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

Last change on this file since 1569 was 1569, checked in by tranquil, 8 years ago
  • added in repository some missing files...
File size: 17.8 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                Along the way we also perform a first rough liveness analysis. *)
6               
7
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
26let 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
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
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
75let 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 }
84         
85(* Expressions, expression sets, and operations thereof *)
86
87(* Load and store ops are not taken into account, maybe later *)
88type 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
93let 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))
97        | _ -> None
98
99let expr_of (g : graph) (n : Label.t) : expr option =
100        expr_of_stmt (Label.Map.find n g)
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, _) ->
113                Register.Set.add s (Register.Set.singleton t)
114  | St_load (_, Reg s, _, _)
115  | St_op1 (_, _, s, _)
116        | St_op2 (_, _, Reg s, _, _)
117        | St_op2 (_, _, _, Reg s, _) -> Register.Set.singleton s
118        | _ -> Register.Set.empty
119
120let vars_of (g : graph) (n : Label.t) : Register.Set.t =
121        vars_of_stmt (Label.Map.find n g)
122       
123(* used in possibly non side-effect-free statements *)
124let used_at_stmt = function
125        | St_call_id (_, rs, _, _, _)
126        | St_call_ptr (_, rs, _, _, _)
127        | St_tailcall_id (_, rs, _)
128        | St_tailcall_ptr (_, rs, _) ->
129            let f s r = Register.Set.add r s in
130            List.fold_left f Register.Set.empty rs
131  | St_store (_, Reg s, Reg t, _) ->
132                Register.Set.add s (Register.Set.singleton t)
133        | St_return (Some r)
134        | St_cond (r, _, _)
135        | St_store (_, Reg r, _, _)
136        | St_store (_, _, Reg r, _)  -> Register.Set.singleton r
137        | _ -> Register.Set.empty
138
139let used_at g n = used_at_stmt (Label.Map.find n g)
140
141module ExprOrdered = struct
142        type t = expr
143        let compare = compare
144end
145
146module ExprSet = Set.Make(ExprOrdered)
147module ExprMap = Map.Make(ExprOrdered)
148
149type expr_set = ExprSet.t
150
151let ( ^^ ) = ExprSet.inter
152
153let ( ++ ) = ExprSet.union
154
155let ( ++* ) s = function
156  | None -> s
157  | Some e -> ExprSet.add e s
158
159let ( --* ) s = function
160  | None -> s
161  | Some e -> ExprSet.remove e s
162
163let ( -- ) = ExprSet.diff
164
165let big_inter (f : Label.t -> ExprSet.t) (ls : Label.t list) : ExprSet.t =
166        (* generalized intersection, but in case of empty list it is empty *)
167        match ls with
168                | [] -> ExprSet.empty
169    (* these two cases are singled out for speed, as they will be common *)
170    | [l] -> f l
171    | [l1 ; l2] -> f l1 ^^ f l2
172    | l :: ls ->
173      let inter s l' = s ^^ f l' in
174      List.fold_left inter (f l) ls
175
176let big_union (f : Label.t -> Register.Set.t) (ls : Label.t list)
177    : Register.Set.t =
178    (* generalized union *)
179  let union s l' = Register.Set.union s (f l') in
180    List.fold_left union Register.Set.empty ls
181
182let filter_unchanged (r : Register.t option) (s : expr_set) : expr_set =
183        match r with
184                | None -> s
185                | Some r ->
186                        let filter = function
187                                | UnOp (_, s) when r = s -> false
188                                | BinOp (_, s, t) when s = Reg r || t = Reg r -> false
189                                | _ -> true in
190                        ExprSet.filter filter s
191                       
192module Lpair = struct
193       
194        (* A property is a pair of sets of expressions. *)
195        type property = expr_set * expr_set
196       
197        let bottom = (ExprSet.empty, ExprSet.empty)
198       
199  let equal (ant1, nea1) (ant2, nea2) =
200                ExprSet.equal ant1 ant2 && ExprSet.equal nea1 nea2
201
202  let is_maximal _ = false
203       
204end
205
206module Lsing = struct
207   
208  (* A property is a set of expressions. *)
209  type property = expr_set
210   
211  let bottom = ExprSet.empty
212   
213  let equal = ExprSet.equal
214
215  let is_maximal _ = false
216   
217end
218
219module Lexprid = struct
220   
221  (* A property is a set of expressions and a set of registers. *)
222  type property = expr_set * Register.Set.t
223   
224  let bottom = (ExprSet.empty, Register.Set.empty)
225   
226  let equal (a, b) (c, d) = ExprSet.equal a c && Register.Set.equal b d
227
228  let is_maximal _ = false
229   
230end
231
232module Fpair = Fix.Make (Label.ImpMap) (Lpair)
233
234module Fsing = Fix.Make (Label.ImpMap) (Lsing)
235
236module Fexprid = Fix.Make (Label.ImpMap) (Lexprid)
237
238(* printing tools to debug *)
239
240let print_expr = function
241(*    | Cst c ->
242      (RTLabsPrinter.print_cst c)*)
243    | UnOp (op, r) ->
244      (RTLabsPrinter.print_op1 op r)
245    | BinOp (op, r, s) ->
246      (RTLabsPrinter.print_op2 op r s)
247                       
248let print_prop_pair (p : Fpair.property) = let (ant, nea) = p in
249  let f e = Printf.printf "%s, " (print_expr e) in
250        Printf.printf "{ ";
251        ExprSet.iter f ant;
252  Printf.printf "}; { ";
253  ExprSet.iter f nea;
254  Printf.printf "}\n"
255
256let print_valu_pair (valu : Fpair.valuation) (g : graph) (entry : Label.t) =
257    let f lbl _ =
258        Printf.printf "%s: " lbl;
259        print_prop_pair (valu lbl) in
260     RTLabsUtilities.dfs_iter f g entry
261
262let print_prop_sing (p : Fsing.property) = 
263  let f e = Printf.printf "%s, " (print_expr e) in
264  Printf.printf "{ ";
265  ExprSet.iter f p;
266  Printf.printf "}\n"
267
268let print_valu_sing (valu : Fsing.valuation) (g : graph) (entry : Label.t) =
269    let f lbl _ =
270        Printf.printf "%s: " lbl;
271        print_prop_sing (valu lbl) in
272     RTLabsUtilities.dfs_iter f g entry
273   
274   
275(* ----- PHASE 1 : Anticipatability and erliestness ------ *)
276(* An expression e is anticipatable at point p if every path from p contains  *)
277(* a computation of e and evaluating e at p holds the same result as all such *)
278(* computations. *)
279(* An expression e is earliest at point p if there is no computation of e *)
280(* preceding p giving the same value. *)
281(* We will compute anticipatable expressions and *non*-earliest ones for every*)
282(* point with a single invocation to a fixpoint calculation. *) 
283
284
285let semantics_ant_nea
286    (g : graph)
287                (pred_table : Label.t list Label.Map.t)
288    (lbl : Label.t)
289    (valu : Fpair.valuation)
290    : Fpair.property =
291        let succs = RTLabsUtilities.statement_successors (Label.Map.find lbl g) in
292        let preds = Label.Map.find lbl pred_table in
293       
294  (* anticipatable expressions at entry *)
295        (* take anticipatable expressions of successors... *)
296        let ant l = fst (valu l) in
297        let nea l = snd (valu l) in
298        let ant_in = big_inter ant succs in
299        (* ... filter out those that contain the register being changed ...*)
300        let ant_in = filter_unchanged (modified_at g lbl) ant_in in
301        (* ... and add the expression being calculated ... *)
302        let ant_in = ant_in ++* expr_of g lbl in
303       
304        (* non-earliest expressions at entry *)
305        (* take non-earliest or anticipatable expressions of predecessors, *)
306        (* filtered so that just unchanged expressions leak *)
307        let ant_or_nea l =
308                filter_unchanged (modified_at g l) (ant l ++ nea l) in
309        let nea_in = big_inter ant_or_nea preds in
310                       
311        (ant_in, nea_in)
312       
313let compute_anticipatable_and_non_earliest
314    (f_def : internal_function)
315    (pred_table : Label.t list Label.Map.t)
316    : Fpair.valuation =
317   
318    Fpair.lfp (semantics_ant_nea f_def.f_graph 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    (pred_table : Label.t list Label.Map.t)
329    (ant_nea : Fpair.valuation)
330    (lbl : Label.t)
331    (valu : Fsing.valuation)
332    : Fsing.property =
333    let preds = Label.Map.find lbl pred_table in
334   
335    (* delayed expressions at entry *)
336    (* take delayed expressions of predecessors which are not the expressions *)
337                (* of such predecessors... *)
338                let rem_pred lbl' = valu lbl' --* expr_of g lbl' in
339    let delay_in = big_inter rem_pred preds in
340                (* ... and add in anticipatable and earliest expressions *)
341                let (ant, nea) = ant_nea lbl in
342    delay_in ++ (ant -- nea)
343   
344let compute_delayed
345    (f_def : internal_function)
346                (pred_table : Label.t list Label.Map.t)
347                (ant_nea : Fpair.valuation)
348    : Fsing.valuation =
349   
350    Fsing.lfp (semantics_delay f_def.f_graph pred_table ant_nea)
351
352(* An expression is latest at p if it cannot be delayed further *)
353let late (g : graph) (delay : Fsing.valuation)
354  : Fsing.valuation = fun lbl ->
355        let stmt = Label.Map.find lbl g in
356        let succs = RTLabsUtilities.statement_successors stmt in
357       
358        let eo = match expr_of g lbl with
359                | Some e when ExprSet.mem e (delay lbl) -> Some e
360                | _ -> None in
361
362  (delay lbl -- big_inter delay succs) ++* eo   
363       
364
365(* --------------- PHASE 3 : isolatedness, optimality and redudancy --------*)
366
367(* An expression e is isolated at point p if on every path from p a use of *)
368(* e is preceded by an optimal computation point for it. These are expressions*)
369(* which will not be touched *)
370(* A variable is used at entry if every use of it later in the execution path *)
371(* is to compute variables which are in turn used. *)
372let semantics_isolated_used
373    (g : graph)
374                (late : Fsing.valuation)
375    (lbl : Label.t)
376    (valu : Fexprid.valuation)
377                : Fexprid.property =
378       
379        let stmt = Label.Map.find lbl g in
380        let succs = RTLabsUtilities.statement_successors stmt in
381        let f l = late l ++ (fst (valu l) --* expr_of g l) in
382        let isol = big_inter f succs in
383       
384        let f l =
385                let used_out = snd (valu l) in
386                let used_out = match modified_at g l with
387                | Some r when Register.Set.mem r used_out ->
388                        Register.Set.union (Register.Set.remove r used_out) (vars_of g l)
389                | _ -> used_out in
390                Register.Set.union used_out (used_at g l) in 
391        let used = big_union f succs in
392       
393        (isol, used)
394       
395let compute_isolated_used
396    (f_def : internal_function)
397    (delayed : Fsing.valuation)
398    : Fexprid.valuation =
399
400    let graph = f_def.f_graph in
401               
402    Fexprid.lfp (semantics_isolated_used graph (late graph delayed))
403
404(* expressions that are optimally placed at point p, without being isolated *)
405let optimal (late : Fsing.valuation) (isol : Fsing.valuation)
406    : Fsing.valuation = fun lbl ->
407        late lbl -- isol lbl
408
409(* mark instructions that are redundant and can be removed *)
410let redundant g late isol lbl =
411        match expr_of g lbl with
412                | Some e when ExprSet.mem e (isol lbl) ->
413                        false
414                | Some _ -> true
415                | _ -> false
416
417(* mark instructions that modify an unused register *)
418let unused g used lbl =
419    match modified_at g lbl with
420        | Some r when Register.Set.mem r (used lbl) ->
421            false
422        | Some r -> true
423                                | _ -> false
424
425(*------ PHASE 4 : place expressions, remove reduntant ones -------------*)
426
427let remove_redundant def is_redundant is_unused =
428        let g = def.f_graph in
429        let types = RTLabsUtilities.computes_type_map def in
430        let f lbl stmt (g', s) =
431                if is_unused lbl then
432      let succ = List.hd (RTLabsUtilities.statement_successors stmt) in
433                        (Label.Map.add lbl (St_skip succ) g', s) else
434                if is_redundant lbl then
435                        match modified_at_stmt stmt, expr_of_stmt stmt with
436                                | Some r, Some e ->
437                                        let succ = List.hd (RTLabsUtilities.statement_successors stmt) in
438                            let (s, (tmp, _)) =
439                                                try
440                                                        (s, ExprMap.find e s)
441                                                with
442                                                        | Not_found ->
443                                                                let tmp =       Register.fresh def.f_runiverse in
444                                                                let typ = Register.Map.find r types in
445                                                                let s = ExprMap.add e (tmp, typ) s in
446                                                                (s, (tmp, typ)) in
447                                        let new_stmt = St_op1 (Op_id, r, tmp, succ) in
448          (Label.Map.add lbl new_stmt g', s)
449        | _ -> assert false
450                else (g', s) in
451        let (g, s) = Label.Map.fold f g (g, ExprMap.empty) in
452        ({ def with f_graph = g }, s)
453
454let stmt_of_expr
455    (r : Register.t)
456                (e : expr)
457                (l : Label.t)
458                : statement =
459        match e with
460(*              | Cst c -> St_cst (r, c, l)*)
461                | UnOp (op, s) -> St_op1 (op, r, s, l)
462                | BinOp (op, s, t) -> St_op2 (op, r, s, t, l)
463
464let insert_after exprs redundants g freshl lbl next =
465  let f e (next', g') =
466    try 
467      let (tmp, _) = ExprMap.find e redundants in
468      let opt_calc = stmt_of_expr tmp e next' in
469      RTLabsUtilities.insert_in_between freshl g' lbl next' opt_calc
470                with
471                        | Not_found -> (next', g') in
472  snd (ExprSet.fold f exprs (next, g))
473       
474let insert_before exprs redundants g freshl lbl stmt =
475        let f e (stmt', g') =
476    try 
477      let (tmp, _) = ExprMap.find e redundants in
478                        let n_lbl = freshl () in
479      let opt_calc = stmt_of_expr tmp e n_lbl in
480                        let g' = Label.Map.add n_lbl stmt' g' in
481                        let g' = Label.Map.add lbl opt_calc g' in
482                        (opt_calc, g')
483     with
484                        | Not_found -> (stmt', g') in
485  snd (ExprSet.fold f exprs (stmt, g))
486               
487let store_optimal_computation (def, redundants) optimal =
488        (* first add the temporaries' declarations *)
489        let f _ (r, typ) vars = (r, typ) :: vars in
490        let f_locals = ExprMap.fold f redundants def.f_locals in
491       
492        (* now the actual replacement *)
493        let g = def.f_graph in
494  let freshl () = Label.Gen.fresh def.f_luniverse in
495        let f lbl stmt g' =
496                match stmt with
497                        (* in case of cost emittance the optimal calculations are inserted *)
498                        (* after, to preserve preciness *)
499(*                      | St_cost (_, next) ->
500                                insert_after (optimal lbl) redundants g' freshl lbl next *)
501                        | _ ->
502                                insert_before (optimal lbl) redundants g' freshl lbl stmt in
503        { def with f_locals = f_locals; f_graph = Label.Map.fold f g g }
504
505               
506(* piecing it all together *)           
507let transform_internal f_def = 
508  let pred_table = RTLabsUtilities.compute_predecessor_lists f_def.f_graph in
509  let ant_nea = compute_anticipatable_and_non_earliest f_def pred_table in
510  (*Printf.printf "Ant + Nearl:\n";
511  print_valu_pair ant_nea f_def.f_graph f_def.f_entry;*)
512  let delay = compute_delayed f_def pred_table ant_nea in
513  (*Printf.printf "Delayed:\n";
514  print_valu_sing delay f_def.f_graph f_def.f_entry;*)
515  let late = late f_def.f_graph delay in
516  (*Printf.printf "Late:\n";
517  print_valu_sing late f_def.f_graph f_def.f_entry;*)
518  let isol_used = compute_isolated_used f_def delay in
519        let isol = fun lbl -> fst (isol_used lbl) in
520  let used = fun lbl -> snd (isol_used lbl) in
521  (*Printf.printf "isolated:\n";
522  print_valu_sing isol f_def.f_graph f_def.f_entry;*)
523        let opt = optimal late isol in
524        let redn = redundant f_def.f_graph late isol in
525        let unusd = unused f_def.f_graph used in
526  (*Printf.printf "optimal:\n";
527  print_valu_sing opt f_def.f_graph f_def.f_entry;
528  Printf.printf "redundant:\n";
529    let f lbl _ =
530      Printf.printf "%s : %s\n" lbl (if redn lbl then "yes" else "no") in
531    RTLabsUtilities.dfs_iter f f_def.f_graph f_def.f_entry;*)
532        let f lbl _ s = Register.Set.union (used lbl) s in
533        let regs_used =
534                RTLabsUtilities.dfs_fold f f_def.f_graph f_def.f_entry Register.Set.empty in
535        let filter (r, _) = Register.Set.mem r regs_used in
536        let f_def = { f_def with f_locals = List.filter filter f_def.f_locals } in 
537        store_optimal_computation (remove_redundant f_def redn unusd) opt
538       
539       
540let transform_funct = function
541        | (f, F_int f_def) -> (f, F_int (transform_internal f_def))
542        | f -> f
543
544let trans = Languages.RTLabs, function
545        | Languages.AstRTLabs p ->
546                Languages.AstRTLabs { p with functs = List.map transform_funct p.functs }
547        | _ -> assert false (* wrong language *)
Note: See TracBrowser for help on using the repository browser.