source: Deliverables/D2.2/8051-indexed-labels-branch/src/RTLabs/redundancyElimination.ml @ 1473

Last change on this file since 1473 was 1473, checked in by tranquil, 9 years ago
  • implemented partial redundancy elimination
  • added some tools for RTLabs, with a depth-first fold
  • prettier printing of RTLabs
File size: 14.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
6open RTLabs
7open AST
8
9let error_prefix = "RTLabs to RTL"
10let error = Error.global_error error_prefix
11
12let error_int () = error "int16 and int32 not supported."
13let error_float () = error "float not supported."
14let error_shift () = error "Shift operations not supported."
15
16(* ----- PHASE 0 : critical edge elimination ------ *)
17
18(* a critical edge is one between a node with several successors and a node*)
19(* with several predecessors. In order for the optimization to work best   *)
20(* these must be avoided, inserting an empty node in-between. *)
21(* Note: maybe in our case we can avoid this, as branchings will have *)
22(* emit cost nodes afterwards. To be checked. *)
23
24let count_predecessors
25    (g : graph)
26    : int Label.Map.t =
27  let f lbl s m =
28    let succs = RTLabsUtilities.statement_successors s in
29      let f' m succ =
30      try
31        Label.Map.add succ (1 + Label.Map.find succ m) m
32      with
33        | Not_found -> Label.Map.add succ 1 m in
34      let m = List.fold_left f' m succs in
35      if Label.Map.mem lbl m then m else Label.Map.add lbl 0 m in
36  Label.Map.fold f g Label.Map.empty
37
38module LabelPairSet = Set.Make(struct
39  type t = Label.t * Label.t
40  let compare = compare
41end)
42
43let find_critical_edges (g : graph) : LabelPairSet.t =
44  let pred_count = count_predecessors g in
45  let add_if_2_preds l1 s l2 =
46    if Label.Map.find l2 pred_count < 2 then s else
47    LabelPairSet.add (l1, l2) s in
48  let f l stmt s = match stmt with
49    | St_cond(_, l1, l2) ->
50      add_if_2_preds l (add_if_2_preds l s l1) l2
51    | St_jumptable (_, ls) when List.length ls > 1 ->
52      List.fold_left (add_if_2_preds l) s ls
53    | _ -> s in
54  Label.Map.fold f g LabelPairSet.empty
55     
56(* note to self: there is a degenrate case that is not eliminated by the *)
57(* following, namely (top to bottom) *)
58(*               src                *)
59(*               / \                *)
60(*              |   |               *)
61(*               \ /                *)
62(*               tgt                *)
63(* In this case the result will be  *)
64(*               src                *)
65(*               / \                *)
66(*               \ /                *)
67(*               new                *)
68(*                |                 *)
69(*               tgt                *)
70(* with two critical edges still in place. To be checked whether it *)
71(* compromises the optimization, I think not *)
72
73let 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  let critical_edges = find_critical_edges g in
79  let rem (src, tgt) g =
80    snd (RTLabsUtilities.insert_in_between fresh g src tgt (St_skip tgt)) in
81  { f_def with f_graph = LabelPairSet.fold rem critical_edges g }
82         
83(* Expressions, expression sets, and operations thereof *)
84
85(* Load and store ops are not taken into account, maybe later *)
86type expr =
87(*      | Cst of cst (* do we need to consider constants? maybe only big ones? *)*)
88  | UnOp of op1 * Register.t
89  | BinOp of op2 * Register.t * Register.t
90
91let expr_of_stmt (s : statement) : expr option = match s with
92(*      | St_cst (_, c, _) -> Some (Cst c)*)
93        | St_op1 (op, _, s, _) -> Some (UnOp (op, s))
94        | St_op2 (op, _, s, t, _) -> Some (BinOp (op, s, t))
95        | _ -> None
96
97let expr_of (g : graph) (n : Label.t) : expr option =
98        expr_of_stmt (Label.Map.find n g)
99
100(* the register modified by a node *)
101let modified_at_stmt stmt =
102  match stmt with
103                | St_op1 (_, r, _, _)
104                | St_op2 (_, r, _, _, _)
105                | St_cst (r, _, _)
106                | St_load (_, r, _, _)
107                | St_call_id (_, _, Some r, _, _)
108                | St_call_ptr (_, _, Some r, _, _) -> Some r
109                | _ -> None
110
111let modified_at (g : graph) (n : Label.t) : Register.t option =
112        modified_at_stmt (Label.Map.find n g)
113
114module ExprOrdered = struct
115        type t = expr
116        let compare = compare
117end
118
119module ExprSet = Set.Make(ExprOrdered)
120module ExprMap = Map.Make(ExprOrdered)
121
122type expr_set = ExprSet.t
123
124let ( ^^ ) = ExprSet.inter
125
126let ( ++ ) = ExprSet.union
127
128let ( ++* ) s = function
129  | None -> s
130  | Some e -> ExprSet.add e s
131
132let ( --* ) s = function
133  | None -> s
134  | Some e -> ExprSet.remove e s
135
136let ( -- ) = ExprSet.diff
137
138let big_inter (f : Label.t -> ExprSet.t) (ls : Label.t list) : ExprSet.t =
139        (* generalized intersection, but in case of empty list it is empty *)
140        match ls with
141                | [] -> ExprSet.empty
142    (* these two cases are singled out for speed, as they will be common *)
143    | [l] -> f l
144    | [l1 ; l2] -> f l1 ^^ f l2
145    | l :: ls ->
146      let inter s l' = s ^^ f l' in
147      List.fold_left inter (f l) ls
148
149let filter_unchanged (r : Register.t option) (s : expr_set) : expr_set =
150        match r with
151                | None -> s
152                | Some r ->
153                        let filter = function
154                                | UnOp (_, s) when r = s -> false
155                                | BinOp (_, s, t) when r = s || r = t -> false
156                                | _ -> true in
157                        ExprSet.filter filter s
158                       
159module Lpair = struct
160       
161        (* A property is a pair of sets of expressions. *)
162        type property = expr_set * expr_set
163       
164        let bottom = (ExprSet.empty, ExprSet.empty)
165       
166  let equal (ant1, nea1) (ant2, nea2) =
167                ExprSet.equal ant1 ant2 && ExprSet.equal nea1 nea2
168
169  let is_maximal _ = false
170       
171end
172
173module Lsing = struct
174   
175  (* A property is a set of expressions. *)
176  type property = expr_set
177   
178  let bottom = ExprSet.empty
179   
180  let equal = ExprSet.equal
181
182  let is_maximal _ = false
183   
184end
185
186module Fpair = Fix.Make (Label.ImpMap) (Lpair)
187
188module Fsing = Fix.Make (Label.ImpMap) (Lsing)
189
190(* printing tools to debug *)
191
192let print_expr = function
193(*    | Cst c ->
194      (RTLabsPrinter.print_cst c)*)
195    | UnOp (op, r) ->
196      (RTLabsPrinter.print_op1 op r)
197    | BinOp (op, r, s) ->
198      (RTLabsPrinter.print_op2 op r s)
199                       
200let print_prop_pair (p : Fpair.property) = let (ant, nea) = p in
201  let f e = Printf.printf "%s, " (print_expr e) in
202        Printf.printf "{ ";
203        ExprSet.iter f ant;
204  Printf.printf "}; { ";
205  ExprSet.iter f nea;
206  Printf.printf "}\n"
207
208let print_valu_pair (valu : Fpair.valuation) (g : graph) (entry : Label.t) =
209    let f lbl _ =
210        Printf.printf "%s: " lbl;
211        print_prop_pair (valu lbl) in
212     RTLabsUtilities.dfs_iter f g entry
213
214let print_prop_sing (p : Fsing.property) = 
215  let f e = Printf.printf "%s, " (print_expr e) in
216  Printf.printf "{ ";
217  ExprSet.iter f p;
218  Printf.printf "}\n"
219
220let print_valu_sing (valu : Fsing.valuation) (g : graph) (entry : Label.t) =
221    let f lbl _ =
222        Printf.printf "%s: " lbl;
223        print_prop_sing (valu lbl) in
224     RTLabsUtilities.dfs_iter f g entry
225   
226   
227(* ----- PHASE 1 : Anticipatability and erliestness ------ *)
228(* An expression e is anticipatable at point p if every path from p contains  *)
229(* a computation of e and evaluating e at p holds the same result as all such *)
230(* computations. *)
231(* An expression e is earliest at point p if there is no computation of e *)
232(* preceding p giving the same value. *)
233(* We will compute anticipatable expressions and *non*-earliest ones for every*)
234(* point with a single invocation to a fixpoint calculation. *) 
235
236
237let semantics_ant_nea
238    (g : graph)
239                (pred_table : Label.t list Label.Map.t)
240    (lbl : Label.t)
241    (valu : Fpair.valuation)
242    : Fpair.property =
243        let succs = RTLabsUtilities.statement_successors (Label.Map.find lbl g) in
244        let preds = Label.Map.find lbl pred_table in
245       
246  (* anticipatable expressions at entry *)
247        (* take anticipatable expressions of successors... *)
248        let ant l = fst (valu l) in
249        let nea l = snd (valu l) in
250        let ant_in = big_inter ant succs in
251        (* ... filter out those that contain the register being changed ...*)
252        let ant_in = filter_unchanged (modified_at g lbl) ant_in in
253        (* ... and add the expression being calculated ... *)
254        let ant_in = ant_in ++* expr_of g lbl in
255       
256        (* non-earliest expressions at entry *)
257        (* take non-earliest or anticipatable expressions of predecessors, *)
258        (* filtered so that just unchanged expressions leak *)
259        let ant_or_nea l =
260                filter_unchanged (modified_at g l) (ant l ++ nea l) in
261        let nea_in = big_inter ant_or_nea preds in
262                       
263        (ant_in, nea_in)
264       
265let compute_anticipatable_and_non_earliest
266    (f_def : internal_function)
267    (pred_table : Label.t list Label.Map.t)
268    : Fpair.valuation =
269   
270    Fpair.lfp (semantics_ant_nea f_def.f_graph pred_table)
271   
272(* ------------ PHASE 2 : delayedness and lateness ----------- *)
273(* An expression e is delayable at position p there is a point p' preceding it*)
274(* in the control flow where e could be safely placed, and between p'and p *)
275(* excluded e is never used. *)
276
277
278let semantics_delay
279    (g : graph)
280    (pred_table : Label.t list Label.Map.t)
281    (ant_nea : Fpair.valuation)
282    (lbl : Label.t)
283    (valu : Fsing.valuation)
284    : Fsing.property =
285    let preds = Label.Map.find lbl pred_table in
286   
287    (* delayed expressions at entry *)
288    (* take delayed expressions of predecessors which are not the expressions *)
289                (* of such predecessors... *)
290                let rem_pred lbl' = valu lbl' --* expr_of g lbl' in
291    let delay_in = big_inter rem_pred preds in
292                (* ... and add in anticipatable and earliest expressions *)
293                let (ant, nea) = ant_nea lbl in
294    delay_in ++ (ant -- nea)
295   
296let compute_delayed
297    (f_def : internal_function)
298                (pred_table : Label.t list Label.Map.t)
299                (ant_nea : Fpair.valuation)
300    : Fsing.valuation =
301   
302    Fsing.lfp (semantics_delay f_def.f_graph pred_table ant_nea)
303
304(* An expression is latest at p if it cannot be delayed further *)
305let late (g : graph) (delay : Fsing.valuation)
306  : Fsing.valuation = fun lbl ->
307        let stmt = Label.Map.find lbl g in
308        let succs = RTLabsUtilities.statement_successors stmt in
309       
310        let eo = match expr_of g lbl with
311                | Some e when ExprSet.mem e (delay lbl) -> Some e
312                | _ -> None in
313
314  (delay lbl -- big_inter delay succs) ++* eo   
315       
316
317(* --------------- PHASE 3 : isolatedness, optimality and redudancy --------*)
318
319(* An expression e is isolated at point p if on every path from p a use of *)
320(* e is preceded by an optimal computation point for it. These are expressions*)
321(* which will not be touched *)
322let semantics_isolated
323    (g : graph)
324                (late : Fsing.valuation)
325    (lbl : Label.t)
326    (valu : Fsing.valuation)
327                : Fsing.property =
328       
329        let stmt = Label.Map.find lbl g in
330        let succs = RTLabsUtilities.statement_successors stmt in
331        let f l = late l ++ (valu l --* expr_of g l) in
332        big_inter f succs
333       
334let compute_isolated
335    (f_def : internal_function)
336    (delayed : Fsing.valuation)
337    : Fsing.valuation =
338
339    let graph = f_def.f_graph in
340               
341    Fsing.lfp (semantics_isolated graph (late graph delayed))
342
343(* expressions that are optimally placed at point p, without being isolated *)
344let optimal (late : Fsing.valuation) (isol : Fsing.valuation)
345    : Fsing.valuation = fun lbl ->
346        late lbl -- isol lbl
347
348(* mark instructions that are redundant and can be removed *)
349let redundant g late isol lbl =
350        match expr_of g lbl with
351                | Some e when ExprSet.mem e (late lbl) || ExprSet.mem e (isol lbl) ->
352                        false
353                | Some _ -> true
354                | _ -> false
355
356(*------ PHASE 4 : place expressions, remove reduntant ones -------------*)
357
358let remove_redundant def is_redundant =
359        let g = def.f_graph in
360        let types = RTLabsUtilities.computes_type_map def in
361        let f lbl stmt (g', s) =
362                if is_redundant lbl then
363                        match modified_at_stmt stmt, expr_of_stmt stmt with
364                                | Some r, Some e ->
365                                        let succs = RTLabsUtilities.statement_successors stmt in
366                            let (s, (tmp, _)) =
367                                                try
368                                                        (s, ExprMap.find e s)
369                                                with
370                                                        | Not_found ->
371                                                                let tmp =       Register.fresh def.f_runiverse in
372                                                                let typ = Register.Map.find r types in
373                                                                let s = ExprMap.add e (tmp, typ) s in
374                                                                (s, (tmp, typ)) in
375                                        let new_stmt = St_op1 (Op_id, r, tmp, lbl) in
376                            let new_stmt = RTLabsUtilities.fill_labels new_stmt succs in
377          (Label.Map.add lbl new_stmt g', s)
378        | _ -> assert false
379                else (g', s) in
380        let (g, s) = Label.Map.fold f g (g, ExprMap.empty) in
381        ({ def with f_graph = g }, s)
382
383let stmt_of_expr
384    (r : Register.t)
385                (e : expr)
386                (l : Label.t)
387                : statement =
388        match e with
389(*              | Cst c -> St_cst (r, c, l)*)
390                | UnOp (op, s) -> St_op1 (op, r, s, l)
391                | BinOp (op, s, t) -> St_op2 (op, r, s, t, l)
392
393let store_optimal_computation (def, redundants) optimal =
394        (* first add the temporaries' declarations *)
395        let f _ (r, typ) vars = (r, typ) :: vars in
396        let f_locals = ExprMap.fold f redundants def.f_locals in
397       
398        (* now the actual replacement *)
399        let g = def.f_graph in
400  let freshl () = Label.Gen.fresh def.f_luniverse in
401        let f lbl stmt g' =
402    match RTLabsUtilities.statement_successors stmt with
403                        | next :: rest ->
404                                (* I am supposing optimal expressions are only at single-successor *)
405                                (* nodes. To be checked. Also to be checked if putting it after the*)
406                                (* node changes things or not. I do that because otherwise a *)
407                                (* computation might find itself before the first cost_label after a*)
408                                (* branching, breaking well labeling *)
409                    let f' e (next', g'') =
410                                        assert (rest = []); (* when I am assured this must go *)
411                                        if not (ExprMap.mem e redundants) then (next', g'') else
412                                        let (tmp, _) = ExprMap.find e redundants in
413          let opt_calc = 
414                                          match modified_at_stmt stmt, expr_of_stmt stmt with
415                                                  | Some r, Some e' when e = e' ->
416                                                                St_op1 (Op_id, tmp, r, next')
417                                                        | _ -> stmt_of_expr tmp e next' in
418                                        RTLabsUtilities.insert_in_between freshl g'' lbl next' opt_calc in
419                                snd (ExprSet.fold f' (optimal lbl) (next, g'))
420                        | _ -> g' in
421        { def with f_locals = f_locals; f_graph = Label.Map.fold f g g }
422
423               
424(* piecing it all together *)           
425let transform_internal f_def = 
426  let pred_table = RTLabsUtilities.compute_predecessor_lists f_def.f_graph in
427  let ant_nea = compute_anticipatable_and_non_earliest f_def pred_table in
428  (*Printf.printf "Ant + Nearl:\n";
429  print_valu_pair ant_nea f_def.f_graph f_def.f_entry;*)
430  let delay = compute_delayed f_def pred_table ant_nea in
431  (*Printf.printf "Delayed:\n";
432  print_valu_sing delay f_def.f_graph f_def.f_entry;*)
433  let late = late f_def.f_graph delay in
434  (*Printf.printf "Late:\n";
435  print_valu_sing late f_def.f_graph f_def.f_entry;*)
436  let isol = compute_isolated f_def delay in
437  (*Printf.printf "isolated:\n";
438  print_valu_sing isol f_def.f_graph f_def.f_entry;*)
439        let opt = optimal late isol in
440        let redn = redundant f_def.f_graph late isol in
441  (*Printf.printf "optimal:\n";
442  print_valu_sing opt f_def.f_graph f_def.f_entry;
443  Printf.printf "redundant:\n";
444    let f lbl _ =
445      Printf.printf "%s : %s\n" lbl (if redn lbl then "yes" else "no") in
446    RTLabsUtilities.dfs_iter f f_def.f_graph f_def.f_entry;*)
447  store_optimal_computation (remove_redundant f_def redn) opt
448       
449let transform_funct = function
450        | (f, F_int f_def) -> (f, F_int (transform_internal f_def))
451        | f -> f
452
453let trans = Languages.RTLabs, function
454        | Languages.AstRTLabs p ->
455                Languages.AstRTLabs { p with functs = List.map transform_funct p.functs }
456        | _ -> assert false (* wrong language *)
Note: See TracBrowser for help on using the repository browser.