lustrec / src / optimize_machine.ml @ 45f0f48d
History | View | Annotate | Download (21.7 KB)
1 |
(********************************************************************) |
---|---|
2 |
(* *) |
3 |
(* The LustreC compiler toolset / The LustreC Development Team *) |
4 |
(* Copyright 2012 - -- ONERA - CNRS - INPT *) |
5 |
(* *) |
6 |
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *) |
7 |
(* under the terms of the GNU Lesser General Public License *) |
8 |
(* version 2.1. *) |
9 |
(* *) |
10 |
(********************************************************************) |
11 |
|
12 |
open Utils |
13 |
open LustreSpec |
14 |
open Corelang |
15 |
open Causality |
16 |
open Machine_code |
17 |
open Dimension |
18 |
|
19 |
|
20 |
let pp_elim fmt elim = |
21 |
begin |
22 |
Format.fprintf fmt "{ /* elim table: */@."; |
23 |
IMap.iter (fun v expr -> Format.fprintf fmt "%s |-> %a@." v pp_val expr) elim; |
24 |
Format.fprintf fmt "}@."; |
25 |
end |
26 |
|
27 |
let rec eliminate elim instr = |
28 |
let e_expr = eliminate_expr elim in |
29 |
match instr with |
30 |
| MComment _ -> instr |
31 |
| MLocalAssign (i,v) -> MLocalAssign (i, e_expr v) |
32 |
| MStateAssign (i,v) -> MStateAssign (i, e_expr v) |
33 |
| MReset i -> instr |
34 |
| MNoReset i -> instr |
35 |
| MStep (il, i, vl) -> MStep(il, i, List.map e_expr vl) |
36 |
| MBranch (g,hl) -> |
37 |
MBranch |
38 |
(e_expr g, |
39 |
(List.map |
40 |
(fun (l, il) -> l, List.map (eliminate elim) il) |
41 |
hl |
42 |
) |
43 |
) |
44 |
|
45 |
and eliminate_expr elim expr = |
46 |
match expr.value_desc with |
47 |
| LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr) |
48 |
| Fun (id, vl) -> {expr with value_desc = Fun (id, List.map (eliminate_expr elim) vl)} |
49 |
| Array(vl) -> {expr with value_desc = Array(List.map (eliminate_expr elim) vl)} |
50 |
| Access(v1, v2) -> { expr with value_desc = Access(eliminate_expr elim v1, eliminate_expr elim v2)} |
51 |
| Power(v1, v2) -> { expr with value_desc = Power(eliminate_expr elim v1, eliminate_expr elim v2)} |
52 |
| Cst _ | StateVar _ -> expr |
53 |
|
54 |
let eliminate_dim elim dim = |
55 |
Dimension.expr_replace_expr |
56 |
(fun v -> try |
57 |
dimension_of_value (IMap.find v elim) |
58 |
with Not_found -> mkdim_ident dim.dim_loc v) |
59 |
dim |
60 |
|
61 |
let unfold_expr_offset m offset expr = |
62 |
List.fold_left |
63 |
(fun res -> (function | Index i -> mk_val (Access (res, value_of_dimension m i)) |
64 |
(Types.array_element_type res.value_type) |
65 |
| Field f -> Format.eprintf "internal error: not yet implemented !"; assert false)) |
66 |
expr offset |
67 |
|
68 |
let rec simplify_cst_expr m offset typ cst = |
69 |
match offset, cst with |
70 |
| [] , _ |
71 |
-> mk_val (Cst cst) typ |
72 |
| Index i :: q, Const_array cl when Dimension.is_dimension_const i |
73 |
-> let elt_typ = Types.array_element_type typ in |
74 |
simplify_cst_expr m q elt_typ (List.nth cl (Dimension.size_const_dimension i)) |
75 |
| Index i :: q, Const_array cl |
76 |
-> let elt_typ = Types.array_element_type typ in |
77 |
unfold_expr_offset m [Index i] (mk_val (Array (List.map (simplify_cst_expr m q elt_typ) cl)) typ) |
78 |
| Field f :: q, Const_struct fl |
79 |
-> let fld_typ = Types.struct_field_type typ f in |
80 |
simplify_cst_expr m q fld_typ (List.assoc f fl) |
81 |
| _ -> (Format.eprintf "internal error: Optimize_machine.simplify_cst_expr %a@." Printers.pp_const cst; assert false) |
82 |
|
83 |
let simplify_expr_offset m expr = |
84 |
let rec simplify offset expr = |
85 |
match offset, expr.value_desc with |
86 |
| Field f ::q , _ -> failwith "not yet implemented" |
87 |
| _ , Fun (id, vl) when Basic_library.is_value_internal_fun expr |
88 |
-> mk_val (Fun (id, List.map (simplify offset) vl)) expr.value_type |
89 |
| _ , Fun _ |
90 |
| _ , StateVar _ |
91 |
| _ , LocalVar _ -> unfold_expr_offset m offset expr |
92 |
| _ , Cst cst -> simplify_cst_expr m offset expr.value_type cst |
93 |
| _ , Access (expr, i) -> simplify (Index (dimension_of_value i) :: offset) expr |
94 |
| [] , _ -> expr |
95 |
| Index _ :: q, Power (expr, _) -> simplify q expr |
96 |
| Index i :: q, Array vl when Dimension.is_dimension_const i |
97 |
-> simplify q (List.nth vl (Dimension.size_const_dimension i)) |
98 |
| Index i :: q, Array vl -> unfold_expr_offset m [Index i] (mk_val (Array (List.map (simplify q) vl)) expr.value_type) |
99 |
(*Format.eprintf "simplify_expr %a %a = %a@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset pp_val res; res) |
100 |
with e -> (Format.eprintf "simplify_expr %a %a = <FAIL>@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset; raise e*) |
101 |
in simplify [] expr |
102 |
|
103 |
let rec simplify_instr_offset m instr = |
104 |
match instr with |
105 |
| MLocalAssign (v, expr) -> MLocalAssign (v, simplify_expr_offset m expr) |
106 |
| MStateAssign (v, expr) -> MStateAssign (v, simplify_expr_offset m expr) |
107 |
| MReset id -> instr |
108 |
| MNoReset id -> instr |
109 |
| MStep (outputs, id, inputs) -> MStep (outputs, id, List.map (simplify_expr_offset m) inputs) |
110 |
| MBranch (cond, brl) |
111 |
-> MBranch(simplify_expr_offset m cond, List.map (fun (l, il) -> l, simplify_instrs_offset m il) brl) |
112 |
| MComment _ -> instr |
113 |
|
114 |
and simplify_instrs_offset m instrs = |
115 |
List.map (simplify_instr_offset m) instrs |
116 |
|
117 |
let is_scalar_const c = |
118 |
match c with |
119 |
| Const_real _ |
120 |
| Const_int _ |
121 |
| Const_tag _ -> true |
122 |
| _ -> false |
123 |
|
124 |
(* An instruction v = expr may (and will) be unfolded iff: |
125 |
- either expr is atomic |
126 |
(no complex expressions, only const, vars and array/struct accesses) |
127 |
- or v has a fanin <= 1 (used at most once) |
128 |
*) |
129 |
let is_unfoldable_expr fanin expr = |
130 |
let rec unfold_const offset cst = |
131 |
match offset, cst with |
132 |
| _ , Const_int _ |
133 |
| _ , Const_real _ |
134 |
| _ , Const_tag _ -> true |
135 |
| Field f :: q, Const_struct fl -> unfold_const q (List.assoc f fl) |
136 |
| [] , Const_struct _ -> false |
137 |
| Index i :: q, Const_array cl when Dimension.is_dimension_const i |
138 |
-> unfold_const q (List.nth cl (Dimension.size_const_dimension i)) |
139 |
| _ , Const_array _ -> false |
140 |
| _ -> assert false in |
141 |
let rec unfold offset expr = |
142 |
match offset, expr.value_desc with |
143 |
| _ , Cst cst -> unfold_const offset cst |
144 |
| _ , LocalVar _ |
145 |
| _ , StateVar _ -> true |
146 |
| [] , Power _ |
147 |
| [] , Array _ -> false |
148 |
| Index i :: q, Power (v, _) -> unfold q v |
149 |
| Index i :: q, Array vl when Dimension.is_dimension_const i |
150 |
-> unfold q (List.nth vl (Dimension.size_const_dimension i)) |
151 |
| _ , Array _ -> false |
152 |
| _ , Access (v, i) -> unfold (Index (dimension_of_value i) :: offset) v |
153 |
| _ , Fun (id, vl) when fanin < 2 && Basic_library.is_value_internal_fun expr |
154 |
-> List.for_all (unfold offset) vl |
155 |
| _ , Fun _ -> false |
156 |
| _ -> assert false |
157 |
in unfold [] expr |
158 |
|
159 |
let basic_unfoldable_assign fanin v expr = |
160 |
try |
161 |
let d = Hashtbl.find fanin v.var_id |
162 |
in is_unfoldable_expr d expr |
163 |
with Not_found -> false |
164 |
|
165 |
let unfoldable_assign fanin v expr = |
166 |
(if !Options.mpfr then Mpfr.unfoldable_value expr else true) |
167 |
&& basic_unfoldable_assign fanin v expr |
168 |
|
169 |
let merge_elim elim1 elim2 = |
170 |
let merge k e1 e2 = |
171 |
match e1, e2 with |
172 |
| Some e1, Some e2 -> if e1 = e2 then Some e1 else None |
173 |
| _ , Some e2 -> Some e2 |
174 |
| Some e1, _ -> Some e1 |
175 |
| _ -> None |
176 |
in IMap.merge merge elim1 elim2 |
177 |
|
178 |
(* see if elim has to take in account the provided instr: |
179 |
if so, update elim and return the remove flag, |
180 |
otherwise, the expression should be kept and elim is left untouched *) |
181 |
let rec instrs_unfold fanin elim instrs = |
182 |
let elim, rev_instrs = |
183 |
List.fold_left (fun (elim, instrs) instr -> |
184 |
(* each subexpression in instr that could be rewritten by the elim set is |
185 |
rewritten *) |
186 |
let instr = eliminate elim instr in |
187 |
(* if instr is a simple local assign, then (a) elim is simplified with it (b) it |
188 |
is stored as the elim set *) |
189 |
instr_unfold fanin instrs elim instr |
190 |
) (elim, []) instrs |
191 |
in elim, List.rev rev_instrs |
192 |
|
193 |
and instr_unfold fanin instrs elim instr = |
194 |
(* Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*) |
195 |
match instr with |
196 |
(* Simple cases*) |
197 |
| MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type) |
198 |
-> instr_unfold fanin instrs elim (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type)) |
199 |
| MLocalAssign(v, expr) when unfoldable_assign fanin v expr |
200 |
-> (IMap.add v.var_id expr elim, instrs) |
201 |
| MBranch(g, hl) when false |
202 |
-> let elim_branches = List.map (fun (h, l) -> (h, instrs_unfold fanin elim l)) hl in |
203 |
let (elim, branches) = |
204 |
List.fold_right |
205 |
(fun (h, (e, l)) (elim, branches) -> (merge_elim elim e, (h, l)::branches)) |
206 |
elim_branches (elim, []) |
207 |
in elim, (MBranch (g, branches) :: instrs) |
208 |
| _ |
209 |
-> (elim, instr :: instrs) |
210 |
(* default case, we keep the instruction and do not modify elim *) |
211 |
|
212 |
|
213 |
(** We iterate in the order, recording simple local assigns in an accumulator |
214 |
1. each expression is rewritten according to the accumulator |
215 |
2. local assigns then rewrite occurrences of the lhs in the computed accumulator |
216 |
*) |
217 |
|
218 |
let static_call_unfold elim (inst, (n, args)) = |
219 |
let replace v = |
220 |
try |
221 |
Machine_code.dimension_of_value (IMap.find v elim) |
222 |
with Not_found -> Dimension.mkdim_ident Location.dummy_loc v |
223 |
in (inst, (n, List.map (Dimension.expr_replace_expr replace) args)) |
224 |
|
225 |
(** Perform optimization on machine code: |
226 |
- iterate through step instructions and remove simple local assigns |
227 |
|
228 |
*) |
229 |
let machine_unfold fanin elim machine = |
230 |
(*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*) |
231 |
let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in |
232 |
let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in |
233 |
let instrs = simplify_instrs_offset machine instrs in |
234 |
let checks = List.map (fun (loc, check) -> loc, eliminate_expr elim_vars check) machine.mstep.step_checks in |
235 |
let locals = List.filter (fun v -> not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in |
236 |
let minstances = List.map (static_call_unfold elim_consts) machine.minstances in |
237 |
let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls |
238 |
in |
239 |
{ |
240 |
machine with |
241 |
mstep = { |
242 |
machine.mstep with |
243 |
step_locals = locals; |
244 |
step_instrs = instrs; |
245 |
step_checks = checks |
246 |
}; |
247 |
mconst = mconst; |
248 |
minstances = minstances; |
249 |
mcalls = mcalls; |
250 |
}, |
251 |
elim_vars |
252 |
|
253 |
let instr_of_const top_const = |
254 |
let const = const_of_top top_const in |
255 |
let vdecl = mkvar_decl Location.dummy_loc (const.const_id, mktyp Location.dummy_loc Tydec_any, mkclock Location.dummy_loc Ckdec_any, true, None) in |
256 |
let vdecl = { vdecl with var_type = const.const_type } |
257 |
in MLocalAssign (vdecl, mk_val (Cst const.const_value) vdecl.var_type) |
258 |
|
259 |
let machines_unfold consts node_schs machines = |
260 |
List.fold_right (fun m (machines, removed) -> |
261 |
let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in |
262 |
let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts) in |
263 |
let (m, removed_m) = machine_unfold fanin elim_consts m in |
264 |
(m::machines, IMap.add m.mname.node_id removed_m removed) |
265 |
) |
266 |
machines |
267 |
([], IMap.empty) |
268 |
|
269 |
let get_assign_lhs instr = |
270 |
match instr with |
271 |
| MLocalAssign(v, e) -> mk_val (LocalVar v) e.value_type |
272 |
| MStateAssign(v, e) -> mk_val (StateVar v) e.value_type |
273 |
| _ -> assert false |
274 |
|
275 |
let get_assign_rhs instr = |
276 |
match instr with |
277 |
| MLocalAssign(_, e) |
278 |
| MStateAssign(_, e) -> e |
279 |
| _ -> assert false |
280 |
|
281 |
let is_assign instr = |
282 |
match instr with |
283 |
| MLocalAssign _ |
284 |
| MStateAssign _ -> true |
285 |
| _ -> false |
286 |
|
287 |
let mk_assign v e = |
288 |
match v.value_desc with |
289 |
| LocalVar v -> MLocalAssign(v, e) |
290 |
| StateVar v -> MStateAssign(v, e) |
291 |
| _ -> assert false |
292 |
|
293 |
let rec assigns_instr instr assign = |
294 |
match instr with |
295 |
| MLocalAssign (i,_) |
296 |
| MStateAssign (i,_) -> ISet.add i assign |
297 |
| MStep (ol, _, _) -> List.fold_right ISet.add ol assign |
298 |
| MBranch (_,hl) -> List.fold_right (fun (_, il) -> assigns_instrs il) hl assign |
299 |
| _ -> assign |
300 |
|
301 |
and assigns_instrs instrs assign = |
302 |
List.fold_left (fun assign instr -> assigns_instr instr assign) assign instrs |
303 |
|
304 |
(* |
305 |
and substitute_expr subst expr = |
306 |
match expr with |
307 |
| StateVar v |
308 |
| LocalVar v -> (try IMap.find expr subst with Not_found -> expr) |
309 |
| Fun (id, vl) -> Fun (id, List.map (substitute_expr subst) vl) |
310 |
| Array(vl) -> Array(List.map (substitute_expr subst) vl) |
311 |
| Access(v1, v2) -> Access(substitute_expr subst v1, substitute_expr subst v2) |
312 |
| Power(v1, v2) -> Power(substitute_expr subst v1, substitute_expr subst v2) |
313 |
| Cst _ -> expr |
314 |
*) |
315 |
(** Finds a substitute for [instr] in [instrs], |
316 |
i.e. another instr' with the same rhs expression. |
317 |
Then substitute this expression with the first assigned var |
318 |
*) |
319 |
let subst_instr subst instrs instr = |
320 |
(*Format.eprintf "subst instr: %a@." Machine_code.pp_instr instr;*) |
321 |
let instr = eliminate subst instr in |
322 |
let v = get_assign_lhs instr in |
323 |
let e = get_assign_rhs instr in |
324 |
try |
325 |
let instr' = List.find (fun instr' -> is_assign instr' && get_assign_rhs instr' = e) instrs in |
326 |
match v.value_desc with |
327 |
| LocalVar v -> |
328 |
IMap.add v.var_id (get_assign_lhs instr') subst, instrs |
329 |
| StateVar stv -> |
330 |
let lhs = get_assign_lhs instr' in |
331 |
(match lhs.value_desc with |
332 |
| LocalVar v' -> |
333 |
let instr = eliminate subst (mk_assign v lhs) in |
334 |
subst, instr :: instrs |
335 |
| StateVar stv' -> |
336 |
let subst_v' = IMap.add stv'.var_id v IMap.empty in |
337 |
let instrs' = snd (List.fold_right (fun instr (ok, instrs) -> (ok || instr = instr', if ok then instr :: instrs else if instr = instr' then instrs else eliminate subst_v' instr :: instrs)) instrs (false, [])) in |
338 |
IMap.add stv'.var_id v subst, instr :: instrs' |
339 |
| _ -> assert false) |
340 |
| _ -> assert false |
341 |
with Not_found -> subst, instr :: instrs |
342 |
|
343 |
(** Common sub-expression elimination for machine instructions *) |
344 |
(* - [subst] : hashtable from ident to (simple) definition |
345 |
it is an equivalence table |
346 |
- [elim] : set of eliminated variables |
347 |
- [instrs] : previous instructions, which [instr] is compared against |
348 |
- [instr] : current instruction, normalized by [subst] |
349 |
*) |
350 |
let rec instr_cse (subst, instrs) instr = |
351 |
match instr with |
352 |
(* Simple cases*) |
353 |
| MStep([v], id, vl) when Basic_library.is_internal_fun id (List.map (fun v -> v.value_type) vl) |
354 |
-> instr_cse (subst, instrs) (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type)) |
355 |
| MLocalAssign(v, expr) when is_unfoldable_expr 2 expr |
356 |
-> (IMap.add v.var_id expr subst, instr :: instrs) |
357 |
| _ when is_assign instr |
358 |
-> subst_instr subst instrs instr |
359 |
| _ -> (subst, instr :: instrs) |
360 |
|
361 |
(** Apply common sub-expression elimination to a sequence of instrs |
362 |
*) |
363 |
let rec instrs_cse subst instrs = |
364 |
let subst, rev_instrs = |
365 |
List.fold_left instr_cse (subst, []) instrs |
366 |
in subst, List.rev rev_instrs |
367 |
|
368 |
(** Apply common sub-expression elimination to a machine |
369 |
- iterate through step instructions and remove simple local assigns |
370 |
*) |
371 |
let machine_cse subst machine = |
372 |
(*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_cse %a@." pp_elim subst);*) |
373 |
let subst, instrs = instrs_cse subst machine.mstep.step_instrs in |
374 |
let assigned = assigns_instrs instrs ISet.empty |
375 |
in |
376 |
{ |
377 |
machine with |
378 |
mmemory = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mmemory; |
379 |
mstep = { |
380 |
machine.mstep with |
381 |
step_locals = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mstep.step_locals; |
382 |
step_instrs = instrs |
383 |
} |
384 |
} |
385 |
|
386 |
let machines_cse machines = |
387 |
List.map |
388 |
(machine_cse IMap.empty) |
389 |
machines |
390 |
|
391 |
(* variable substitution for optimizing purposes *) |
392 |
|
393 |
(* checks whether an [instr] is skip and can be removed from program *) |
394 |
let rec instr_is_skip instr = |
395 |
match instr with |
396 |
| MLocalAssign (i, { value_desc = (LocalVar v) ; _}) when i = v -> true |
397 |
| MStateAssign (i, { value_desc = StateVar v; _}) when i = v -> true |
398 |
| MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl |
399 |
| _ -> false |
400 |
and instrs_are_skip instrs = |
401 |
List.for_all instr_is_skip instrs |
402 |
|
403 |
let instr_cons instr cont = |
404 |
if instr_is_skip instr then cont else instr::cont |
405 |
|
406 |
let rec instr_remove_skip instr cont = |
407 |
match instr with |
408 |
| MLocalAssign (i, { value_desc = LocalVar v; _ }) when i = v -> cont |
409 |
| MStateAssign (i, { value_desc = StateVar v; _ }) when i = v -> cont |
410 |
| MBranch (g, hl) -> MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl) :: cont |
411 |
| _ -> instr::cont |
412 |
|
413 |
and instrs_remove_skip instrs cont = |
414 |
List.fold_right instr_remove_skip instrs cont |
415 |
|
416 |
let rec value_replace_var fvar value = |
417 |
match value.value_desc with |
418 |
| Cst c -> value |
419 |
| LocalVar v -> { value with value_desc = LocalVar (fvar v) } |
420 |
| StateVar v -> value |
421 |
| Fun (id, args) -> { value with value_desc = Fun (id, List.map (value_replace_var fvar) args) } |
422 |
| Array vl -> { value with value_desc = Array (List.map (value_replace_var fvar) vl)} |
423 |
| Access (t, i) -> { value with value_desc = Access(value_replace_var fvar t, i)} |
424 |
| Power (v, n) -> { value with value_desc = Power(value_replace_var fvar v, n)} |
425 |
|
426 |
let rec instr_replace_var fvar instr cont = |
427 |
match instr with |
428 |
| MComment _ -> instr_cons instr cont |
429 |
| MLocalAssign (i, v) -> instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont |
430 |
| MStateAssign (i, v) -> instr_cons (MStateAssign (i, value_replace_var fvar v)) cont |
431 |
| MReset i -> instr_cons instr cont |
432 |
| MStep (il, i, vl) -> instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont |
433 |
| MBranch (g, hl) -> instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl)) cont |
434 |
|
435 |
and instrs_replace_var fvar instrs cont = |
436 |
List.fold_right (instr_replace_var fvar) instrs cont |
437 |
|
438 |
let step_replace_var fvar step = |
439 |
(* Some outputs may have been replaced by locals. |
440 |
We then need to rename those outputs |
441 |
without changing their clocks, etc *) |
442 |
let outputs' = |
443 |
List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs in |
444 |
let locals' = |
445 |
List.fold_left (fun res l -> |
446 |
let l' = fvar l in |
447 |
if List.exists (fun o -> o.var_id = l'.var_id) outputs' |
448 |
then res |
449 |
else Utils.add_cons l' res) |
450 |
[] step.step_locals in |
451 |
{ step with |
452 |
step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks; |
453 |
step_outputs = outputs'; |
454 |
step_locals = locals'; |
455 |
step_instrs = instrs_replace_var fvar step.step_instrs []; |
456 |
} |
457 |
|
458 |
let rec machine_replace_variables fvar m = |
459 |
{ m with |
460 |
mstep = step_replace_var fvar m.mstep |
461 |
} |
462 |
|
463 |
let machine_reuse_variables m reuse = |
464 |
let fvar v = |
465 |
try |
466 |
Hashtbl.find reuse v.var_id |
467 |
with Not_found -> v in |
468 |
machine_replace_variables fvar m |
469 |
|
470 |
let machines_reuse_variables prog reuse_tables = |
471 |
List.map |
472 |
(fun m -> |
473 |
machine_reuse_variables m (Utils.IMap.find m.mname.node_id reuse_tables) |
474 |
) prog |
475 |
|
476 |
let rec instr_assign res instr = |
477 |
match instr with |
478 |
| MLocalAssign (i, _) -> Disjunction.CISet.add i res |
479 |
| MStateAssign (i, _) -> Disjunction.CISet.add i res |
480 |
| MBranch (g, hl) -> List.fold_left (fun res (h, b) -> instrs_assign res b) res hl |
481 |
| MStep (il, _, _) -> List.fold_right Disjunction.CISet.add il res |
482 |
| _ -> res |
483 |
|
484 |
and instrs_assign res instrs = |
485 |
List.fold_left instr_assign res instrs |
486 |
|
487 |
let rec instr_constant_assign var instr = |
488 |
match instr with |
489 |
| MLocalAssign (i, { value_desc = Cst (Const_tag _); _ }) |
490 |
| MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) -> i = var |
491 |
| MBranch (g, hl) -> List.for_all (fun (h, b) -> instrs_constant_assign var b) hl |
492 |
| _ -> false |
493 |
|
494 |
and instrs_constant_assign var instrs = |
495 |
List.fold_left (fun res i -> if Disjunction.CISet.mem var (instr_assign Disjunction.CISet.empty i) then instr_constant_assign var i else res) false instrs |
496 |
|
497 |
let rec instr_reduce branches instr1 cont = |
498 |
match instr1 with |
499 |
| MLocalAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont) |
500 |
| MStateAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont) |
501 |
| MBranch (g, hl) -> MBranch (g, List.map (fun (h, b) -> (h, instrs_reduce branches b [])) hl) :: cont |
502 |
| _ -> instr1 :: cont |
503 |
|
504 |
and instrs_reduce branches instrs cont = |
505 |
match instrs with |
506 |
| [] -> cont |
507 |
| [i] -> instr_reduce branches i cont |
508 |
| i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont |
509 |
|
510 |
let rec instrs_fusion instrs = |
511 |
match instrs with |
512 |
| [] |
513 |
| [_] -> |
514 |
instrs |
515 |
| i1::(MBranch ({ value_desc = LocalVar v; _}, hl))::q when instr_constant_assign v i1 -> |
516 |
instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q) |
517 |
| i1::(MBranch ({ value_desc = StateVar v; _}, hl))::q when instr_constant_assign v i1 -> |
518 |
instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q) |
519 |
| i1::i2::q -> |
520 |
i1 :: instrs_fusion (i2::q) |
521 |
|
522 |
let step_fusion step = |
523 |
{ step with |
524 |
step_instrs = instrs_fusion step.step_instrs; |
525 |
} |
526 |
|
527 |
let rec machine_fusion m = |
528 |
{ m with |
529 |
mstep = step_fusion m.mstep |
530 |
} |
531 |
|
532 |
let machines_fusion prog = |
533 |
List.map machine_fusion prog |
534 |
|
535 |
(* Local Variables: *) |
536 |
(* compile-command:"make -C .." *) |
537 |
(* End: *) |