Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / optimize_machine.ml @ cf9cc6f9

History | View | Annotate | Download (21.1 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
  | MLocalAssign (i,v) -> MLocalAssign (i, e_expr v)
31
  | MStateAssign (i,v) -> MStateAssign (i, e_expr v)
32
  | MReset i           -> instr
33
  | MNoReset i         -> instr
34
  | MStep (il, i, vl)  -> MStep(il, i, List.map e_expr vl)
35
  | MBranch (g,hl)     -> 
36
    MBranch
37
      (e_expr g, 
38
       (List.map 
39
	  (fun (l, il) -> l, List.map (eliminate elim) il) 
40
	  hl
41
       )
42
      )
43
    
44
and eliminate_expr elim expr =
45
  match expr with
46
  | StateVar v
47
  | LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr)
48
  | Fun (id, vl) -> Fun (id, List.map (eliminate_expr elim) vl)
49
  | Array(vl) -> Array(List.map (eliminate_expr elim) vl)
50
  | Access(v1, v2) -> Access(eliminate_expr elim v1, eliminate_expr elim v2)
51
  | Power(v1, v2) -> Power(eliminate_expr elim v1, eliminate_expr elim v2)
52
  | Cst _ -> 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 -> 
64
      (function Index i -> 
65
       Access(res, value_of_dimension m i) 
66
      | Field f -> failwith "not yet implemented"))
67
    expr offset
68

    
69
let rec simplify_cst_expr m offset cst =
70
    match offset, cst with
71
    | []          , _
72
        -> Cst cst
73
    | Index i :: q, Const_array cl when Dimension.is_dimension_const i
74
	-> simplify_cst_expr m q (List.nth cl (Dimension.size_const_dimension i))
75
    | Index i :: q, Const_array cl
76
        -> unfold_expr_offset m [Index i] (Array (List.map (simplify_cst_expr m q) cl))
77
    | Field f :: q, Const_struct fl
78
        -> simplify_cst_expr m q (List.assoc f fl)
79
    | _ -> (Format.eprintf "internal error: Optimize_machine.simplify_cst_expr %a@." Printers.pp_const cst; assert false)
80

    
81
let simplify_expr_offset m expr =
82
  let rec simplify offset expr =
83
    match offset, expr with
84
    | Field f ::q , _                -> failwith "not yet implemented"
85
    | _           , Fun (id, vl) when Basic_library.is_internal_fun id
86
                                     -> Fun (id, List.map (simplify offset) vl)
87
    | _           , Fun _
88
    | _           , StateVar _
89
    | _           , LocalVar _       -> unfold_expr_offset m offset expr
90
    | _           , Cst cst          -> simplify_cst_expr m offset cst
91
    | _           , Access (expr, i) -> simplify (Index (dimension_of_value i) :: offset) expr
92
    | []          , _                -> expr
93
    | Index _ :: q, Power (expr, _)  -> simplify q expr
94
    | Index i :: q, Array vl when Dimension.is_dimension_const i
95
                                     -> simplify q (List.nth vl (Dimension.size_const_dimension i))
96
    | Index i :: q, Array vl         -> unfold_expr_offset m [Index i] (Array (List.map (simplify q) vl))
