source: Deliverables/D2.2/8051/src/RTLabs/redundancyElimination.ml @ 1580

Last change on this file since 1580 was 1580, checked in by tranquil, 9 years ago

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

File size: 17.1 KB
Line 
1(** This module implements partial redundancy elimination, which subsumes
2    common subexpression elimination and loop-invariant code motion.
3    This is a reformulation of material found in Muchnick, Advanced compiler
4    design and implementation. *)
5
6
7open RTLabs
8open AST
9
10module Trans = GraphUtilities.Trans(RTLabsGraph)(RTLabsGraph)
11module Util = GraphUtilities.Util(RTLabsGraph)
12
13(* Notes: To move loop-invariant computation, peeling is needed. It would *)
14(* also profit from algebraic transformations that piece together *)
15(* loop-constants: if x and y are loop-invariants, then x*y*i won't be *)
16(* optimized unless it is transformed to (x*y)*i. Pretty important for *)
17(* array addresses. *)
18
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 } *)
79
80(* Expressions, expression sets, and operations thereof *)
81
82(* Load and store ops are not taken into account, maybe later *)
83type expr =
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))
93  | _ -> None
94
95let expr_of type_of (g : graph) (n : Label.t) : expr option =
96  expr_of_stmt type_of (Label.Map.find n g)
97
98(* the register modified by a node *)
99let modified_at_stmt = RTLabsGraph.modified_at_stmt
100
101let modified_at = RTLabsGraph.modified_at
102
103(* registers on which the value computed at the statement depends, which are*)
104(* needed if the modified register is needed. Below used_at lists those*)
105(* registers that may be needed regardless (i.e. in non-side-effect-free *)
106(* statements).*)
107let vars_of_stmt = function
108  | St_op2 (_, _, Reg s, Reg t, _) ->
109    Register.Set.add s (Register.Set.singleton t)
110  | St_load (_, Reg s, _, _)
111  | St_op1 (_, _, s, _)
112  | St_op2 (_, _, Reg s, _, _)
113  | St_op2 (_, _, _, Reg s, _) -> Register.Set.singleton s
114  | _ -> Register.Set.empty
115
116let vars_of (g : graph) (n : Label.t) : Register.Set.t =
117  vars_of_stmt (Label.Map.find n g)
118
119(* used in possibly non side-effect-free statements *)
120let used_at_stmt stmt =
121  let add_arg s = function
122    | Reg r -> Register.Set.add r s
123    | Imm _ -> s in
124  match stmt with
125    | St_call_id (_, rs, _, _, _)
126    | St_call_ptr (_, rs, _, _, _)
127    | St_tailcall_id (_, rs, _)
128    | St_tailcall_ptr (_, rs, _) ->
129      List.fold_left add_arg Register.Set.empty rs
130    | St_store (_, a, b, _) ->
131      add_arg (add_arg Register.Set.empty a) b
132    | St_return (Some (Reg r))
133    | St_cond (r, _, _) -> Register.Set.singleton r
134    | _ -> Register.Set.empty
135
136let used_at g n = used_at_stmt (Label.Map.find n g)
137
138module ExprOrdered = struct
139  type t = expr
140  let compare = compare
141end
142
143module ExprSet = Set.Make(ExprOrdered)
144module ExprMap = Map.Make(ExprOrdered)
145
146type expr_set = ExprSet.t
147
148let ( ^^ ) = ExprSet.inter
149
150let ( ++ ) = ExprSet.union
151
152let ( ++* ) s = function
153  | None -> s
154  | Some e -> ExprSet.add e s
155
156let ( --* ) s = function
157  | None -> s
158  | Some e -> ExprSet.remove e s
159
160let ( -- ) = ExprSet.diff
161
162let big_inter (f : Label.t -> ExprSet.t) (ls : Label.t list) : ExprSet.t =
163        (* generalized intersection, but in case of empty list it is empty *)
164  match ls with
165    | [] -> ExprSet.empty
166    (* these two cases are singled out for speed, as they will be common *)
167    | [l] -> f l
168    | [l1 ; l2] -> f l1 ^^ f l2
169    | l :: ls ->
170      let inter s l' = s ^^ f l' in
171      List.fold_left inter (f l) ls
172
173let big_union (f : Label.t -> Register.Set.t) (ls : Label.t list)
174    : Register.Set.t =
175  (* generalized union *)
176  let union s l' = Register.Set.union s (f l') in
177  List.fold_left union Register.Set.empty ls
178
179let filter_unchanged (r : Register.t option) (s : expr_set) : expr_set =
180  match r with
181    | None -> s
182    | Some r ->
183      let filter = function
184        | UnOp (_, s, _) when r = s -> false
185        | BinOp (_, s, t, _) when s = Reg r || t = Reg r -> false
186        | _ -> true in
187      ExprSet.filter filter s
188
189module Lpair = struct
190
191        (* A property is a pair of sets of expressions. *)
192  type property = expr_set * expr_set
193
194  let bottom = (ExprSet.empty, ExprSet.empty)
195
196  let equal (ant1, nea1) (ant2, nea2) =
197    ExprSet.equal ant1 ant2 && ExprSet.equal nea1 nea2
198
199  let is_maximal _ = false
200
201end
202
203module Lsing = struct
204
205  (* A property is a set of expressions. *)
206  type property = expr_set
207
208  let bottom = ExprSet.empty
209
210  let equal = ExprSet.equal
211
212  let is_maximal _ = false
213
214end
215
216module Lexprid = struct
217
218  (* A property is a set of expressions and a set of registers. *)
219  type property = expr_set * Register.Set.t
220
221  let bottom = (ExprSet.empty, Register.Set.empty)
222
223  let equal (a, b) (c, d) = ExprSet.equal a c && Register.Set.equal b d
224
225  let is_maximal _ = false
226
227end
228
229module Fpair = Fix.Make (Label.ImpMap) (Lpair)
230
231module Fsing = Fix.Make (Label.ImpMap) (Lsing)
232
233module Fexprid = Fix.Make (Label.ImpMap) (Lexprid)
234
235(* printing tools to debug *)
236
237let print_expr = function
238    (*    | Cst c ->
239          (RTLabsPrinter.print_cst c)*)
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"
253
254let print_valu_pair (valu : Fpair.valuation) (g : graph) (entry : Label.t) =
255  let f lbl _ =
256    Printf.printf "%s: " lbl;
257    print_prop_pair (valu lbl) in
258  Util.dfs_iter f g entry
259
260let print_prop_sing (p : Fsing.property) =
261  let f e = Printf.printf "%s, " (print_expr e) in
262  Printf.printf "{ ";
263  ExprSet.iter f p;
264  Printf.printf "}\n"
265
266let print_valu_sing (valu : Fsing.valuation) (g : graph) (entry : Label.t) =
267  let f lbl _ =
268    Printf.printf "%s: " lbl;
269    print_prop_sing (valu lbl) in
270  Util.dfs_iter f g entry
271
272
273(* ----- PHASE 1 : Anticipatability and erliestness ------ *)
274(* An expression e is anticipatable at point p if every path from p contains  *)
275(* a computation of e and evaluating e at p holds the same result as all such *)
276(* computations. *)
277(* An expression e is earliest at point p if there is no computation of e *)
278(* preceding p giving the same value. *)
279(* We will compute anticipatable expressions and *non*-earliest ones for every*)
280(* point with a single invocation to a fixpoint calculation. *)
281
282
283let semantics_ant_nea
284    (g : graph)
285    (type_of : Register.t -> AST.sig_type)
286    (pred_table : Label.t list Label.Map.t)
287    (lbl : Label.t)
288    (valu : Fpair.valuation)
289    : Fpair.property =
290  let succs = RTLabsGraph.successors (Label.Map.find lbl g) in
291  let preds = Label.Map.find lbl pred_table in
292
293        (* anticipatable expressions at entry *)
294        (* take anticipatable expressions of successors... *)
295  let ant l = fst (valu l) in
296  let nea l = snd (valu l) in
297  let ant_in = big_inter ant succs in
298        (* ... filter out those that contain the register being changed ...*)
299  let ant_in = filter_unchanged (modified_at g lbl) ant_in in
300        (* ... and add the expression being calculated ... *)
301  let ant_in = ant_in ++* expr_of type_of g lbl in
302
303        (* non-earliest expressions at entry *)
304        (* take non-earliest or anticipatable expressions of predecessors, *)
305        (* filtered so that just unchanged expressions leak *)
306  let ant_or_nea l =
307    filter_unchanged (modified_at g l) (ant l ++ nea l) in
308  let nea_in = big_inter ant_or_nea preds in
309
310  (ant_in, nea_in)
311
312let compute_anticipatable_and_non_earliest
313    (f_def : internal_function)
314    (type_of : Register.t -> AST.sig_type)
315    (pred_table : Label.t list Label.Map.t)
316    : Fpair.valuation =
317
318  Fpair.lfp (semantics_ant_nea f_def.f_graph  type_of pred_table)
319
320(* ------------ PHASE 2 : delayedness and lateness ----------- *)
321(* An expression e is delayable at position p there is a point p' preceding it*)
322(* in the control flow where e could be safely placed, and between p'and p *)
323(* excluded e is never used. *)
324
325
326let semantics_delay
327    (g : graph)
328    (type_of : Register.t -> AST.sig_type)
329    (pred_table : Label.t list Label.Map.t)
330    (ant_nea : Fpair.valuation)
331    (lbl : Label.t)
332    (valu : Fsing.valuation)
333    : Fsing.property =
334  let preds = Label.Map.find lbl pred_table in
335
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
340  let delay_in = big_inter rem_pred preds in
341                (* ... and add in anticipatable and earliest expressions *)
342  let (ant, nea) = ant_nea lbl in
343  delay_in ++ (ant -- nea)
344
345let compute_delayed
346    (f_def : internal_function)
347    (type_of : Register.t -> AST.sig_type)
348    (pred_table : Label.t list Label.Map.t)
349    (ant_nea : Fpair.valuation)
350    : Fsing.valuation =
351
352  Fsing.lfp (semantics_delay f_def.f_graph type_of pred_table ant_nea)
353
354(* An expression is latest at p if it cannot be delayed further *)
355let late
356    (g : graph)
357    (type_of : Register.t -> AST.sig_type)
358    (delay : Fsing.valuation)
359    : Fsing.valuation = fun lbl ->
360      let stmt = Label.Map.find lbl g in
361      let succs = RTLabsGraph.successors stmt in
362
363      let eo = match expr_of type_of g lbl with
364        | Some e when ExprSet.mem e (delay lbl) -> Some e
365        | _ -> None in
366
367      (delay lbl -- big_inter delay succs) ++* eo
368
369
370(* --------------- PHASE 3 : isolatedness, optimality and redudancy --------*)
371
372(* An expression e is isolated at point p if on every path from p a use of *)
373(* e is preceded by an optimal computation point for it. These are expressions*)
374(* which will not be touched *)
375(* A variable is used at entry if every use of it later in the execution path *)
376(* is to compute variables which are in turn used. *)
377let semantics_isolated_used
378    (g : graph)
379    (type_of : Register.t -> AST.sig_type)
380    (late : Fsing.valuation)
381    (lbl : Label.t)
382    (valu : Fexprid.valuation)
383    : Fexprid.property =
384
385  let stmt = Label.Map.find lbl g in
386  let succs = RTLabsGraph.successors stmt in
387  let f l = late l ++ (fst (valu l) --* expr_of type_of g l) in
388  let isol = big_inter f succs in
389
390  let f l =
391    let used_out = snd (valu l) in
392    let used_out = match modified_at g l with
393      | Some r when Register.Set.mem r used_out ->
394        Register.Set.union (Register.Set.remove r used_out) (vars_of g l)
395      | _ -> used_out in
396    Register.Set.union used_out (used_at g l) in
397  let used = big_union f succs in
398
399  (isol, used)
400
401let compute_isolated_used
402    (f_def : internal_function)
403    (type_of : Register.t -> AST.sig_type)
404    (delayed : Fsing.valuation)
405    : Fexprid.valuation =
406
407  let graph = f_def.f_graph in
408
409  Fexprid.lfp
410    (semantics_isolated_used graph type_of (late graph type_of delayed))
411
412(* expressions that are optimally placed at point p, without being isolated *)
413let optimal (late : Fsing.valuation) (isol : Fsing.valuation)
414    : Fsing.valuation = fun lbl ->
415      late lbl -- isol lbl
416
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
420    | Some e when ExprSet.mem e (isol lbl) ->
421      false
422    | Some _ -> true
423    | _ -> false
424
425(* mark instructions that modify an unused register *)
426let unused g used lbl =
427  match modified_at g lbl with
428    | Some r when Register.Set.mem r (used lbl) ->
429      false
430    | Some r -> true
431    | _ -> false
432
433(*------ PHASE 4 : place expressions, remove reduntant ones -------------*)
434
435let stmt_of_expr
436    (r : Register.t)
437    (e : expr)
438    (l : Label.t)
439    : statement =
440  match e with
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 =
447    try
448      (tmps, ExprMap.find expr tmps)
449    with
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
480
481(* piecing it all together *)
482let transform_internal f_def =
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
492  let isol = fun lbl -> fst (isol_used lbl) in
493  let used = fun lbl -> snd (isol_used lbl) in
494  let opt = optimal late isol in
495  let redn = redundant f_def.f_graph type_of late isol in
496  let unusd = unused f_def.f_graph used in
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 }
506
507let transform_funct = function
508  | (f, F_int f_def) -> (f, F_int (transform_internal f_def))
509  | f -> f
510
511let trans = Languages.RTLabs, function
512  | Languages.AstRTLabs p ->
513    Languages.AstRTLabs { p with functs = List.map transform_funct p.functs }
514  | _ -> assert false (* wrong language *)
Note: See TracBrowser for help on using the repository browser.