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 subexpression 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 subexpression 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 subexpression 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 
(* compilecommand:"make C .." *) 
537 
(* End: *) 