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