Ignore:
Timestamp:
Dec 1, 2011, 2:50:27 PM (9 years ago)
Author:
tranquil
Message:

implemented constant propagation in LTL
cleaned up translations in optimizations, a new module for translations is available

File:
1 edited

Legend:

Unmodified
Added
Removed
  • Deliverables/D2.2/8051/src/RTLabs/redundancyElimination.ml

    r1572 r1580  
    22    common subexpression elimination and loop-invariant code motion.
    33    This is a reformulation of material found in Muchnick, Advanced compiler
    4     design and implementation.
    5     Along the way we also perform a first rough liveness analysis. *)
     4    design and implementation. *)
    65
    76
    87open RTLabs
    98open AST
     9
     10module Trans = GraphUtilities.Trans(RTLabsGraph)(RTLabsGraph)
     11module Util = GraphUtilities.Util(RTLabsGraph)
    1012
    1113(* Notes: To move loop-invariant computation, peeling is needed. It would *)
     
    1517(* array addresses. *)
    1618
    17 (* ----- PHASE 0 : critical edge elimination ------ *)
    18 
    19 (* a critical edge is one between a node with several successors and a node*)
    20 (* with several predecessors. In order for the optimization to work best   *)
    21 (* these must be avoided, inserting an empty node in-between. *)
    22 (* Note: maybe in our case we can avoid this, as branchings will have *)
    23 (* emit cost nodes afterwards. To be checked. Empirically I haven't found *)
    24 (* an example where this transformation really applies. *)
    25 
    26 let count_predecessors
    27     (g : graph)
    28     : int Label.Map.t =
    29   let f lbl s m =
    30     let succs = RTLabsUtilities.statement_successors s in
    31     let f' m succ =
    32       try
    33         Label.Map.add succ (1 + Label.Map.find succ m) m
    34       with
    35         | Not_found -> Label.Map.add succ 1 m in
    36     let m = List.fold_left f' m succs in
    37     if Label.Map.mem lbl m then m else Label.Map.add lbl 0 m in
    38   Label.Map.fold f g Label.Map.empty
    39 
    40 module LabelPairSet = Set.Make(struct
    41   type t = Label.t * Label.t
    42   let compare = compare
    43 end)
    44 
    45 let find_critical_edges (g : graph) : LabelPairSet.t =
    46   let pred_count = count_predecessors g in
    47   let add_if_2_preds l1 s l2 =
    48     if Label.Map.find l2 pred_count < 2 then s else
    49       LabelPairSet.add (l1, l2) s in
    50   let f l stmt s = match stmt with
    51     | St_cond(_, l1, l2) ->
    52       add_if_2_preds l (add_if_2_preds l s l1) l2
    53     | St_jumptable (_, ls) when List.length ls > 1 ->
    54       List.fold_left (add_if_2_preds l) s ls
    55     | _ -> s in
    56   Label.Map.fold f g LabelPairSet.empty
    57 
    58 (* note to self: there is a degenrate case that is not eliminated by the *)
    59 (* following, namely (top to bottom) *)
    60 (*               src                *)
    61 (*               / \                *)
    62 (*              |   |               *)
    63 (*               \ /                *)
    64 (*               tgt                *)
    65 (* In this case the result will be  *)
    66 (*               src                *)
    67 (*               / \                *)
    68 (*               \ /                *)
    69 (*               new                *)
    70 (*                |                 *)
    71 (*               tgt                *)
    72 (* with two critical edges still in place. To be checked whether it *)
    73 (* compromises the optimization, I think not *)
    74 
    75 let critical_edge_elimination
    76     (f_def : internal_function)
    77     : internal_function =
    78   let g = f_def.f_graph in
    79   let fresh () = Label.Gen.fresh f_def.f_luniverse in
    80   let critical_edges = find_critical_edges g in
    81   let rem (src, tgt) g =
    82     snd (RTLabsUtilities.insert_in_between fresh g src tgt (St_skip tgt)) in
    83   { f_def with f_graph = LabelPairSet.fold rem critical_edges g }
     19(* Why I'm removing critical edge elimination:
     20   It seems to me that the invariant about the presence of labels after
     21   every branching prevents critical edges from appearing: every time a node
     22   has more than one successor, all of its successors are cost emit statements.
     23
     24   We cannot jump directly to such a cost emittance from elsewhere. *)
     25
     26(* (\* ----- PHASE 0 : critical edge elimination ------ *\) *)
     27
     28(* (\* a critical edge is one between a node with several successors and a node*\) *)
     29(* (\* with several predecessors. In order for the optimization to work best   *\) *)
     30(* (\* these must be avoided, inserting an empty node in-between. *\) *)
     31(* (\* Note: maybe in our case we can avoid this, as branchings will have *\) *)
     32(* (\* emit cost nodes afterwards. To be checked. Empirically I haven't found *\) *)
     33(* (\* an example where this transformation really applies. *\) *)
     34
     35(* (\* a labels will not be in the domain of the map if it does not have any *)
     36(*    predecessor. It will be bound to false if it has just one of them, *)
     37(*    and it will bound to true is it has more than two *\) *)
     38(* let mark_multi_predecessor *)
     39(*     (g : graph) *)
     40(*     : bool Label.Map.t = *)
     41(*   let f lbl s m = *)
     42(*     let f' m succ = *)
     43(*       try *)
     44(*         if Label.Map.find succ m then *)
     45(*           m *)
     46(*         else *)
     47(*           Label.Map.add succ true m *)
     48(*       with *)
     49(*         | Not_found -> Label.Map.add succ false m in *)
     50(*     List.fold_left f' m (RTLabsGraph.successors s) in *)
     51(*   Label.Map.fold f g Label.Map.empty *)
     52
     53(* (\* will give the set of nodes that *)
     54(*    1) have more than one successor *)
     55(*    2) at least one of those successors has more *)
     56(*       than one predecessor *\) *)
     57(* let remove_critical_edges fresh g = *)
     58(*   let multi_pred_marks = mark_multi_predecessor g in *)
     59(*   let is_multi_pred lbl = *)
     60(*     try Label.Map.find lbl multi_pred_marks with *)
     61(*       | Not_found -> false in *)
     62(*   let trans () l = function *)
     63(*     | St_cond (r, l1, l2) when is_multi_pred l1 || is_multi_pred l2 -> *)
     64(*         ((), [St_cond (r, l, l)], [[] ; []], [[l1] ; [l2]]) *)
     65(*     | St_jumptable (r, ls) *)
     66(*       when List.length ls > 1 && List.exists is_multi_pred ls -> *)
     67(*       let blocks = MiscPottier.make [] (List.length ls) in *)
     68(*       let succs = List.map (fun l -> [l]) ls in *)
     69(*       ((), [St_jumptable (r, [])], blocks, succs) *)
     70(*     | stmt -> ((), [], [[stmt]], [RTLabsGraph.successors stmt]) in *)
     71(*   snd (Trans.translate_general trans fresh () g) *)
     72
     73(* let critical_edge_elimination *)
     74(*     (f_def : internal_function) *)
     75(*     : internal_function = *)
     76(*   let g = f_def.f_graph in *)
     77(*   let fresh () = Label.Gen.fresh f_def.f_luniverse in *)
     78(*   { f_def with f_graph = remove_critical_edges fresh g } *)
    8479
    8580(* Expressions, expression sets, and operations thereof *)
     
    8782(* Load and store ops are not taken into account, maybe later *)
    8883type expr =
    89   (*        | Cst of cst (* do we need to consider constants? maybe only big ones? *)*)
    90   | UnOp of op1 * Register.t
    91   | BinOp of op2 * argument * argument
    92 
    93 let expr_of_stmt (s : statement) : expr option = match s with
    94         (*        | St_cst (_, c, _) -> Some (Cst c)*)
    95   | St_op1 (op, _, s, _) when op <> Op_id -> Some (UnOp (op, s))
    96   | St_op2 (op, _, s, t, _) -> Some (BinOp (op, s, t))
     84  (* | Cst of cst (\* do we need to consider constants? only big ones? *\) *)
     85  | UnOp of op1 * Register.t * AST.sig_type
     86  | BinOp of op2 * argument * argument * AST.sig_type
     87
     88let expr_of_stmt type_of (s : statement) : expr option = match s with
     89  (* | St_cst (_, c, _) -> Some (Cst c) *)
     90  | St_op1 (op, r, s, _) when op <> Op_id ->
     91    Some (UnOp (op, s, type_of r))
     92  | St_op2 (op, r, s, t, _) -> Some (BinOp (op, s, t, type_of r))
    9793  | _ -> None
    9894
    99 let expr_of (g : graph) (n : Label.t) : expr option =
    100   expr_of_stmt (Label.Map.find n g)
     95let expr_of type_of (g : graph) (n : Label.t) : expr option =
     96  expr_of_stmt type_of (Label.Map.find n g)
    10197
    10298(* the register modified by a node *)
    103 let modified_at_stmt = RTLabsUtilities.modified_at_stmt
    104 
    105 let modified_at = RTLabsUtilities.modified_at
     99let modified_at_stmt = RTLabsGraph.modified_at_stmt
     100
     101let modified_at = RTLabsGraph.modified_at
    106102
    107103(* registers on which the value computed at the statement depends, which are*)
     
    186182    | Some r ->
    187183      let filter = function
    188         | UnOp (_, s) when r = s -> false
    189         | BinOp (_, s, t) when s = Reg r || t = Reg r -> false
     184        | UnOp (_, s, _) when r = s -> false
     185        | BinOp (_, s, t, _) when s = Reg r || t = Reg r -> false
    190186        | _ -> true in
    191187      ExprSet.filter filter s
     
    242238    (*    | Cst c ->
    243239          (RTLabsPrinter.print_cst c)*)
    244   | UnOp (op, r) ->
    245     (RTLabsPrinter.print_op1 op r)
    246   | BinOp (op, r, s) ->
    247     (RTLabsPrinter.print_op2 op r s)
    248 
    249 let print_prop_pair (p : Fpair.property) = let (ant, nea) = p in
    250                                            let f e = Printf.printf "%s, " (print_expr e) in
    251                                            Printf.printf "{ ";
    252                                            ExprSet.iter f ant;
    253                                            Printf.printf "}; { ";
    254                                            ExprSet.iter f nea;
    255                                            Printf.printf "}\n"
     240  | UnOp (op, r, t) ->
     241    (RTLabsPrinter.print_op1 op r ^ " : " ^ Primitive.print_type t)
     242  | BinOp (op, r, s, t) ->
     243    (RTLabsPrinter.print_op2 op r s  ^ " : " ^ Primitive.print_type t)
     244
     245let print_prop_pair (p : Fpair.property) =
     246  let (ant, nea) = p in
     247  let f e = Printf.printf "%s, " (print_expr e) in
     248  Printf.printf "{ ";
     249  ExprSet.iter f ant;
     250  Printf.printf "}; { ";
     251  ExprSet.iter f nea;
     252  Printf.printf "}\n"
    256253
    257254let print_valu_pair (valu : Fpair.valuation) (g : graph) (entry : Label.t) =
     
    259256    Printf.printf "%s: " lbl;
    260257    print_prop_pair (valu lbl) in
    261   RTLabsUtilities.dfs_iter f g entry
     258  Util.dfs_iter f g entry
    262259
    263260let print_prop_sing (p : Fsing.property) =
     
    271268    Printf.printf "%s: " lbl;
    272269    print_prop_sing (valu lbl) in
    273   RTLabsUtilities.dfs_iter f g entry
     270  Util.dfs_iter f g entry
    274271
    275272
     
    286283let semantics_ant_nea
    287284    (g : graph)
     285    (type_of : Register.t -> AST.sig_type)
    288286    (pred_table : Label.t list Label.Map.t)
    289287    (lbl : Label.t)
    290288    (valu : Fpair.valuation)
    291289    : Fpair.property =
    292   let succs = RTLabsUtilities.statement_successors (Label.Map.find lbl g) in
     290  let succs = RTLabsGraph.successors (Label.Map.find lbl g) in
    293291  let preds = Label.Map.find lbl pred_table in
    294292
     
    301299  let ant_in = filter_unchanged (modified_at g lbl) ant_in in
    302300        (* ... and add the expression being calculated ... *)
    303   let ant_in = ant_in ++* expr_of g lbl in
     301  let ant_in = ant_in ++* expr_of type_of g lbl in
    304302
    305303        (* non-earliest expressions at entry *)
     
    314312let compute_anticipatable_and_non_earliest
    315313    (f_def : internal_function)
     314    (type_of : Register.t -> AST.sig_type)
    316315    (pred_table : Label.t list Label.Map.t)
    317316    : Fpair.valuation =
    318317
    319   Fpair.lfp (semantics_ant_nea f_def.f_graph pred_table)
     318  Fpair.lfp (semantics_ant_nea f_def.f_graph  type_of pred_table)
    320319
    321320(* ------------ PHASE 2 : delayedness and lateness ----------- *)
     
    327326let semantics_delay
    328327    (g : graph)
     328    (type_of : Register.t -> AST.sig_type)
    329329    (pred_table : Label.t list Label.Map.t)
    330330    (ant_nea : Fpair.valuation)
     
    334334  let preds = Label.Map.find lbl pred_table in
    335335
    336                 (* delayed expressions at entry *)
    337                 (* take delayed expressions of predecessors which are not the expressions *)
    338                 (* of such predecessors... *)
    339   let rem_pred lbl' = valu lbl' --* expr_of g lbl' in
     336  (* delayed expressions at entry *)
     337  (* take delayed expressions of predecessors which are not the expressions *)
     338  (* of such predecessors... *)
     339  let rem_pred lbl' = valu lbl' --* expr_of type_of g lbl' in
    340340  let delay_in = big_inter rem_pred preds in
    341341                (* ... and add in anticipatable and earliest expressions *)
     
    345345let compute_delayed
    346346    (f_def : internal_function)
     347    (type_of : Register.t -> AST.sig_type)
    347348    (pred_table : Label.t list Label.Map.t)
    348349    (ant_nea : Fpair.valuation)
    349350    : Fsing.valuation =
    350351
    351   Fsing.lfp (semantics_delay f_def.f_graph pred_table ant_nea)
     352  Fsing.lfp (semantics_delay f_def.f_graph type_of pred_table ant_nea)
    352353
    353354(* An expression is latest at p if it cannot be delayed further *)
    354 let late (g : graph) (delay : Fsing.valuation)
     355let late
     356    (g : graph)
     357    (type_of : Register.t -> AST.sig_type)
     358    (delay : Fsing.valuation)
    355359    : Fsing.valuation = fun lbl ->
    356360      let stmt = Label.Map.find lbl g in
    357       let succs = RTLabsUtilities.statement_successors stmt in
    358 
    359       let eo = match expr_of g lbl with
     361      let succs = RTLabsGraph.successors stmt in
     362
     363      let eo = match expr_of type_of g lbl with
    360364        | Some e when ExprSet.mem e (delay lbl) -> Some e
    361365        | _ -> None in
     
    373377let semantics_isolated_used
    374378    (g : graph)
     379    (type_of : Register.t -> AST.sig_type)
    375380    (late : Fsing.valuation)
    376381    (lbl : Label.t)
     
    379384
    380385  let stmt = Label.Map.find lbl g in
    381   let succs = RTLabsUtilities.statement_successors stmt in
    382   let f l = late l ++ (fst (valu l) --* expr_of g l) in
     386  let succs = RTLabsGraph.successors stmt in
     387  let f l = late l ++ (fst (valu l) --* expr_of type_of g l) in
    383388  let isol = big_inter f succs in
    384389
     
    396401let compute_isolated_used
    397402    (f_def : internal_function)
     403    (type_of : Register.t -> AST.sig_type)
    398404    (delayed : Fsing.valuation)
    399405    : Fexprid.valuation =
     
    401407  let graph = f_def.f_graph in
    402408
    403   Fexprid.lfp (semantics_isolated_used graph (late graph delayed))
     409  Fexprid.lfp
     410    (semantics_isolated_used graph type_of (late graph type_of delayed))
    404411
    405412(* expressions that are optimally placed at point p, without being isolated *)
     
    408415      late lbl -- isol lbl
    409416
    410 (* mark instructions that are redundant and can be removed *)
    411 let redundant g late isol lbl =
    412   match expr_of g lbl with
     417(* mark instructions that are redundant and can be replaced by a copy *)
     418let redundant g type_of late isol lbl =
     419  match expr_of type_of g lbl with
    413420    | Some e when ExprSet.mem e (isol lbl) ->
    414421      false
     
    426433(*------ PHASE 4 : place expressions, remove reduntant ones -------------*)
    427434
    428 let remove_redundant def is_redundant is_unused =
    429   let g = def.f_graph in
    430   let types = RTLabsUtilities.computes_type_map def in
    431   let f lbl stmt (g', s) =
    432     if is_unused lbl then
    433       let succ = List.hd (RTLabsUtilities.statement_successors stmt) in
    434       (Label.Map.add lbl (St_skip succ) g', s) else
    435       if is_redundant lbl then
    436         match modified_at_stmt stmt, expr_of_stmt stmt with
    437           | Some r, Some e ->
    438             let succ = List.hd (RTLabsUtilities.statement_successors stmt) in
    439             let (s, (tmp, _)) =
    440               try
    441                 (s, ExprMap.find e s)
    442               with
    443                 | Not_found ->
    444                   let tmp =        Register.fresh def.f_runiverse in
    445                   let typ = Register.Map.find r types in
    446                   let s = ExprMap.add e (tmp, typ) s in
    447                   (s, (tmp, typ)) in
    448             let new_stmt = St_op1 (Op_id, r, tmp, succ) in
    449             (Label.Map.add lbl new_stmt g', s)
    450           | _ -> assert false
    451       else (g', s) in
    452   let (g, s) = Label.Map.fold f g (g, ExprMap.empty) in
    453   ({ def with f_graph = g }, s)
    454 
    455435let stmt_of_expr
    456436    (r : Register.t)
     
    459439    : statement =
    460440  match e with
    461                 (*                | Cst c -> St_cst (r, c, l)*)
    462     | UnOp (op, s) -> St_op1 (op, r, s, l)
    463     | BinOp (op, s, t) -> St_op2 (op, r, s, t, l)
    464 
    465 let insert_after exprs redundants g freshl lbl next =
    466   let f e (next', g') =
     441    (* | Cst c -> St_cst (r, c, l) *)
     442    | UnOp (op, s, _) -> St_op1 (op, r, s, l)
     443    | BinOp (op, s, t, _) -> St_op2 (op, r, s, t, l)
     444
     445let trans freshr type_of is_redundant is_unused optimal tmps lbl stmt =
     446  let get_r expr tmps =
    467447    try
    468       let (tmp, _) = ExprMap.find e redundants in
    469       let opt_calc = stmt_of_expr tmp e next' in
    470       RTLabsUtilities.insert_in_between freshl g' lbl next' opt_calc
     448      (tmps, ExprMap.find expr tmps)
    471449    with
    472       | Not_found -> (next', g') in
    473   snd (ExprSet.fold f exprs (next, g))
    474 
    475 let insert_before exprs redundants g freshl lbl stmt =
    476   let f e (stmt', g') =
    477     try
    478       let (tmp, _) = ExprMap.find e redundants in
    479       let n_lbl = freshl () in
    480       let opt_calc = stmt_of_expr tmp e n_lbl in
    481       let g' = Label.Map.add n_lbl stmt' g' in
    482       let g' = Label.Map.add lbl opt_calc g' in
    483       (opt_calc, g')
    484     with
    485       | Not_found -> (stmt', g') in
    486   snd (ExprSet.fold f exprs (stmt, g))
    487 
    488 let store_optimal_computation (def, redundants) optimal =
    489         (* first add the temporaries' declarations *)
    490   let f _ (r, typ) vars = (r, typ) :: vars in
    491   let f_locals = ExprMap.fold f redundants def.f_locals in
    492 
    493         (* now the actual replacement *)
    494   let g = def.f_graph in
    495   let freshl () = Label.Gen.fresh def.f_luniverse in
    496   let f lbl stmt g' =
    497     match stmt with
    498       (* in case of cost emittance the optimal calculations are inserted *)
    499       (* after, to preserve preciness *)
    500       | St_cost (_, next) ->
    501          insert_after (optimal lbl) redundants g' freshl lbl next
    502       | _ ->
    503         insert_before (optimal lbl) redundants g' freshl lbl stmt in
    504   { def with f_locals = f_locals; f_graph = Label.Map.fold f g g }
    505 
     450      | Not_found ->
     451        let r = freshr () in
     452        (ExprMap.add expr r tmps, r) in
     453  let f expr (tmps, instrs) =
     454    let (tmps, r) = get_r expr tmps in
     455    (tmps, stmt_of_expr r expr lbl :: instrs) in
     456  let (tmps, optimals) = ExprSet.fold f (optimal lbl) (tmps, []) in
     457  match stmt, is_unused lbl, is_redundant lbl with
     458    | St_cost (cost_lbl, next) as s, _, _ ->
     459      (* in this case we place optimal calculations after the cost one *)
     460      (tmps, s :: optimals)
     461    | _, true, _ ->
     462      (* here we can remove the statement altogether *)
     463      (tmps, optimals)
     464    | _, _, false ->
     465      (tmps, optimals @ [stmt])
     466    | _, _, true ->
     467      match modified_at_stmt stmt, expr_of_stmt type_of stmt with
     468        | Some s, Some e ->
     469          let (tmps, r) = get_r e tmps in
     470          (tmps, optimals @ [St_op1 (Op_id, s, r, lbl)])
     471        | _ -> assert false (* if redundant must be an expression *)
     472
     473let type_of_expr = function
     474  | UnOp (_, _, t) -> t
     475  | BinOp (_, _, _, t) -> t
     476
     477let add_decls expr_regs decls =
     478  let f e r decls = (r, type_of_expr e) :: decls in
     479  ExprMap.fold f expr_regs decls
    506480
    507481(* piecing it all together *)
    508482let transform_internal f_def =
    509   let pred_table = RTLabsUtilities.compute_predecessor_lists f_def.f_graph in
    510   let ant_nea = compute_anticipatable_and_non_earliest f_def pred_table in
    511   let delay = compute_delayed f_def pred_table ant_nea in
    512   let late = late f_def.f_graph delay in
    513   let isol_used = compute_isolated_used f_def delay in
     483  let pred_table = Util.compute_predecessor_lists f_def.f_graph in
     484  let type_table = RTLabsGraph.compute_type_map f_def in
     485  let type_of r = Register.Map.find r type_table in
     486  (* analysis *)
     487  let ant_nea =
     488    compute_anticipatable_and_non_earliest f_def type_of pred_table in
     489  let delay = compute_delayed f_def type_of pred_table ant_nea in
     490  let late = late f_def.f_graph type_of delay in
     491  let isol_used = compute_isolated_used f_def type_of delay in
    514492  let isol = fun lbl -> fst (isol_used lbl) in
    515493  let used = fun lbl -> snd (isol_used lbl) in
    516494  let opt = optimal late isol in
    517   let redn = redundant f_def.f_graph late isol in
     495  let redn = redundant f_def.f_graph type_of late isol in
    518496  let unusd = unused f_def.f_graph used in
    519   let f lbl _ s = Register.Set.union (used lbl) s in
    520   let regs_used =
    521     RTLabsUtilities.dfs_fold f f_def.f_graph f_def.f_entry Register.Set.empty in
    522   let filter (r, _) = Register.Set.mem r regs_used in
    523   let f_def = { f_def with f_locals = List.filter filter f_def.f_locals } in
    524   store_optimal_computation (remove_redundant f_def redn unusd) opt
    525 
     497  (* end of analysis *)
     498  let freshr () = Register.fresh f_def.f_runiverse in
     499  let freshl () = Label.Gen.fresh f_def.f_luniverse in
     500  let trans = trans freshr type_of redn unusd opt in
     501  let expr_regs = ExprMap.empty in
     502  let (expr_regs, g) = Trans.translate freshl trans expr_regs f_def.f_graph in
     503  let d = add_decls expr_regs f_def.f_locals in
     504
     505  { f_def with f_locals = d ; f_graph = g }
    526506
    527507let transform_funct = function
Note: See TracChangeset for help on using the changeset viewer.