lustrec / src / optimize_machine.ml @ 521e2a6b
History  View  Annotate  Download (22.9 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  
62 
(* 8th Jan 2016: issues when merging salsa with horn_encoding: The following 
63 
functions seem unsused. They have to be adapted to the new type for expr 
64 
*) 
65  
66 
let unfold_expr_offset m offset expr = 
67 
List.fold_left 
68 
(fun res > (function  Index i > mk_val (Access (res, value_of_dimension m i)) 
69 
(Types.array_element_type res.value_type) 
70 
 Field f > Format.eprintf "internal error: not yet implemented !"; assert false)) 
71 
expr offset 
72  
73 
let rec simplify_cst_expr m offset typ cst = 
74 
match offset, cst with 
75 
 [] , _ 
76 
> mk_val (Cst cst) typ 
77 
 Index i :: q, Const_array cl when Dimension.is_dimension_const i 
78 
> let elt_typ = Types.array_element_type typ in 
79 
simplify_cst_expr m q elt_typ (List.nth cl (Dimension.size_const_dimension i)) 
80 
 Index i :: q, Const_array cl 
81 
> let elt_typ = Types.array_element_type typ in 
82 
unfold_expr_offset m [Index i] (mk_val (Array (List.map (simplify_cst_expr m q elt_typ) cl)) typ) 
83 
 Field f :: q, Const_struct fl 
84 
> let fld_typ = Types.struct_field_type typ f in 
85 
simplify_cst_expr m q fld_typ (List.assoc f fl) 
86 
 _ > (Format.eprintf "internal error: Optimize_machine.simplify_cst_expr %a@." Printers.pp_const cst; assert false) 
87  
88 
let simplify_expr_offset m expr = 
89 
let rec simplify offset expr = 
90 
match offset, expr.value_desc with 
91 
 Field f ::q , _ > failwith "not yet implemented" 
92 
 _ , Fun (id, vl) when Basic_library.is_value_internal_fun expr 
93 
> mk_val (Fun (id, List.map (simplify offset) vl)) expr.value_type 
94 
 _ , Fun _ 
95 
 _ , StateVar _ 
96 
 _ , LocalVar _ > unfold_expr_offset m offset expr 
97 
 _ , Cst cst > simplify_cst_expr m offset expr.value_type cst 
98 
 _ , Access (expr, i) > simplify (Index (dimension_of_value i) :: offset) expr 
99 
 [] , _ > expr 
100 
 Index _ :: q, Power (expr, _) > simplify q expr 
101 
 Index i :: q, Array vl when Dimension.is_dimension_const i 
102 
> simplify q (List.nth vl (Dimension.size_const_dimension i)) 
103 
 Index i :: q, Array vl > unfold_expr_offset m [Index i] (mk_val (Array (List.map (simplify q) vl)) expr.value_type) 
104 
(*Format.eprintf "simplify_expr %a %a = %a@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset pp_val res; res) 
105 
with e > (Format.eprintf "simplify_expr %a %a = <FAIL>@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset; raise e*) 
106 
in simplify [] expr 
107  
108 
let rec simplify_instr_offset m instr = 
109 
match instr with 
110 
 MLocalAssign (v, expr) > MLocalAssign (v, simplify_expr_offset m expr) 
111 
 MStateAssign (v, expr) > MStateAssign (v, simplify_expr_offset m expr) 
112 
 MReset id > instr 
113 
 MNoReset id > instr 
114 
 MStep (outputs, id, inputs) > MStep (outputs, id, List.map (simplify_expr_offset m) inputs) 
115 
 MBranch (cond, brl) 
116 
> MBranch(simplify_expr_offset m cond, List.map (fun (l, il) > l, simplify_instrs_offset m il) brl) 
117 
 MComment _ > instr 
118  
119 
and simplify_instrs_offset m instrs = 
120 
List.map (simplify_instr_offset m) instrs 
121  
122 
let is_scalar_const c = 
123 
match c with 
124 
 Const_real _ 
125 
 Const_int _ 
126 
 Const_tag _ > true 
127 
 _ > false 
128  
129 
(* An instruction v = expr may (and will) be unfolded iff: 
130 
 either expr is atomic 
131 
(no complex expressions, only const, vars and array/struct accesses) 
132 
 or v has a fanin <= 1 (used at most once) 
133 
*) 
134 
let is_unfoldable_expr fanin expr = 
135 
let rec unfold_const offset cst = 
136 
match offset, cst with 
137 
 _ , Const_int _ 
138 
 _ , Const_real _ 
139 
 _ , Const_tag _ > true 
140 
 Field f :: q, Const_struct fl > unfold_const q (List.assoc f fl) 
141 
 [] , Const_struct _ > false 
142 
 Index i :: q, Const_array cl when Dimension.is_dimension_const i 
143 
> unfold_const q (List.nth cl (Dimension.size_const_dimension i)) 
144 
 _ , Const_array _ > false 
145 
 _ > assert false in 
146 
let rec unfold offset expr = 
147 
match offset, expr.value_desc with 
148 
 _ , Cst cst > unfold_const offset cst 
149 
 _ , LocalVar _ 
150 
 _ , StateVar _ > true 
151 
 [] , Power _ 
152 
 [] , Array _ > false 
153 
 Index i :: q, Power (v, _) > unfold q v 
154 
 Index i :: q, Array vl when Dimension.is_dimension_const i 
155 
> unfold q (List.nth vl (Dimension.size_const_dimension i)) 
156 
 _ , Array _ > false 
157 
 _ , Access (v, i) > unfold (Index (dimension_of_value i) :: offset) v 
158 
 _ , Fun (id, vl) when fanin < 2 && Basic_library.is_value_internal_fun expr 
159 
> List.for_all (unfold offset) vl 
160 
 _ , Fun _ > false 
161 
 _ > assert false 
162 
in unfold [] expr 
163  
164 
let basic_unfoldable_assign fanin v expr = 
165 
try 
166 
let d = Hashtbl.find fanin v.var_id 
167 
in is_unfoldable_expr d expr 
168 
with Not_found > false 
169  
170 
let unfoldable_assign fanin v expr = 
171 
(if !Options.mpfr then Mpfr.unfoldable_value expr else true) 
172 
&& basic_unfoldable_assign fanin v expr 
173  
174 
let merge_elim elim1 elim2 = 
175 
let merge k e1 e2 = 
176 
match e1, e2 with 
177 
 Some e1, Some e2 > if e1 = e2 then Some e1 else None 
178 
 _ , Some e2 > Some e2 
179 
 Some e1, _ > Some e1 
180 
 _ > None 
181 
in IMap.merge merge elim1 elim2 
182  
183 
(* see if elim has to take in account the provided instr: 
184 
if so, update elim and return the remove flag, 
185 
otherwise, the expression should be kept and elim is left untouched *) 
186 
let rec instrs_unfold fanin elim instrs = 
187 
let elim, rev_instrs = 
188 
List.fold_left (fun (elim, instrs) instr > 
189 
(* each subexpression in instr that could be rewritten by the elim set is 
190 
rewritten *) 
191 
let instr = eliminate elim instr in 
192 
(* if instr is a simple local assign, then (a) elim is simplified with it (b) it 
193 
is stored as the elim set *) 
194 
instr_unfold fanin instrs elim instr 
195 
) (elim, []) instrs 
196 
in elim, List.rev rev_instrs 
197  
198 
and instr_unfold fanin instrs elim instr = 
199 
(* Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*) 
200 
match instr with 
201 
(* Simple cases*) 
202 
 MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type) 
203 
> instr_unfold fanin instrs elim (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type)) 
204 
 MLocalAssign(v, expr) when unfoldable_assign fanin v expr 
205 
> (IMap.add v.var_id expr elim, instrs) 
206 
 MBranch(g, hl) when false 
207 
> let elim_branches = List.map (fun (h, l) > (h, instrs_unfold fanin elim l)) hl in 
208 
let (elim, branches) = 
209 
List.fold_right 
210 
(fun (h, (e, l)) (elim, branches) > (merge_elim elim e, (h, l)::branches)) 
211 
elim_branches (elim, []) 
212 
in elim, (MBranch (g, branches) :: instrs) 
213 
 _ 
214 
> (elim, instr :: instrs) 
215 
(* default case, we keep the instruction and do not modify elim *) 
216 

217  
218 
(** We iterate in the order, recording simple local assigns in an accumulator 
219 
1. each expression is rewritten according to the accumulator 
220 
2. local assigns then rewrite occurrences of the lhs in the computed accumulator 
221 
*) 
222  
223 
let static_call_unfold elim (inst, (n, args)) = 
224 
let replace v = 
225 
try 
226 
Machine_code.dimension_of_value (IMap.find v elim) 
227 
with Not_found > Dimension.mkdim_ident Location.dummy_loc v 
228 
in (inst, (n, List.map (Dimension.expr_replace_expr replace) args)) 
229  
230 
(** Perform optimization on machine code: 
231 
 iterate through step instructions and remove simple local assigns 
232 

233 
*) 
234 
let machine_unfold fanin elim machine = 
235 
(*Log.report ~level:1 (fun fmt > Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*) 
236 
let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in 
237 
let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in 
238 
let instrs = simplify_instrs_offset machine instrs in 
239 
let checks = List.map (fun (loc, check) > loc, eliminate_expr elim_vars check) machine.mstep.step_checks in 
240 
let locals = List.filter (fun v > not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in 
241 
let minstances = List.map (static_call_unfold elim_consts) machine.minstances in 
242 
let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls 
243 
in 
244 
{ 
245 
machine with 
246 
mstep = { 
247 
machine.mstep with 
248 
step_locals = locals; 
249 
step_instrs = instrs; 
250 
step_checks = checks 
251 
}; 
252 
mconst = mconst; 
253 
minstances = minstances; 
254 
mcalls = mcalls; 
255 
}, 
256 
elim_vars 
257  
258 
let instr_of_const top_const = 
259 
let const = const_of_top top_const in 
260 
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 
261 
let vdecl = { vdecl with var_type = const.const_type } 
262 
in MLocalAssign (vdecl, mk_val (Cst const.const_value) vdecl.var_type) 
263  
264 
let machines_unfold consts node_schs machines = 
265 
List.fold_right (fun m (machines, removed) > 
266 
let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in 
267 
let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts) in 
268 
let (m, removed_m) = machine_unfold fanin elim_consts m in 
269 
(m::machines, IMap.add m.mname.node_id removed_m removed) 
270 
) 
271 
machines 
272 
([], IMap.empty) 
273  
274 
let get_assign_lhs instr = 
275 
match instr with 
276 
 MLocalAssign(v, e) > mk_val (LocalVar v) e.value_type 
277 
 MStateAssign(v, e) > mk_val (StateVar v) e.value_type 
278 
 _ > assert false 
279  
280 
let get_assign_rhs instr = 
281 
match instr with 
282 
 MLocalAssign(_, e) 
283 
 MStateAssign(_, e) > e 
284 
 _ > assert false 
285  
286 
let is_assign instr = 
287 
match instr with 
288 
 MLocalAssign _ 
289 
 MStateAssign _ > true 
290 
 _ > false 
291  
292 
let mk_assign v e = 
293 
match v.value_desc with 
294 
 LocalVar v > MLocalAssign(v, e) 
295 
 StateVar v > MStateAssign(v, e) 
296 
 _ > assert false 
297  
298 
let rec assigns_instr instr assign = 
299 
match instr with 
300 
 MLocalAssign (i,_) 
301 
 MStateAssign (i,_) > ISet.add i assign 
302 
 MStep (ol, _, _) > List.fold_right ISet.add ol assign 
303 
 MBranch (_,hl) > List.fold_right (fun (_, il) > assigns_instrs il) hl assign 
304 
 _ > assign 
305  
306 
and assigns_instrs instrs assign = 
307 
List.fold_left (fun assign instr > assigns_instr instr assign) assign instrs 
308  
309 
(* 
310 
and substitute_expr subst expr = 
311 
match expr with 
312 
 StateVar v 
313 
 LocalVar v > (try IMap.find expr subst with Not_found > expr) 
314 
 Fun (id, vl) > Fun (id, List.map (substitute_expr subst) vl) 
315 
 Array(vl) > Array(List.map (substitute_expr subst) vl) 
316 
 Access(v1, v2) > Access(substitute_expr subst v1, substitute_expr subst v2) 
317 
 Power(v1, v2) > Power(substitute_expr subst v1, substitute_expr subst v2) 
318 
 Cst _ > expr 
319 
*) 
320 
(** Finds a substitute for [instr] in [instrs], 
321 
i.e. another instr' with the same rhs expression. 
322 
Then substitute this expression with the first assigned var 
323 
*) 
324 
let subst_instr subst instrs instr = 
325 
(*Format.eprintf "subst instr: %a@." Machine_code.pp_instr instr;*) 
326 
let instr = eliminate subst instr in 
327 
let v = get_assign_lhs instr in 
328 
let e = get_assign_rhs instr in 
329 
(* Difficulties to merge with unstable. Here is the other code: 
330  
331 
try 
332 
let instr' = List.find (fun instr' > is_assign instr' && get_assign_rhs instr' = e) instrs in 
333 
match v.value_desc with 
334 
 LocalVar v > 
335 
IMap.add v.var_id (get_assign_lhs instr') subst, instrs 
336 
 StateVar v > 
337 
let lhs' = get_assign_lhs instr' in 
338 
let typ' = lhs'.value_type in 
339 
(match lhs'.value_desc with 
340 
 LocalVar v' > 
341 
let instr = eliminate subst (mk_assign (mk_val (StateVar v) typ') (mk_val (LocalVar v') typ')) in 
342 
subst, instr :: instrs 
343 
 StateVar v' > 
344 
let subst_v' = IMap.add v'.var_id (mk_val (StateVar v) typ') IMap.empty in 
345 
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 
346 
IMap.add v'.var_id (mk_val (StateVar v) typ') subst, instr :: instrs' 
347 
 _ > assert false) 
348 
 _ > assert false 
349 
with Not_found > subst, instr :: instrs 
350 

351 
*) 
352  
353 
try 
354 
let instr' = List.find (fun instr' > is_assign instr' && get_assign_rhs instr' = e) instrs in 
355 
match v.value_desc with 
356 
 LocalVar v > 
357 
IMap.add v.var_id (get_assign_lhs instr') subst, instrs 
358 
 StateVar stv > 
359 
let lhs = get_assign_lhs instr' in 
360 
(match lhs.value_desc with 
361 
 LocalVar v' > 
362 
let instr = eliminate subst (mk_assign v lhs) in 
363 
subst, instr :: instrs 
364 
 StateVar stv' > 
365 
let subst_v' = IMap.add stv'.var_id v IMap.empty in 
366 
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 
367 
IMap.add stv'.var_id v subst, instr :: instrs' 
368 
 _ > assert false) 
369 
 _ > assert false 
370 
with Not_found > subst, instr :: instrs 
371 

372 
(** Common subexpression elimination for machine instructions *) 
373 
(*  [subst] : hashtable from ident to (simple) definition 
374 
it is an equivalence table 
375 
 [elim] : set of eliminated variables 
376 
 [instrs] : previous instructions, which [instr] is compared against 
377 
 [instr] : current instruction, normalized by [subst] 
378 
*) 
379 
let rec instr_cse (subst, instrs) instr = 
380 
match instr with 
381 
(* Simple cases*) 
382 
 MStep([v], id, vl) when Basic_library.is_internal_fun id (List.map (fun v > v.value_type) vl) 
383 
> instr_cse (subst, instrs) (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type)) 
384 
 MLocalAssign(v, expr) when is_unfoldable_expr 2 expr 
385 
> (IMap.add v.var_id expr subst, instr :: instrs) 
386 
 _ when is_assign instr 
387 
> subst_instr subst instrs instr 
388 
 _ > (subst, instr :: instrs) 
389  
390 
(** Apply common subexpression elimination to a sequence of instrs 
391 
*) 
392 
let rec instrs_cse subst instrs = 
393 
let subst, rev_instrs = 
394 
List.fold_left instr_cse (subst, []) instrs 
395 
in subst, List.rev rev_instrs 
396  
397 
(** Apply common subexpression elimination to a machine 
398 
 iterate through step instructions and remove simple local assigns 
399 
*) 
400 
let machine_cse subst machine = 
401 
(*Log.report ~level:1 (fun fmt > Format.fprintf fmt "machine_cse %a@." pp_elim subst);*) 
402 
let subst, instrs = instrs_cse subst machine.mstep.step_instrs in 
403 
let assigned = assigns_instrs instrs ISet.empty 
404 
in 
405 
{ 
406 
machine with 
407 
mmemory = List.filter (fun vdecl > ISet.mem vdecl assigned) machine.mmemory; 
408 
mstep = { 
409 
machine.mstep with 
410 
step_locals = List.filter (fun vdecl > ISet.mem vdecl assigned) machine.mstep.step_locals; 
411 
step_instrs = instrs 
412 
} 
413 
} 
414  
415 
let machines_cse machines = 
416 
List.map 
417 
(machine_cse IMap.empty) 
418 
machines 
419  
420 
(* variable substitution for optimizing purposes *) 
421  
422 
(* checks whether an [instr] is skip and can be removed from program *) 
423 
let rec instr_is_skip instr = 
424 
match instr with 
425 
 MLocalAssign (i, { value_desc = (LocalVar v) ; _}) when i = v > true 
426 
 MStateAssign (i, { value_desc = StateVar v; _}) when i = v > true 
427 
 MBranch (g, hl) > List.for_all (fun (_, il) > instrs_are_skip il) hl 
428 
 _ > false 
429 
and instrs_are_skip instrs = 
430 
List.for_all instr_is_skip instrs 
431  
432 
let instr_cons instr cont = 
433 
if instr_is_skip instr then cont else instr::cont 
434  
435 
let rec instr_remove_skip instr cont = 
436 
match instr with 
437 
 MLocalAssign (i, { value_desc = LocalVar v; _ }) when i = v > cont 
438 
 MStateAssign (i, { value_desc = StateVar v; _ }) when i = v > cont 
439 
 MBranch (g, hl) > MBranch (g, List.map (fun (h, il) > (h, instrs_remove_skip il [])) hl) :: cont 
440 
 _ > instr::cont 
441  
442 
and instrs_remove_skip instrs cont = 
443 
List.fold_right instr_remove_skip instrs cont 
444  
445 
let rec value_replace_var fvar value = 
446 
match value.value_desc with 
447 
 Cst c > value 
448 
 LocalVar v > { value with value_desc = LocalVar (fvar v) } 
449 
 StateVar v > value 
450 
 Fun (id, args) > { value with value_desc = Fun (id, List.map (value_replace_var fvar) args) } 
451 
 Array vl > { value with value_desc = Array (List.map (value_replace_var fvar) vl)} 
452 
 Access (t, i) > { value with value_desc = Access(value_replace_var fvar t, i)} 
453 
 Power (v, n) > { value with value_desc = Power(value_replace_var fvar v, n)} 
454  
455 
let rec instr_replace_var fvar instr cont = 
456 
match instr with 
457 
 MComment _ > instr_cons instr cont 
458 
 MLocalAssign (i, v) > instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont 
459 
 MStateAssign (i, v) > instr_cons (MStateAssign (i, value_replace_var fvar v)) cont 
460 
 MReset i > instr_cons instr cont 
461 
 MNoReset i > instr_cons instr cont 
462 
 MStep (il, i, vl) > instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont 
463 
 MBranch (g, hl) > instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) > (h, instrs_replace_var fvar il [])) hl)) cont 
