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 | |
---|
8 | open RTLabs |
---|
9 | open 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 | |
---|
26 | let 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 | |
---|
40 | module LabelPairSet = Set.Make(struct |
---|
41 | type t = Label.t * Label.t |
---|
42 | let compare = compare |
---|
43 | end) |
---|
44 | |
---|
45 | let 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 | |
---|
75 | let 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 *) |
---|
88 | type 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 | |
---|
93 | let 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 | |
---|
99 | let 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 *) |
---|
103 | let modified_at_stmt = RTLabsUtilities.modified_at_stmt |
---|
104 | |
---|
105 | let 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).*) |
---|
111 | let 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 | |
---|
120 | let 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 *) |
---|
124 | let 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 |
---|
139 | |
---|
140 | let used_at g n = used_at_stmt (Label.Map.find n g) |
---|
141 | |
---|
142 | module ExprOrdered = struct |
---|
143 | type t = expr |
---|
144 | let compare = compare |
---|
145 | end |
---|
146 | |
---|
147 | module ExprSet = Set.Make(ExprOrdered) |
---|
148 | module ExprMap = Map.Make(ExprOrdered) |
---|
149 | |
---|
150 | type expr_set = ExprSet.t |
---|
151 | |
---|
152 | let ( ^^ ) = ExprSet.inter |
---|
153 | |
---|
154 | let ( ++ ) = ExprSet.union |
---|
155 | |
---|
156 | let ( ++* ) s = function |
---|
157 | | None -> s |
---|
158 | | Some e -> ExprSet.add e s |
---|
159 | |
---|
160 | let ( --* ) s = function |
---|
161 | | None -> s |
---|
162 | | Some e -> ExprSet.remove e s |
---|
163 | |
---|
164 | let ( -- ) = ExprSet.diff |
---|
165 | |
---|
166 | let 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 | |
---|
177 | let 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 | |
---|
183 | let 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 | |
---|
193 | module 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 | |
---|
205 | end |
---|
206 | |
---|
207 | module 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 | |
---|
218 | end |
---|
219 | |
---|
220 | module 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 | |
---|
231 | end |
---|
232 | |
---|
233 | module Fpair = Fix.Make (Label.ImpMap) (Lpair) |
---|
234 | |
---|
235 | module Fsing = Fix.Make (Label.ImpMap) (Lsing) |
---|
236 | |
---|
237 | module Fexprid = Fix.Make (Label.ImpMap) (Lexprid) |
---|
238 | |
---|
239 | (* printing tools to debug *) |
---|
240 | |
---|
241 | let print_expr = function |
---|
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 | |
---|
249 | let print_prop_pair (p : Fpair.property) = let (ant, nea) = p in |
---|
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" |
---|
256 | |
---|
257 | let print_valu_pair (valu : Fpair.valuation) (g : graph) (entry : Label.t) = |
---|
258 | let f lbl _ = |
---|
259 | Printf.printf "%s: " lbl; |
---|
260 | print_prop_pair (valu lbl) in |
---|
261 | RTLabsUtilities.dfs_iter f g entry |
---|
262 | |
---|
263 | let print_prop_sing (p : Fsing.property) = |
---|
264 | let f e = Printf.printf "%s, " (print_expr e) in |
---|
265 | Printf.printf "{ "; |
---|
266 | ExprSet.iter f p; |
---|
267 | Printf.printf "}\n" |
---|
268 | |
---|
269 | let print_valu_sing (valu : Fsing.valuation) (g : graph) (entry : Label.t) = |
---|
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 | |
---|
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*) |
---|
283 | (* point with a single invocation to a fixpoint calculation. *) |
---|
284 | |
---|
285 | |
---|
286 | let semantics_ant_nea |
---|
287 | (g : graph) |
---|
288 | (pred_table : Label.t list Label.Map.t) |
---|
289 | (lbl : Label.t) |
---|
290 | (valu : Fpair.valuation) |
---|
291 | : Fpair.property = |
---|
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 | |
---|
314 | let compute_anticipatable_and_non_earliest |
---|
315 | (f_def : internal_function) |
---|
316 | (pred_table : Label.t list Label.Map.t) |
---|
317 | : Fpair.valuation = |
---|
318 | |
---|
319 | Fpair.lfp (semantics_ant_nea f_def.f_graph pred_table) |
---|
320 | |
---|
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 | |
---|
327 | let 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 = |
---|
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 | |
---|
345 | let compute_delayed |
---|
346 | (f_def : internal_function) |
---|
347 | (pred_table : Label.t list Label.Map.t) |
---|
348 | (ant_nea : Fpair.valuation) |
---|
349 | : Fsing.valuation = |
---|
350 | |
---|
351 | Fsing.lfp (semantics_delay f_def.f_graph pred_table ant_nea) |
---|
352 | |
---|
353 | (* An expression is latest at p if it cannot be delayed further *) |
---|
354 | let late (g : graph) (delay : Fsing.valuation) |
---|
355 | : Fsing.valuation = fun lbl -> |
---|
356 | let stmt = Label.Map.find lbl g in |
---|
357 | let succs = RTLabsUtilities.statement_successors stmt in |
---|
358 | |
---|
359 | let eo = match expr_of g lbl with |
---|
360 | | Some e when ExprSet.mem e (delay lbl) -> Some e |
---|
361 | | _ -> None in |
---|
362 | |
---|
363 | (delay lbl -- big_inter delay succs) ++* eo |
---|
364 | |
---|
365 | |
---|
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. *) |
---|
373 | let semantics_isolated_used |
---|
374 | (g : graph) |
---|
375 | (late : Fsing.valuation) |
---|
376 | (lbl : Label.t) |
---|
377 | (valu : Fexprid.valuation) |
---|
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 | |
---|
396 | let compute_isolated_used |
---|
397 | (f_def : internal_function) |
---|
398 | (delayed : Fsing.valuation) |
---|
399 | : Fexprid.valuation = |
---|
400 | |
---|
401 | let graph = f_def.f_graph in |
---|
402 | |
---|
403 | Fexprid.lfp (semantics_isolated_used graph (late graph delayed)) |
---|
404 | |
---|
405 | (* expressions that are optimally placed at point p, without being isolated *) |
---|
406 | let optimal (late : Fsing.valuation) (isol : Fsing.valuation) |
---|
407 | : Fsing.valuation = fun lbl -> |
---|
408 | late lbl -- isol lbl |
---|
409 | |
---|
410 | (* mark instructions that are redundant and can be removed *) |
---|
411 | let redundant g late isol lbl = |
---|
412 | match expr_of g lbl with |
---|
413 | | Some e when ExprSet.mem e (isol lbl) -> |
---|
414 | false |
---|
415 | | Some _ -> true |
---|
416 | | _ -> false |
---|
417 | |
---|
418 | (* mark instructions that modify an unused register *) |
---|
419 | let unused g used lbl = |
---|
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 |
---|
425 | |
---|
426 | (*------ PHASE 4 : place expressions, remove reduntant ones -------------*) |
---|
427 | |
---|
428 | let remove_redundant def is_redundant is_unused = |
---|
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 |
---|
433 | let succ = List.hd (RTLabsUtilities.statement_successors stmt) in |
---|
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) |
---|
454 | |
---|
455 | let stmt_of_expr |
---|
456 | (r : Register.t) |
---|
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) |
---|
464 | |
---|
465 | let insert_after exprs redundants g freshl lbl next = |
---|
466 | let f e (next', g') = |
---|
467 | try |
---|
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 |
---|
471 | with |
---|
472 | | Not_found -> (next', g') in |
---|
473 | snd (ExprSet.fold f exprs (next, g)) |
---|
474 | |
---|
475 | let insert_before exprs redundants g freshl lbl stmt = |
---|
476 | let f e (stmt', g') = |
---|
477 | try |
---|
478 | let (tmp, _) = ExprMap.find e redundants in |
---|
479 | let n_lbl = freshl () in |
---|
480 | let opt_calc = stmt_of_expr tmp e n_lbl in |
---|
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 |
---|
486 | snd (ExprSet.fold f exprs (stmt, g)) |
---|
487 | |
---|
488 | let store_optimal_computation (def, redundants) optimal = |
---|
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 |
---|
495 | let freshl () = Label.Gen.fresh def.f_luniverse in |
---|
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 } |
---|
505 | |
---|
506 | |
---|
507 | (* piecing it all together *) |
---|
508 | let transform_internal f_def = |
---|
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 |
---|
514 | let isol = fun lbl -> fst (isol_used lbl) in |
---|
515 | let used = fun lbl -> snd (isol_used lbl) in |
---|
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 | |
---|
527 | let transform_funct = function |
---|
528 | | (f, F_int f_def) -> (f, F_int (transform_internal f_def)) |
---|
529 | | f -> f |
---|
530 | |
---|
531 | let trans = Languages.RTLabs, function |
---|
532 | | Languages.AstRTLabs p -> |
---|
533 | Languages.AstRTLabs { p with functs = List.map transform_funct p.functs } |
---|
534 | | _ -> assert false (* wrong language *) |
---|