97
(*    | _ -> (Format.eprintf "internal error: Optimize_machine.simplify_expr_offset %a@." pp_val expr; assert false) *)
98
    (*Format.eprintf "simplify_expr %a %a = %a@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset pp_val res; res)
99
     with e -> (Format.eprintf "simplify_expr %a %a = <FAIL>@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset; raise e*)
100
  in simplify [] expr
101

    
102
let rec simplify_instr_offset m accu instr =
103
  match instr with
104
  | MLocalAssign (v, expr) -> MLocalAssign (v, simplify_expr_offset m expr) :: accu
105
  | MStateAssign (v, expr) -> MStateAssign (v, simplify_expr_offset m expr) :: accu
106
  | MReset id              -> instr :: accu
107
  | MNoReset id              -> instr :: accu
108
  | MStep (outputs, id, inputs) -> MStep (outputs, id, List.map (simplify_expr_offset m) inputs) :: accu
109
  | MBranch (cond, brl)
110
    -> (
111
    let cond' = simplify_expr_offset m cond in
112
    match cond' with
113
    | Cst (Const_tag l) -> 
114
      let il = List.assoc l brl in
115
      List.fold_left (simplify_instr_offset m) accu il
116
    |  _ -> MBranch(cond', List.map (fun (l, il) -> l, simplify_instrs_offset m il) brl) :: accu
117
    )
118
and simplify_instrs_offset m instrs =
119
  let rev_l = List.fold_left (simplify_instr_offset m) [] instrs in
120
  List.rev rev_l
121

    
122
let is_scalar_const c =
123
  match c with
124
  | Const_int _
125
  | Const_real _
126
  | Const_float _
127
  | Const_tag _   -> true
128
  | _             -> false
129

    
130
(* An instruction v = expr may (and will) be unfolded iff:
131
   - either expr is atomic
132
     (no complex expressions, only const, vars and array/struct accesses)
133
   - or v has a fanin <= 1 (used at most once)
134
*)
135
let is_unfoldable_expr fanin expr =
136
  let rec unfold_const offset cst =
137
    match offset, cst with
138
    | _           , Const_int _
139
    | _           , Const_real _
140
    | _           , Const_float _
141
    | _           , Const_tag _     -> true
142
    | Field f :: q, Const_struct fl -> unfold_const q (List.assoc f fl)
143
    | []          , Const_struct _  -> false
144
    | Index i :: q, Const_array cl when Dimension.is_dimension_const i
145
                                    -> unfold_const q (List.nth cl (Dimension.size_const_dimension i))
146
    | _           , Const_array _   -> false
147
    | _                             -> assert false in
148
  let rec unfold offset expr =
149
    match offset, expr with
150
    | _           , Cst cst                      -> unfold_const offset cst
151
    | _           , LocalVar _
152
    | _           , StateVar _                   -> true
153
    | []          , Power _
154
    | []          , Array _                      -> false
155
    | Index i :: q, Power (v, _)                 -> unfold q v
156
    | Index i :: q, Array vl when Dimension.is_dimension_const i
157
                                                 -> unfold q (List.nth vl (Dimension.size_const_dimension i))
158
    | _           , Array _                      -> false
159
    | _           , Access (v, i)                -> unfold (Index (dimension_of_value i) :: offset) v
160
    | _           , Fun (id, vl) when fanin < 2 && Basic_library.is_internal_fun id
161
                                                 -> List.for_all (unfold offset) vl
162
    | _           , Fun _                        -> false
163
    | _                                          -> assert false
164
  in unfold [] expr
165

    
166
let unfoldable_assign fanin v expr =
167
  try
168
    let d = Hashtbl.find fanin v.var_id
169
    in is_unfoldable_expr d expr
170
  with Not_found -> false
171
(*
172
let unfoldable_assign fanin v expr =
173
  try
174
    let d = Hashtbl.find fanin v.var_id
175
    in is_basic_expr expr ||
176
    match expr with
177
    | Cst c when d < 2                                           -> true
178
    | Fun (id, _) when d < 2 && Basic_library.is_internal_fun id -> true
179
    | _                                                          -> false
180
  with Not_found -> false
181
*)
182
let merge_elim elim1 elim2 =
183
  let merge k e1 e2 =
184
    match e1, e2 with
185
    | Some e1, Some e2 -> if e1 = e2 then Some e1 else None
186
    | _      , Some e2 -> Some e2
187
    | Some e1, _       -> Some e1
188
    | _                -> None
189
  in IMap.merge merge elim1 elim2
190

    
191
(* see if elim has to take in account the provided instr:
192
   if so, update elim and return the remove flag,
193
   otherwise, the expression should be kept and elim is left untouched *)
194
let rec instrs_unfold fanin elim instrs =
195
  let elim, rev_instrs = 
196
    List.fold_left (fun (elim, instrs) instr ->
197
      (* each subexpression in instr that could be rewritten by the elim set is
198
	 rewritten *)
199
      let instr = eliminate elim instr in
200
      (* if instr is a simple local assign, then (a) elim is simplified with it (b) it
201
	 is stored as the elim set *)
202
      instr_unfold fanin instrs elim instr
203
    ) (elim, []) instrs
204
  in elim, List.rev rev_instrs
205

    
206
and instr_unfold fanin instrs elim instr =
207
(*  Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*)
208
  match instr with
209
  (* Simple cases*)
210
  | MStep([v], id, vl) when Basic_library.is_internal_fun id
211
    -> instr_unfold fanin instrs elim (MLocalAssign (v, Fun (id, vl)))
212
  | MLocalAssign(v, expr) when unfoldable_assign fanin v expr
213
    -> (IMap.add v.var_id expr elim, instrs)
214
  | MBranch(g, hl) when false
215
    -> let elim_branches = List.map (fun (h, l) -> (h, instrs_unfold fanin elim l)) hl in
216
       let (elim, branches) =
217
	 List.fold_right
218
	   (fun (h, (e, l)) (elim, branches) -> (merge_elim elim e, (h, l)::branches))
219
	   elim_branches (elim, [])
220
       in elim, (MBranch (g, branches) :: instrs)
221
  | _
222
    -> (elim, instr :: instrs)
223
    (* default case, we keep the instruction and do not modify elim *)
224
  
225

    
226
(** We iterate in the order, recording simple local assigns in an accumulator
227
    1. each expression is rewritten according to the accumulator
228
    2. local assigns then rewrite occurrences of the lhs in the computed accumulator
229
*)
230

    
231
let static_call_unfold elim (inst, (n, args)) =
232
  let replace v =
233
    try
234
      Machine_code.dimension_of_value (IMap.find v elim)
235
    with Not_found -> Dimension.mkdim_ident Location.dummy_loc v
236
  in (inst, (n, List.map (Dimension.expr_replace_expr replace) args))
237

    
238
(** Perform optimization on machine code:
239
    - iterate through step instructions and remove simple local assigns
240
    - constant switch cases are simplified
241
*)
242
let machine_unfold fanin elim machine =
243
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*)
244
  let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in
245
  let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in
246
  let instrs = simplify_instrs_offset machine instrs in
247
  let checks = List.map (fun (loc, check) -> loc, eliminate_expr elim_vars check) machine.mstep.step_checks in
248
  let locals = List.filter (fun v -> not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in
249
  let minstances = List.map (static_call_unfold elim_consts) machine.minstances in
250
  let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls
251
  in
252
  {
253
    machine with
254
      mstep = { 
255
	machine.mstep with 
256
	  step_locals = locals;
257
	  step_instrs = instrs;
258
	  step_checks = checks
259
      };
260
      mconst = mconst;
261
      minstances = minstances;
262
      mcalls = mcalls;
263
  }
264

    
265
let instr_of_const top_const =
266
  let const = const_of_top top_const in
267
  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
268
  let vdecl = { vdecl with var_type = const.const_type }
269
  in MLocalAssign (vdecl, Cst const.const_value)
270

    
271
let machines_unfold consts node_schs machines =
272
  List.map
273
    (fun m ->
274
      let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in
275
      let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts)
276
      in machine_unfold fanin elim_consts m)
277
    machines
278

    
279
let get_assign_lhs instr =
280
  match instr with
281
  | MLocalAssign(v, _) -> LocalVar v
282
  | MStateAssign(v, _) -> StateVar v
283
  | _                  -> assert false
284

    
285
let get_assign_rhs instr =
286
  match instr with
287
  | MLocalAssign(_, e)
288
  | MStateAssign(_, e) -> e
289
  | _                  -> assert false
290

    
291
let is_assign instr =
292
  match instr with
293
  | MLocalAssign _
294
  | MStateAssign _ -> true
295
  | _              -> false
296

    
297
let mk_assign v e =
298
 match v with
299
 | LocalVar v -> MLocalAssign(v, e)
300
 | StateVar v -> MStateAssign(v, e)
301
 | _          -> assert false
302

    
303
let rec assigns_instr instr assign =
304
  match instr with  
305
  | MLocalAssign (i,_)
306
  | MStateAssign (i,_) -> ISet.add i assign
307
  | MStep (ol, _, _)   -> List.fold_right ISet.add ol assign
308
  | MBranch (_,hl)     -> List.fold_right (fun (_, il) -> assigns_instrs il) hl assign
309
  | _                  -> assign
310

    
311
and assigns_instrs instrs assign =
312
  List.fold_left (fun assign instr -> assigns_instr instr assign) assign instrs
313

    
314
(*    
315
and substitute_expr subst expr =
316
  match expr with
317
  | StateVar v
318
  | LocalVar v -> (try IMap.find expr subst with Not_found -> expr)
319
  | Fun (id, vl) -> Fun (id, List.map (substitute_expr subst) vl)
320
  | Array(vl) -> Array(List.map (substitute_expr subst) vl)
321
  | Access(v1, v2) -> Access(substitute_expr subst v1, substitute_expr subst v2)
322
  | Power(v1, v2) -> Power(substitute_expr subst v1, substitute_expr subst v2)
323
  | Cst _  -> expr
324
*)
325
(** Finds a substitute for [instr] in [instrs], 
326
   i.e. another instr' with the same rhs expression.
327
   Then substitute this expression with the first assigned var
328
*)
329
let subst_instr subst instrs instr =
330
  (*Format.eprintf "subst instr: %a@." Machine_code.pp_instr instr;*)
331
  let instr = eliminate subst instr in
332
  let v = get_assign_lhs instr in
333
  let e = get_assign_rhs instr in
334
  try
335
    let instr' = List.find (fun instr' -> is_assign instr' && get_assign_rhs instr' = e) instrs in
336
    match v with
337
    | LocalVar v ->
338
      IMap.add v.var_id (get_assign_lhs instr') subst, instrs
339
    | StateVar v ->
340
      (match get_assign_lhs instr' with
341
      | LocalVar v' ->
342
	let instr = eliminate subst (mk_assign (StateVar v) (LocalVar v')) in
343
	subst, instr :: instrs
344
      | StateVar v' ->
345
	let subst_v' = IMap.add v'.var_id (StateVar v) IMap.empty in
346
	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
347
	IMap.add v'.var_id (StateVar v) subst, instr :: instrs'
348
      | _           -> assert false)
349
    | _          -> assert false
350
  with Not_found -> subst, instr :: instrs
351
 
352
(** Common sub-expression elimination for machine instructions *)
353
(* - [subst] : hashtable from ident to (simple) definition
354
               it is an equivalence table
355
   - [elim]   : set of eliminated variables
356
   - [instrs] : previous instructions, which [instr] is compared against
357
   - [instr] : current instruction, normalized by [subst]
358
*)
359
let rec instr_cse (subst, instrs) instr =
360
  match instr with
361
  (* Simple cases*)
362
  | MStep([v], id, vl) when Basic_library.is_internal_fun id
363
      -> instr_cse (subst, instrs) (MLocalAssign (v, Fun (id, vl)))
364
  | MLocalAssign(v, expr) when is_unfoldable_expr 2 expr
365
      -> (IMap.add v.var_id expr subst, instr :: instrs)
366
  | _ when is_assign instr
367
      -> subst_instr subst instrs instr
368
  | _ -> (subst, instr :: instrs)
369

    
370
(** Apply common sub-expression elimination to a sequence of instrs
371
*)
372
let rec instrs_cse subst instrs =
373
  let subst, rev_instrs = 
374
    List.fold_left instr_cse (subst, []) instrs
375
  in subst, List.rev rev_instrs
376

    
377
(** Apply common sub-expression elimination to a machine
378
    - iterate through step instructions and remove simple local assigns
379
*)
380
let machine_cse subst machine =
381
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_cse %a@." pp_elim subst);*)
382
  let subst, instrs = instrs_cse subst machine.mstep.step_instrs in
383
  let assigned = assigns_instrs instrs ISet.empty
384
  in
385
  {
386
    machine with
387
      mmemory = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mmemory;
388
      mstep = { 
389
	machine.mstep with 
390
	  step_locals = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mstep.step_locals;
391
	  step_instrs = instrs
392
      }
393
  }
394

    
395
let machines_cse machines =
396
  List.map
397
    (machine_cse IMap.empty)
398
    machines
399

    
400
(* variable substitution for optimizing purposes *)
401

    
402
(* checks whether an [instr] is skip and can be removed from program *)
403
let rec instr_is_skip instr =
404
  match instr with
405
  | MLocalAssign (i, LocalVar v) when i = v -> true
406
  | MStateAssign (i, StateVar v) when i = v -> true
407
  | MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl
408
  | _               -> false
409
and instrs_are_skip instrs =
410
  List.for_all instr_is_skip instrs
411

    
412
let instr_cons instr cont =
413
 if instr_is_skip instr then cont else instr::cont
414

    
415
let rec instr_remove_skip instr cont =
416
  match instr with
417
  | MLocalAssign (i, LocalVar v) when i = v -> cont
418
  | MStateAssign (i, StateVar v) when i = v -> cont
419
  | MBranch (g, hl) -> MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl) :: cont
420
  | _               -> instr::cont
421

    
422
and instrs_remove_skip instrs cont =
423
  List.fold_right instr_remove_skip instrs cont
424

    
425
let rec value_replace_var fvar value =
426
  match value with
427
  | Cst c -> value
428
  | LocalVar v -> LocalVar (fvar v)
429
  | StateVar v -> value
430
  | Fun (id, args) -> Fun (id, List.map (value_replace_var fvar) args) 
431
  | Array vl -> Array (List.map (value_replace_var fvar) vl)
432
  | Access (t, i) -> Access(value_replace_var fvar t, i)
433
  | Power (v, n) -> Power(value_replace_var fvar v, n)
434

    
435
let rec instr_replace_var fvar instr cont =
436
  match instr with
437
  | MLocalAssign (i, v) -> instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont
438
  | MStateAssign (i, v) -> instr_cons (MStateAssign (i, value_replace_var fvar v)) cont
439
  | MReset i            -> instr_cons instr cont
440
  | MNoReset i            -> instr_cons instr cont
441
  | MStep (il, i, vl)   -> instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont
442
  | MBranch (g, hl)     -> instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl)) cont
443

    
444
and instrs_replace_var fvar instrs cont =
445
  List.fold_right (instr_replace_var fvar) instrs cont
446

    
447
let step_replace_var fvar step =
448
  (* Some outputs may have been replaced by locals.
449
     We then need to rename those outputs
450
     without changing their clocks, etc *)
451
  let outputs' =
452
    List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs in
453
  let locals'  =
454
    List.fold_left (fun res l ->
455
      let l' = fvar l in
456
      if List.exists (fun o -> o.var_id = l'.var_id) outputs'
457
      then res
458
      else Utils.add_cons l' res)
459
      [] step.step_locals in
460
  { step with
461
    step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks;
462
    step_outputs = outputs';
463
    step_locals = locals';
464
    step_instrs = instrs_replace_var fvar step.step_instrs [];
465
}
466

    
467
let rec machine_replace_variables fvar m =
468
  { m with
469
    mstep = step_replace_var fvar m.mstep
470
  }
471

    
472
let machine_reuse_variables m reuse =
473
  let fvar v =
474
    try
475
      Hashtbl.find reuse v.var_id
476
    with Not_found -> v in
477
  machine_replace_variables fvar m
478

    
479
let machines_reuse_variables prog node_schs =
480
  List.map 
481
    (fun m -> 
482
      machine_reuse_variables m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table
483
    ) prog
484

    
485
let rec instr_assign res instr =
486
  match instr with
487
  | MLocalAssign (i, _) -> Disjunction.CISet.add i res
488
  | MStateAssign (i, _) -> Disjunction.CISet.add i res
489
  | MBranch (g, hl)     -> List.fold_left (fun res (h, b) -> instrs_assign res b) res hl
490
  | MStep (il, _, _)    -> List.fold_right Disjunction.CISet.add il res
491
  | _                   -> res
492

    
493
and instrs_assign res instrs =
494
  List.fold_left instr_assign res instrs
495

    
496
let rec instr_constant_assign var instr =
497
  match instr with
498
  | MLocalAssign (i, Cst (Const_tag _))
499
  | MStateAssign (i, Cst (Const_tag _)) -> i = var
500
  | MBranch (g, hl)                     -> List.for_all (fun (h, b) -> instrs_constant_assign var b) hl
501
  | _                                   -> false
502

    
503
and instrs_constant_assign var instrs =
504
  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
505

    
506
let rec instr_reduce branches instr1 cont =
507
  match instr1 with
508
  | MLocalAssign (_, Cst (Const_tag c)) -> instr1 :: (List.assoc c branches @ cont)
509
  | MStateAssign (_, Cst (Const_tag c)) -> instr1 :: (List.assoc c branches @ cont)
510
  | MBranch (g, hl)                     -> MBranch (g, List.map (fun (h, b) -> (h, instrs_reduce branches b [])) hl) :: cont
511
  | _                                   -> instr1 :: cont
512

    
513
and instrs_reduce branches instrs cont =
514
 match instrs with
515
 | []        -> cont
516
 | [i]       -> instr_reduce branches i cont
517
 | i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont
518

    
519
let rec instrs_fusion instrs =
520
  match instrs with
521
  | []
522
  | [_]                                                               ->
523
    instrs
524
  | i1::(MBranch (LocalVar v, hl))::q when instr_constant_assign v i1 ->
525
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q)
526
  | i1::(MBranch (StateVar v, hl))::q when instr_constant_assign v i1 ->
527
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q) 
528
  | i1::i2::q                                                         ->
529
    i1 :: instrs_fusion (i2::q)
530

    
531
let step_fusion step =
532
  { step with
533
    step_instrs = instrs_fusion step.step_instrs;
534
  }
535

    
536
let rec machine_fusion m =
537
  { m with
538
    mstep = step_fusion m.mstep
539
  }
540

    
541
let machines_fusion prog =
542
  List.map machine_fusion prog
543

    
544
(* Local Variables: *)
545
(* compile-command:"make -C .." *)
546
(* End: *)