464  
465 
and instrs_replace_var fvar instrs cont = 
466 
List.fold_right (instr_replace_var fvar) instrs cont 
467  
468 
let step_replace_var fvar step = 
469 
(* Some outputs may have been replaced by locals. 
470 
We then need to rename those outputs 
471 
without changing their clocks, etc *) 
472 
let outputs' = 
473 
List.map (fun o > { o with var_id = (fvar o).var_id }) step.step_outputs in 
474 
let locals' = 
475 
List.fold_left (fun res l > 
476 
let l' = fvar l in 
477 
if List.exists (fun o > o.var_id = l'.var_id) outputs' 
478 
then res 
479 
else Utils.add_cons l' res) 
480 
[] step.step_locals in 
481 
{ step with 
482 
step_checks = List.map (fun (l, v) > (l, value_replace_var fvar v)) step.step_checks; 
483 
step_outputs = outputs'; 
484 
step_locals = locals'; 
485 
step_instrs = instrs_replace_var fvar step.step_instrs []; 
486 
} 
487  
488 
let rec machine_replace_variables fvar m = 
489 
{ m with 
490 
mstep = step_replace_var fvar m.mstep 
491 
} 
492  
493 
let machine_reuse_variables m reuse = 
494 
let fvar v = 
495 
try 
496 
Hashtbl.find reuse v.var_id 
497 
with Not_found > v in 
498 
machine_replace_variables fvar m 
499  
500 
let machines_reuse_variables prog reuse_tables = 
501 
List.map 
502 
(fun m > 
503 
machine_reuse_variables m (Utils.IMap.find m.mname.node_id reuse_tables) 
504 
) prog 
505  
506 
let rec instr_assign res instr = 
507 
match instr with 
508 
 MLocalAssign (i, _) > Disjunction.CISet.add i res 
509 
 MStateAssign (i, _) > Disjunction.CISet.add i res 
510 
 MBranch (g, hl) > List.fold_left (fun res (h, b) > instrs_assign res b) res hl 
511 
 MStep (il, _, _) > List.fold_right Disjunction.CISet.add il res 
512 
 _ > res 
513  
514 
and instrs_assign res instrs = 
515 
List.fold_left instr_assign res instrs 
516  
517 
let rec instr_constant_assign var instr = 
518 
match instr with 
519 
 MLocalAssign (i, { value_desc = Cst (Const_tag _); _ }) 
520 
 MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) > i = var 
521 
 MBranch (g, hl) > List.for_all (fun (h, b) > instrs_constant_assign var b) hl 
522 
 _ > false 
523  
524 
and instrs_constant_assign var instrs = 
525 
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 
526  
527 
let rec instr_reduce branches instr1 cont = 
528 
match instr1 with 
529 
 MLocalAssign (_, { value_desc = Cst (Const_tag c); _}) > instr1 :: (List.assoc c branches @ cont) 
530 
 MStateAssign (_, { value_desc = Cst (Const_tag c); _}) > instr1 :: (List.assoc c branches @ cont) 
531 
 MBranch (g, hl) > MBranch (g, List.map (fun (h, b) > (h, instrs_reduce branches b [])) hl) :: cont 
532 
 _ > instr1 :: cont 
533  
534 
and instrs_reduce branches instrs cont = 
535 
match instrs with 
536 
 [] > cont 
537 
 [i] > instr_reduce branches i cont 
538 
 i1::i2::q > i1 :: instrs_reduce branches (i2::q) cont 
539  
540 
let rec instrs_fusion instrs = 
541 
match instrs with 
542 
 [] 
543 
 [_] > 
544 
instrs 
545 
 i1::(MBranch ({ value_desc = LocalVar v; _}, hl))::q when instr_constant_assign v i1 > 
546 
instr_reduce (List.map (fun (h, b) > h, instrs_fusion b) hl) i1 (instrs_fusion q) 
547 
 i1::(MBranch ({ value_desc = StateVar v; _}, hl))::q when instr_constant_assign v i1 > 
548 
instr_reduce (List.map (fun (h, b) > h, instrs_fusion b) hl) i1 (instrs_fusion q) 
549 
 i1::i2::q > 
550 
i1 :: instrs_fusion (i2::q) 
551  
552 
let step_fusion step = 
553 
{ step with 
554 
step_instrs = instrs_fusion step.step_instrs; 
555 
} 
556  
557 
let rec machine_fusion m = 
558 
{ m with 
559 
mstep = step_fusion m.mstep 
560 
} 
561  
562 
let machines_fusion prog = 
563 
List.map machine_fusion prog 
564  
565 
(* Local Variables: *) 
566 
(* compilecommand:"make C .." *) 
567 
(* End: *) 