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

Last change on this file since 1572 was 1572, checked in by tranquil, 9 years ago
  • corrected previous bug
  • finished propagating immediates
File size: 17.8 KB
RevLine 
[1569]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.
[1572]5    Along the way we also perform a first rough liveness analysis. *)
[1569]6
[1572]7
[1569]8open RTLabs
9open AST
10
11(* Notes: To move loop-invariant computation, peeling is needed. It would *)
12(* also profit from algebraic transformations that piece together *)
13(* loop-constants: if x and y are loop-invariants, then x*y*i won't be *)
14(* optimized unless it is transformed to (x*y)*i. Pretty important for *)
15(* array addresses. *)
16
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
[1572]26let count_predecessors
[1569]27    (g : graph)
28    : int Label.Map.t =
29  let f lbl s m =
30    let succs = RTLabsUtilities.statement_successors s in
[1572]31    let f' m succ =
[1569]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
[1572]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
[1569]38  Label.Map.fold f g Label.Map.empty
39
40module LabelPairSet = Set.Make(struct
41  type t = Label.t * Label.t
42  let compare = compare
43end)
44
45let 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
[1572]49      LabelPairSet.add (l1, l2) s in
[1569]50  let f l stmt s = match stmt with
51    | St_cond(_, l1, l2) ->
[1572]52      add_if_2_preds l (add_if_2_preds l s l1) l2
[1569]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
[1572]57
[1569]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
75let critical_edge_elimination
76    (f_def : internal_function)
77    : internal_function =
[1572]78  let g = f_def.f_graph in
79  let fresh () = Label.Gen.fresh f_def.f_luniverse in
[1569]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 }
[1572]84
[1569]85(* Expressions, expression sets, and operations thereof *)
86
87(* Load and store ops are not taken into account, maybe later *)
88type expr =
[1572]89  (*        | Cst of cst (* do we need to consider constants? maybe only big ones? *)*)
[1569]90  | UnOp of op1 * Register.t
91  | BinOp of op2 * argument * argument
92
93let expr_of_stmt (s : statement) : expr option = match s with
[1572]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))
97  | _ -> None
[1569]98
99let expr_of (g : graph) (n : Label.t) : expr option =
[1572]100  expr_of_stmt (Label.Map.find n g)
[1569]101
102(* the register modified by a node *)
103let modified_at_stmt = RTLabsUtilities.modified_at_stmt
104
105let modified_at = RTLabsUtilities.modified_at
106
107(* registers on which the value computed at the statement depends, which are*)
108(* needed if the modified register is needed. Below used_at lists those*)
109(* registers that may be needed regardless (i.e. in non-side-effect-free *)
110(* statements).*)
111let vars_of_stmt = function
112  | St_op2 (_, _, Reg s, Reg t, _) ->
[1572]113    Register.Set.add s (Register.Set.singleton t)
[1569]114  | St_load (_, Reg s, _, _)
115  | St_op1 (_, _, s, _)
[1572]116  | St_op2 (_, _, Reg s, _, _)
117  | St_op2 (_, _, _, Reg s, _) -> Register.Set.singleton s
118  | _ -> Register.Set.empty
[1569]119
120let vars_of (g : graph) (n : Label.t) : Register.Set.t =
[1572]121  vars_of_stmt (Label.Map.find n g)
122
[1569]123(* used in possibly non side-effect-free statements *)
[1572]124let used_at_stmt stmt =
125  let add_arg s = function
126    | Reg r -> Register.Set.add r s
127    | Imm _ -> s in
128  match stmt with
129    | St_call_id (_, rs, _, _, _)
130    | St_call_ptr (_, rs, _, _, _)
131    | St_tailcall_id (_, rs, _)
132    | St_tailcall_ptr (_, rs, _) ->
133      List.fold_left add_arg Register.Set.empty rs
134    | St_store (_, a, b, _) ->
135      add_arg (add_arg Register.Set.empty a) b
136    | St_return (Some (Reg r))
137    | St_cond (r, _, _) -> Register.Set.singleton r
138    | _ -> Register.Set.empty
[1569]139
140let used_at g n = used_at_stmt (Label.Map.find n g)
141
142module ExprOrdered = struct
[1572]143  type t = expr
144  let compare = compare
[1569]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 =
[1572]167        (* generalized intersection, but in case of empty list it is empty *)
168  match ls with
169    | [] -> ExprSet.empty
[1569]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 =
[1572]179  (* generalized union *)
[1569]180  let union s l' = Register.Set.union s (f l') in
[1572]181  List.fold_left union Register.Set.empty ls
[1569]182
183let filter_unchanged (r : Register.t option) (s : expr_set) : expr_set =
[1572]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
[1569]193module Lpair = struct
[1572]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
[1569]200  let equal (ant1, nea1) (ant2, nea2) =
[1572]201    ExprSet.equal ant1 ant2 && ExprSet.equal nea1 nea2
[1569]202
203  let is_maximal _ = false
[1572]204
[1569]205end
206
207module Lsing = struct
[1572]208
[1569]209  (* A property is a set of expressions. *)
210  type property = expr_set
[1572]211
[1569]212  let bottom = ExprSet.empty
[1572]213
[1569]214  let equal = ExprSet.equal
215
216  let is_maximal _ = false
[1572]217
[1569]218end
219
220module Lexprid = struct
[1572]221
[1569]222  (* A property is a set of expressions and a set of registers. *)
223  type property = expr_set * Register.Set.t
[1572]224
[1569]225  let bottom = (ExprSet.empty, Register.Set.empty)
[1572]226
[1569]227  let equal (a, b) (c, d) = ExprSet.equal a c && Register.Set.equal b d
228
229  let is_maximal _ = false
[1572]230
[1569]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
[1572]242    (*    | Cst c ->
243          (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
[1569]249let print_prop_pair (p : Fpair.property) = let (ant, nea) = p in
[1572]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"
[1569]256
257let print_valu_pair (valu : Fpair.valuation) (g : graph) (entry : Label.t) =
[1572]258  let f lbl _ =
259    Printf.printf "%s: " lbl;
260    print_prop_pair (valu lbl) in
261  RTLabsUtilities.dfs_iter f g entry
[1569]262
[1572]263let print_prop_sing (p : Fsing.property) =
[1569]264  let f e = Printf.printf "%s, " (print_expr e) in
265  Printf.printf "{ ";
266  ExprSet.iter f p;
267  Printf.printf "}\n"
268
269let print_valu_sing (valu : Fsing.valuation) (g : graph) (entry : Label.t) =
[1572]270  let f lbl _ =
271    Printf.printf "%s: " lbl;
272    print_prop_sing (valu lbl) in
273  RTLabsUtilities.dfs_iter f g entry
274
275
[1569]276(* ----- PHASE 1 : Anticipatability and erliestness ------ *)
277(* An expression e is anticipatable at point p if every path from p contains  *)
278(* a computation of e and evaluating e at p holds the same result as all such *)
279(* computations. *)
280(* An expression e is earliest at point p if there is no computation of e *)
281(* preceding p giving the same value. *)
282(* We will compute anticipatable expressions and *non*-earliest ones for every*)
[1572]283(* point with a single invocation to a fixpoint calculation. *)
[1569]284
285
286let semantics_ant_nea
287    (g : graph)
[1572]288    (pred_table : Label.t list Label.Map.t)
[1569]289    (lbl : Label.t)
290    (valu : Fpair.valuation)
291    : Fpair.property =
[1572]292  let succs = RTLabsUtilities.statement_successors (Label.Map.find lbl g) in
293  let preds = Label.Map.find lbl pred_table in
294
295        (* anticipatable expressions at entry *)
296        (* take anticipatable expressions of successors... *)
297  let ant l = fst (valu l) in
298  let nea l = snd (valu l) in
299  let ant_in = big_inter ant succs in
300        (* ... filter out those that contain the register being changed ...*)
301  let ant_in = filter_unchanged (modified_at g lbl) ant_in in
302        (* ... and add the expression being calculated ... *)
303  let ant_in = ant_in ++* expr_of g lbl in
304
305        (* non-earliest expressions at entry *)
306        (* take non-earliest or anticipatable expressions of predecessors, *)
307        (* filtered so that just unchanged expressions leak *)
308  let ant_or_nea l =
309    filter_unchanged (modified_at g l) (ant l ++ nea l) in
310  let nea_in = big_inter ant_or_nea preds in
311
312  (ant_in, nea_in)
313
[1569]314let compute_anticipatable_and_non_earliest
315    (f_def : internal_function)
316    (pred_table : Label.t list Label.Map.t)
317    : Fpair.valuation =
[1572]318
319  Fpair.lfp (semantics_ant_nea f_def.f_graph pred_table)
320
[1569]321(* ------------ PHASE 2 : delayedness and lateness ----------- *)
322(* An expression e is delayable at position p there is a point p' preceding it*)
323(* in the control flow where e could be safely placed, and between p'and p *)
324(* excluded e is never used. *)
325
326
327let semantics_delay
328    (g : graph)
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 =
[1572]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 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
[1569]345let compute_delayed
346    (f_def : internal_function)
[1572]347    (pred_table : Label.t list Label.Map.t)
348    (ant_nea : Fpair.valuation)
[1569]349    : Fsing.valuation =
350
[1572]351  Fsing.lfp (semantics_delay f_def.f_graph pred_table ant_nea)
352
[1569]353(* An expression is latest at p if it cannot be delayed further *)
354let late (g : graph) (delay : Fsing.valuation)
[1572]355    : Fsing.valuation = fun lbl ->
356      let stmt = Label.Map.find lbl g in
357      let succs = RTLabsUtilities.statement_successors stmt in
[1569]358
[1572]359      let eo = match expr_of g lbl with
360        | Some e when ExprSet.mem e (delay lbl) -> Some e
361        | _ -> None in
[1569]362
[1572]363      (delay lbl -- big_inter delay succs) ++* eo
364
365
[1569]366(* --------------- PHASE 3 : isolatedness, optimality and redudancy --------*)
367
368(* An expression e is isolated at point p if on every path from p a use of *)
369(* e is preceded by an optimal computation point for it. These are expressions*)
370(* which will not be touched *)
371(* A variable is used at entry if every use of it later in the execution path *)
372(* is to compute variables which are in turn used. *)
373let semantics_isolated_used
374    (g : graph)
[1572]375    (late : Fsing.valuation)
[1569]376    (lbl : Label.t)
377    (valu : Fexprid.valuation)
[1572]378    : Fexprid.property =
379
380  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
383  let isol = big_inter f succs in
384
385  let f l =
386    let used_out = snd (valu l) in
387    let used_out = match modified_at g l with
388      | Some r when Register.Set.mem r used_out ->
389        Register.Set.union (Register.Set.remove r used_out) (vars_of g l)
390      | _ -> used_out in
391    Register.Set.union used_out (used_at g l) in
392  let used = big_union f succs in
393
394  (isol, used)
395
[1569]396let compute_isolated_used
397    (f_def : internal_function)
398    (delayed : Fsing.valuation)
399    : Fexprid.valuation =
400
[1572]401  let graph = f_def.f_graph in
[1569]402
[1572]403  Fexprid.lfp (semantics_isolated_used graph (late graph delayed))
404
[1569]405(* expressions that are optimally placed at point p, without being isolated *)
406let optimal (late : Fsing.valuation) (isol : Fsing.valuation)
407    : Fsing.valuation = fun lbl ->
[1572]408      late lbl -- isol lbl
[1569]409
410(* mark instructions that are redundant and can be removed *)
411let redundant g late isol lbl =
[1572]412  match expr_of g lbl with
413    | Some e when ExprSet.mem e (isol lbl) ->
414      false
415    | Some _ -> true
416    | _ -> false
[1569]417
418(* mark instructions that modify an unused register *)
419let unused g used lbl =
[1572]420  match modified_at g lbl with
421    | Some r when Register.Set.mem r (used lbl) ->
422      false
423    | Some r -> true
424    | _ -> false
[1569]425
426(*------ PHASE 4 : place expressions, remove reduntant ones -------------*)
427
428let remove_redundant def is_redundant is_unused =
[1572]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
[1569]433      let succ = List.hd (RTLabsUtilities.statement_successors stmt) in
[1572]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)
[1569]454
455let stmt_of_expr
456    (r : Register.t)
[1572]457    (e : expr)
458    (l : Label.t)
459    : statement =
460  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)
[1569]464
465let insert_after exprs redundants g freshl lbl next =
466  let f e (next', g') =
[1572]467    try
[1569]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
[1572]471    with
472      | Not_found -> (next', g') in
[1569]473  snd (ExprSet.fold f exprs (next, g))
[1572]474
[1569]475let insert_before exprs redundants g freshl lbl stmt =
[1572]476  let f e (stmt', g') =
477    try
[1569]478      let (tmp, _) = ExprMap.find e redundants in
[1572]479      let n_lbl = freshl () in
[1569]480      let opt_calc = stmt_of_expr tmp e n_lbl in
[1572]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
[1569]486  snd (ExprSet.fold f exprs (stmt, g))
[1572]487
[1569]488let store_optimal_computation (def, redundants) optimal =
[1572]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
[1569]495  let freshl () = Label.Gen.fresh def.f_luniverse in
[1572]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 }
[1569]505
[1572]506
507(* piecing it all together *)
508let transform_internal f_def =
[1569]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
[1572]514  let isol = fun lbl -> fst (isol_used lbl) in
[1569]515  let used = fun lbl -> snd (isol_used lbl) in
[1572]516  let opt = optimal late isol in
517  let redn = redundant f_def.f_graph late isol in
518  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
526
[1569]527let transform_funct = function
[1572]528  | (f, F_int f_def) -> (f, F_int (transform_internal f_def))
529  | f -> f
[1569]530
531let trans = Languages.RTLabs, function
[1572]532  | Languages.AstRTLabs p ->
533    Languages.AstRTLabs { p with functs = List.map transform_funct p.functs }
534  | _ -> assert false (* wrong language *)
Note: See TracBrowser for help on using the repository browser.