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

Last change on this file was 1589, checked in by tranquil, 9 years ago
  • turned to argument-less return statements for RTLabs and RTL (there was a hidden invariant, for which the arguments of return statements where equal to the f_result field of the function definition: they were useless and an optimization was breaking the compilation)
  • corrected a bug in liveness analysis I had introduced
File size: 17.3 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 ret 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_cond (r, _, _) -> Register.Set.singleton r
133    | St_return ->
134      begin match ret with
135        | Some (r, _) -> Register.Set.singleton r
136        | None ->  Register.Set.empty
137      end
138    | _ -> Register.Set.empty
139
140let used_at ret g n = used_at_stmt ret (Label.Map.find n g)
141
142module ExprOrdered = struct
143  type t = expr
144  let compare = compare
145end
146
147module ExprSet = Set.Make(ExprOrdered)
148module ExprMap = Map.Make(ExprOrdered)
149
150type expr_set = ExprSet.t
151
152let ( ^^ ) = ExprSet.inter
153
154let ( ++ ) = ExprSet.union
155
156let ( ++* ) s = function
157  | None -> s
158  | Some e -> ExprSet.add e s
159
160let ( --* ) s = function
161  | None -> s
162  | Some e -> ExprSet.remove e s
163
164let ( -- ) = ExprSet.diff
165
166let big_inter (f : Label.t -> ExprSet.t) (ls : Label.t list) : ExprSet.t =
167        (* generalized intersection, but in case of empty list it is empty *)
168  match ls with
169    | [] -> ExprSet.empty
170    (* these two cases are singled out for speed, as they will be common *)
171    | [l] -> f l
172    | [l1 ; l2] -> f l1 ^^ f l2
173    | l :: ls ->
174      let inter s l' = s ^^ f l' in
175      List.fold_left inter (f l) ls
176
177let big_union (f : Label.t -> Register.Set.t) (ls : Label.t list)
178    : Register.Set.t =
179  (* generalized union *)
180  let union s l' = Register.Set.union s (f l') in
181  List.fold_left union Register.Set.empty ls
182
183let filter_unchanged (r : Register.t option) (s : expr_set) : expr_set =
184  match r with
185    | None -> s
186    | Some r ->
187      let filter = function
188        | UnOp (_, s, _) when r = s -> false
189        | BinOp (_, s, t, _) when s = Reg r || t = Reg r -> false
190        | _ -> true in
191      ExprSet.filter filter s
192
193module Lpair = struct
194
195        (* A property is a pair of sets of expressions. *)
196  type property = expr_set * expr_set
197
198  let bottom = (ExprSet.empty, ExprSet.empty)
199
200  let equal (ant1, nea1) (ant2, nea2) =
201    ExprSet.equal ant1 ant2 && ExprSet.equal nea1 nea2
202
203  let is_maximal _ = false
204
205end
206
207module Lsing = struct
208
209  (* A property is a set of expressions. *)
210  type property = expr_set
211
212  let bottom = ExprSet.empty
213
214  let equal = ExprSet.equal
215
216  let is_maximal _ = false
217
218end
219
220module Lexprid = struct
221
222  (* A property is a set of expressions and a set of registers. *)
223  type property = expr_set * Register.Set.t
224
225  let bottom = (ExprSet.empty, Register.Set.empty)
226
227  let equal (a, b) (c, d) = ExprSet.equal a c && Register.Set.equal b d
228
229  let is_maximal _ = false
230
231end
232
233module Fpair = Fix.Make (Label.ImpMap) (Lpair)
234
235module Fsing = Fix.Make (Label.ImpMap) (Lsing)
236
237module Fexprid = Fix.Make (Label.ImpMap) (Lexprid)
238
239(* printing tools to debug *)
240
241let print_expr = function
242    (*    | Cst c ->
243          (RTLabsPrinter.print_cst c)*)
244  | UnOp (op, r, t) ->
245    (RTLabsPrinter.print_op1 op r ^ " : " ^ Primitive.print_type t)
246  | BinOp (op, r, s, t) ->
247    (RTLabsPrinter.print_op2 op r s  ^ " : " ^ Primitive.print_type t)
248
249let print_prop_pair (p : Fpair.property) =
250  let (ant, nea) = p in
251  let f e = Printf.printf "%s, " (print_expr e) in
252  Printf.printf "{ ";
253  ExprSet.iter f ant;
254  Printf.printf "}; { ";
255  ExprSet.iter f nea;
256  Printf.printf "}\n"
257
258let print_valu_pair (valu : Fpair.valuation) (g : graph) (entry : Label.t) =
259  let f lbl _ =
260    Printf.printf "%s: " lbl;
261    print_prop_pair (valu lbl) in
262  Util.dfs_iter f g entry
263
264let print_prop_sing (p : Fsing.property) =
265  let f e = Printf.printf "%s, " (print_expr e) in
266  Printf.printf "{ ";
267  ExprSet.iter f p;
268  Printf.printf "}\n"
269
270let print_valu_sing (valu : Fsing.valuation) (g : graph) (entry : Label.t) =
271  let f lbl _ =
272    Printf.printf "%s: " lbl;
273    print_prop_sing (valu lbl) in
274  Util.dfs_iter f g entry
275
276
277(* ----- PHASE 1 : Anticipatability and erliestness ------ *)
278(* An expression e is anticipatable at point p if every path from p contains  *)
279(* a computation of e and evaluating e at p holds the same result as all such *)
280(* computations. *)
281(* An expression e is earliest at point p if there is no computation of e *)
282(* preceding p giving the same value. *)
283(* We will compute anticipatable expressions and *non*-earliest ones for every*)
284(* point with a single invocation to a fixpoint calculation. *)
285
286
287let semantics_ant_nea
288    (g : graph)
289    (type_of : Register.t -> AST.sig_type)
290    (pred_table : Label.t list Label.Map.t)
291    (lbl : Label.t)
292    (valu : Fpair.valuation)
293    : Fpair.property =
294  let succs = RTLabsGraph.successors (Label.Map.find lbl g) in
295  let preds = Label.Map.find lbl pred_table in
296
297        (* anticipatable expressions at entry *)
298        (* take anticipatable expressions of successors... *)
299  let ant l = fst (valu l) in
300  let nea l = snd (valu l) in
301  let ant_in = big_inter ant succs in
302        (* ... filter out those that contain the register being changed ...*)
303  let ant_in = filter_unchanged (modified_at g lbl) ant_in in
304        (* ... and add the expression being calculated ... *)
305  let ant_in = ant_in ++* expr_of type_of g lbl in
306
307        (* non-earliest expressions at entry *)
308        (* take non-earliest or anticipatable expressions of predecessors, *)
309        (* filtered so that just unchanged expressions leak *)
310  let ant_or_nea l =
311    filter_unchanged (modified_at g l) (ant l ++ nea l) in
312  let nea_in = big_inter ant_or_nea preds in
313
314  (ant_in, nea_in)
315
316let compute_anticipatable_and_non_earliest
317    (f_def : internal_function)
318    (type_of : Register.t -> AST.sig_type)
319    (pred_table : Label.t list Label.Map.t)
320    : Fpair.valuation =
321
322  Fpair.lfp (semantics_ant_nea f_def.f_graph  type_of pred_table)
323
324(* ------------ PHASE 2 : delayedness and lateness ----------- *)
325(* An expression e is delayable at position p there is a point p' preceding it*)
326(* in the control flow where e could be safely placed, and between p'and p *)
327(* excluded e is never used. *)
328
329
330let semantics_delay
331    (g : graph)
332    (type_of : Register.t -> AST.sig_type)
333    (pred_table : Label.t list Label.Map.t)
334    (ant_nea : Fpair.valuation)
335    (lbl : Label.t)
336    (valu : Fsing.valuation)
337    : Fsing.property =
338  let preds = Label.Map.find lbl pred_table in
339
340  (* delayed expressions at entry *)
341  (* take delayed expressions of predecessors which are not the expressions *)
342  (* of such predecessors... *)
343  let rem_pred lbl' = valu lbl' --* expr_of type_of g lbl' in
344  let delay_in = big_inter rem_pred preds in
345                (* ... and add in anticipatable and earliest expressions *)
346  let (ant, nea) = ant_nea lbl in
347  delay_in ++ (ant -- nea)
348
349let compute_delayed
350    (f_def : internal_function)
351    (type_of : Register.t -> AST.sig_type)
352    (pred_table : Label.t list Label.Map.t)
353    (ant_nea : Fpair.valuation)
354    : Fsing.valuation =
355
356  Fsing.lfp (semantics_delay f_def.f_graph type_of pred_table ant_nea)
357
358(* An expression is latest at p if it cannot be delayed further *)
359let late
360    (g : graph)
361    (type_of : Register.t -> AST.sig_type)
362    (delay : Fsing.valuation)
363    : Fsing.valuation = fun lbl ->
364      let stmt = Label.Map.find lbl g in
365      let succs = RTLabsGraph.successors stmt in
366
367      let eo = match expr_of type_of g lbl with
368        | Some e when ExprSet.mem e (delay lbl) -> Some e
369        | _ -> None in
370
371      (delay lbl -- big_inter delay succs) ++* eo
372
373
374(* --------------- PHASE 3 : isolatedness, optimality and redudancy --------*)
375
376(* An expression e is isolated at point p if on every path from p a use of *)
377(* e is preceded by an optimal computation point for it. These are expressions*)
378(* which will not be touched *)
379(* A variable is used at entry if every use of it later in the execution path *)
380(* is to compute variables which are in turn used. *)
381let semantics_isolated_used
382    (g : graph)
383    (type_of : Register.t -> AST.sig_type)
384    (ret : (Register.t * AST.sig_type) option)
385    (late : Fsing.valuation)
386    (lbl : Label.t)
387    (valu : Fexprid.valuation)
388    : Fexprid.property =
389
390  let stmt = Label.Map.find lbl g in
391  let succs = RTLabsGraph.successors stmt in
392  let f l = late l ++ (fst (valu l) --* expr_of type_of g l) in
393  let isol = big_inter f succs in
394
395  let f l =
396    let used_out = snd (valu l) in
397    let used_out = match modified_at g l with
398      | Some r when Register.Set.mem r used_out ->
399        Register.Set.union (Register.Set.remove r used_out) (vars_of g l)
400      | _ -> used_out in
401    Register.Set.union used_out (used_at ret g l) in
402  let used = big_union f succs in
403
404  (isol, used)
405
406let compute_isolated_used
407    (f_def : internal_function)
408    (type_of : Register.t -> AST.sig_type)
409    (delayed : Fsing.valuation)
410    : Fexprid.valuation =
411
412  let graph = f_def.f_graph in
413  let ret = f_def.f_result in
414
415  Fexprid.lfp
416    (semantics_isolated_used graph type_of ret (late graph type_of delayed))
417
418(* expressions that are optimally placed at point p, without being isolated *)
419let optimal (late : Fsing.valuation) (isol : Fsing.valuation)
420    : Fsing.valuation = fun lbl ->
421      late lbl -- isol lbl
422
423(* mark instructions that are redundant and can be replaced by a copy *)
424let redundant g type_of late isol lbl =
425  match expr_of type_of g lbl with
426    | Some e when ExprSet.mem e (isol lbl) ->
427      false
428    | Some _ -> true
429    | _ -> false
430
431(* mark instructions that modify an unused register *)
432let unused g used lbl =
433  match modified_at g lbl with
434    | Some r when Register.Set.mem r (used lbl) ->
435      false
436    | Some r -> true
437    | _ -> false
438
439(*------ PHASE 4 : place expressions, remove reduntant ones -------------*)
440
441let stmt_of_expr
442    (r : Register.t)
443    (e : expr)
444    (l : Label.t)
445    : statement =
446  match e with
447    (* | Cst c -> St_cst (r, c, l) *)
448    | UnOp (op, s, _) -> St_op1 (op, r, s, l)
449    | BinOp (op, s, t, _) -> St_op2 (op, r, s, t, l)
450
451let trans freshr type_of is_redundant is_unused optimal tmps lbl stmt =
452  let get_r expr tmps =
453    try
454      (tmps, ExprMap.find expr tmps)
455    with
456      | Not_found ->
457        let r = freshr () in
458        (ExprMap.add expr r tmps, r) in
459  let f expr (tmps, instrs) =
460    let (tmps, r) = get_r expr tmps in
461    (tmps, stmt_of_expr r expr lbl :: instrs) in
462  let (tmps, optimals) = ExprSet.fold f (optimal lbl) (tmps, []) in
463  match stmt, is_unused lbl, is_redundant lbl with
464    | St_cost (cost_lbl, next) as s, _, _ ->
465      (* in this case we place optimal calculations after the cost one *)
466      (tmps, s :: optimals)
467    | _, true, _ ->
468      (* here we can remove the statement altogether *)
469      (tmps, optimals)
470    | _, _, false ->
471      (tmps, optimals @ [stmt])
472    | _, _, true ->
473      match modified_at_stmt stmt, expr_of_stmt type_of stmt with
474        | Some s, Some e ->
475          let (tmps, r) = get_r e tmps in
476          (tmps, optimals @ [St_op1 (Op_id, s, r, lbl)])
477        | _ -> assert false (* if redundant must be an expression *)
478
479let type_of_expr = function
480  | UnOp (_, _, t) -> t
481  | BinOp (_, _, _, t) -> t
482
483let add_decls expr_regs decls =
484  let f e r decls = (r, type_of_expr e) :: decls in
485  ExprMap.fold f expr_regs decls
486
487(* piecing it all together *)
488let transform_internal f_def =
489  let pred_table = Util.compute_predecessor_lists f_def.f_graph in
490  let type_table = RTLabsGraph.compute_type_map f_def in
491  let type_of r = Register.Map.find r type_table in
492  (* analysis *)
493  let ant_nea =
494    compute_anticipatable_and_non_earliest f_def type_of pred_table in
495  let delay = compute_delayed f_def type_of pred_table ant_nea in
496  let late = late f_def.f_graph type_of delay in
497  let isol_used = compute_isolated_used f_def type_of delay in
498  let isol = fun lbl -> fst (isol_used lbl) in
499  let used = fun lbl -> snd (isol_used lbl) in
500  let opt = optimal late isol in
501  let redn = redundant f_def.f_graph type_of late isol in
502  let unusd = unused f_def.f_graph used in
503  (* end of analysis *)
504  let freshr () = Register.fresh f_def.f_runiverse in
505  let freshl () = Label.Gen.fresh f_def.f_luniverse in
506  let trans = trans freshr type_of redn unusd opt in
507  let expr_regs = ExprMap.empty in
508  let (expr_regs, g) = Trans.translate freshl trans expr_regs f_def.f_graph in
509  let d = add_decls expr_regs f_def.f_locals in
510
511  { f_def with f_locals = d ; f_graph = g }
512
513let transform_funct = function
514  | (f, F_int f_def) -> (f, F_int (transform_internal f_def))
515  | f -> f
516
517let trans = Languages.RTLabs, function
518  | Languages.AstRTLabs p ->
519    Languages.AstRTLabs { p with functs = List.map transform_funct p.functs }
520  | _ -> assert false (* wrong language *)
Note: See TracBrowser for help on using the repository browser.