Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / optimize_machine.ml @ ca88e660

History | View | Annotate | Download (20.8 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 -> 
69
      (function Index i -> 
70
	Access(res, value_of_dimension m i) 
71
      | Field f -> failwith "not yet implemented"))
72
    expr offset
73

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

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

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

    
128
let is_scalar_const c =
129
  match c with
130
  | Const_real _
131
  | Const_int _
132
  | Const_tag _   -> true
133
  | _             -> false
134

    
135
let basic_unfoldable_expr expr =
136
  match expr.value_desc with
137
  | Cst c when is_scalar_const c -> true
138
  | LocalVar _
139
  | StateVar _                   -> true
140
  | _                            -> false
141

    
142
let rec basic_unfoldable_assign fanin v expr =
143
  try
144
    let d = Hashtbl.find fanin v.var_id
145
    in match expr.value_desc with
146
    | Cst c when is_scalar_const c -> true
147
    | Cst c when d < 2             -> true
148
    | LocalVar _
149
    | StateVar _                   -> true
150
    | Fun (id, [a]) when d < 2 && Basic_library.is_value_internal_fun expr -> basic_unfoldable_assign fanin v a
151
    | _                                                          -> false
152
  with Not_found -> false
153

    
154
let unfoldable_assign fanin v expr =
155
   (if !Options.mpfr then Mpfr.unfoldable_value expr else true)
156
&& basic_unfoldable_assign fanin v expr
157

    
158
let merge_elim elim1 elim2 =
159
  let merge k e1 e2 =
160
    match e1, e2 with
161
    | Some e1, Some e2 -> if e1 = e2 then Some e1 else None
162
    | _      , Some e2 -> Some e2
163
    | Some e1, _       -> Some e1
164
    | _                -> None
165
  in IMap.merge merge elim1 elim2
166

    
167
(* see if elim has to take in account the provided instr:
168
   if so, update elim and return the remove flag,
169
   otherwise, the expression should be kept and elim is left untouched *)
170
let rec instrs_unfold fanin elim instrs =
171
  let elim, rev_instrs = 
172
    List.fold_left (fun (elim, instrs) instr ->
173
      (* each subexpression in instr that could be rewritten by the elim set is
174
	 rewritten *)
175
      let instr = eliminate elim instr in
176
      (* if instr is a simple local assign, then (a) elim is simplified with it (b) it
177
	 is stored as the elim set *)
178
      instr_unfold fanin instrs elim instr
179
    ) (elim, []) instrs
180
  in elim, List.rev rev_instrs
181

    
182
and instr_unfold fanin instrs elim instr =
183
(*  Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*)
184
  match instr with
185
  (* Simple cases*)
186
  | MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type)
187
    -> instr_unfold fanin instrs elim (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type))
188
  | MLocalAssign(v, expr) when unfoldable_assign fanin v expr
189
    -> (IMap.add v.var_id expr elim, instrs)
190
  | MBranch(g, hl) when false
191
    -> let elim_branches = List.map (fun (h, l) -> (h, instrs_unfold fanin elim l)) hl in
192
       let (elim, branches) =
193
	 List.fold_right
194
	   (fun (h, (e, l)) (elim, branches) -> (merge_elim elim e, (h, l)::branches))
195
	   elim_branches (elim, [])
196
       in elim, (MBranch (g, branches) :: instrs)
197
  | _
198
    -> (elim, instr :: instrs)
199
    (* default case, we keep the instruction and do not modify elim *)
200
  
201

    
202
(** We iterate in the order, recording simple local assigns in an accumulator
203
    1. each expression is rewritten according to the accumulator
204
    2. local assigns then rewrite occurrences of the lhs in the computed accumulator
205
*)
206

    
207
let static_call_unfold elim (inst, (n, args)) =
208
  let replace v =
209
    try
210
      Machine_code.dimension_of_value (IMap.find v elim)
211
    with Not_found -> Dimension.mkdim_ident Location.dummy_loc v
212
  in (inst, (n, List.map (Dimension.expr_replace_expr replace) args))
213

    
214
(** Perform optimization on machine code:
215
    - iterate through step instructions and remove simple local assigns
216
    - constant switch cases are simplified
217
*)
218
let machine_unfold fanin elim machine =
219
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*)
220
  let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in
221
  let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in
222
  (*let instrs = simplify_instrs_offset machine instrs in*)
223
  let checks = List.map (fun (loc, check) -> loc, eliminate_expr elim_vars check) machine.mstep.step_checks in
224
  let locals = List.filter (fun v -> not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in
225
  let minstances = List.map (static_call_unfold elim_consts) machine.minstances in
226
  let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls
227
  in
228
  {
229
    machine with
230
      mstep = { 
231
	machine.mstep with 
232
	  step_locals = locals;
233
	  step_instrs = instrs;
234
	  step_checks = checks
235
      };
236
      mconst = mconst;
237
      minstances = minstances;
238
      mcalls = mcalls;
239
  },
240
  elim_vars
241

    
242
let instr_of_const top_const =
243
  let const = const_of_top top_const in
244
  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
245
  let vdecl = { vdecl with var_type = const.const_type }
246
  in MLocalAssign (vdecl, mk_val (Cst const.const_value) vdecl.var_type)
247

    
248
let machines_unfold consts node_schs machines =
249
  List.fold_right (fun m (machines, removed) ->
250
    let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in
251
    let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts) in
252
    let (m, removed_m) =  machine_unfold fanin elim_consts m in
253
    (m::machines, IMap.add m.mname.node_id removed_m removed)
254
    )
255
    machines
256
    ([], IMap.empty)
257

    
258
let get_assign_lhs instr =
259
  match instr with
260
  | MLocalAssign(v, e) -> mk_val (LocalVar v) e.value_type
261
  | MStateAssign(v, e) -> mk_val (StateVar v) e.value_type
262
  | _                  -> assert false
263

    
264
let get_assign_rhs instr =
265
  match instr with
266
  | MLocalAssign(_, e)
267
  | MStateAssign(_, e) -> e
268
  | _                  -> assert false
269

    
270
let is_assign instr =
271
  match instr with
272
  | MLocalAssign _
273
  | MStateAssign _ -> true
274
  | _              -> false
275

    
276
let mk_assign v e =
277
 match v.value_desc with
278
 | LocalVar v -> MLocalAssign(v, e)
279
 | StateVar v -> MStateAssign(v, e)
280
 | _          -> assert false
281

    
282
let rec assigns_instr instr assign =
283
  match instr with  
284
  | MLocalAssign (i,_)
285
  | MStateAssign (i,_) -> ISet.add i assign
286
  | MStep (ol, _, _)   -> List.fold_right ISet.add ol assign
287
  | MBranch (_,hl)     -> List.fold_right (fun (_, il) -> assigns_instrs il) hl assign
288
  | _                  -> assign
289

    
290
and assigns_instrs instrs assign =
291
  List.fold_left (fun assign instr -> assigns_instr instr assign) assign instrs
292

    
293
(*    
294
and substitute_expr subst expr =
295
  match expr with
296
  | StateVar v
297
  | LocalVar v -> (try IMap.find expr subst with Not_found -> expr)
298
  | Fun (id, vl) -> Fun (id, List.map (substitute_expr subst) vl)
299
  | Array(vl) -> Array(List.map (substitute_expr subst) vl)
300
  | Access(v1, v2) -> Access(substitute_expr subst v1, substitute_expr subst v2)
301
  | Power(v1, v2) -> Power(substitute_expr subst v1, substitute_expr subst v2)
302
  | Cst _  -> expr
303
*)
304
(** Finds a substitute for [instr] in [instrs], 
305
   i.e. another instr' with the same rhs expression.
306
   Then substitute this expression with the first assigned var
307
*)
308
let subst_instr subst instrs instr =
309
  (*Format.eprintf "subst instr: %a@." Machine_code.pp_instr instr;*)
310
  let instr = eliminate subst instr in
311
  let v = get_assign_lhs instr in
312
  let e = get_assign_rhs instr in
313
  try
314
    let instr' = List.find (fun instr' -> is_assign instr' && get_assign_rhs instr' = e) instrs in
315
    match v.value_desc with
316
    | LocalVar v ->
317
      IMap.add v.var_id (get_assign_lhs instr') subst, instrs
318
    | StateVar v ->
319
      let lhs' = get_assign_lhs instr' in
320
      let typ' = lhs'.value_type in
321
      (match lhs'.value_desc with
322
      | LocalVar v' ->
323
	let instr = eliminate subst (mk_assign (mk_val (StateVar v) typ') (mk_val (LocalVar v') typ')) in
324
	subst, instr :: instrs
325
      | StateVar v' ->
326
	let subst_v' = IMap.add v'.var_id (mk_val (StateVar v) typ') IMap.empty in
327
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
328
	IMap.add v'.var_id (mk_val (StateVar v) typ') subst, instr :: instrs'
329
      | _           -> assert false)
330
    | _          -> assert false
331
  with Not_found -> subst, instr :: instrs
332
 
333
(** Common sub-expression elimination for machine instructions *)
334
(* - [subst] : hashtable from ident to (simple) definition
335
               it is an equivalence table
336
   - [elim]   : set of eliminated variables
337
   - [instrs] : previous instructions, which [instr] is compared against
338
   - [instr] : current instruction, normalized by [subst]
339
*)
340
let rec instr_cse (subst, instrs) instr =
341
  match instr with
342
  (* Simple cases*)
343
  | MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type)
344
      -> instr_cse (subst, instrs) (MLocalAssign (v, (mk_val (Fun (id, vl)) v.var_type)))
345
  | MLocalAssign(v, expr) when basic_unfoldable_expr expr
346
      -> (IMap.add v.var_id expr subst, instr :: instrs)
347
  | _ when is_assign instr
348
      -> subst_instr subst instrs instr
349
  | _ -> (subst, instr :: instrs)
350

    
351
(** Apply common sub-expression elimination to a sequence of instrs
352
*)
353
let rec instrs_cse subst instrs =
354
  let subst, rev_instrs = 
355
    List.fold_left instr_cse (subst, []) instrs
356
  in subst, List.rev rev_instrs
357

    
358
(** Apply common sub-expression elimination to a machine
359
    - iterate through step instructions and remove simple local assigns
360
*)
361
let machine_cse subst machine =
362
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_cse %a@." pp_elim subst);*)
363
  let subst, instrs = instrs_cse subst machine.mstep.step_instrs in
364
  let assigned = assigns_instrs instrs ISet.empty
365
  in
366
  {
367
    machine with
368
      mmemory = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mmemory;
369
      mstep = { 
370
	machine.mstep with 
371
	  step_locals = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mstep.step_locals;
372
	  step_instrs = instrs
373
      }
374
  }
375

    
376
let machines_cse machines =
377
  List.map
378
    (machine_cse IMap.empty)
379
    machines
380

    
381
(* variable substitution for optimizing purposes *)
382

    
383
(* checks whether an [instr] is skip and can be removed from program *)
384
let rec instr_is_skip instr =
385
  match instr with
386
  | MLocalAssign (i, { value_desc = (LocalVar v) ; _}) when i = v -> true
387
  | MStateAssign (i, { value_desc = StateVar v; _}) when i = v -> true
388
  | MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl
389
  | _               -> false
390
and instrs_are_skip instrs =
391
  List.for_all instr_is_skip instrs
392

    
393
let instr_cons instr cont =
394
 if instr_is_skip instr then cont else instr::cont
395

    
396
let rec instr_remove_skip instr cont =
397
  match instr with
398
  | MLocalAssign (i, { value_desc = LocalVar v; _ }) when i = v -> cont
399
  | MStateAssign (i, { value_desc = StateVar v; _ }) when i = v -> cont
400
  | MBranch (g, hl) -> MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl) :: cont
401
  | _               -> instr::cont
402

    
403
and instrs_remove_skip instrs cont =
404
  List.fold_right instr_remove_skip instrs cont
405

    
406
let rec value_replace_var fvar value =
407
  match value.value_desc with
408
  | Cst c -> value
409
  | LocalVar v -> { value with value_desc = LocalVar (fvar v) }
410
  | StateVar v -> value
411
  | Fun (id, args) -> { value with value_desc = Fun (id, List.map (value_replace_var fvar) args) }
412
  | Array vl -> { value with value_desc = Array (List.map (value_replace_var fvar) vl)}
413
  | Access (t, i) -> { value with value_desc = Access(value_replace_var fvar t, i)}
414
  | Power (v, n) -> { value with value_desc = Power(value_replace_var fvar v, n)}
415

    
416
let rec instr_replace_var fvar instr cont =
417
  match instr with
418
  | MComment _          -> instr_cons instr cont
419
  | MLocalAssign (i, v) -> instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont
420
  | MStateAssign (i, v) -> instr_cons (MStateAssign (i, value_replace_var fvar v)) cont
421
  | MReset i            -> instr_cons instr cont
422
  | MNoReset i            -> instr_cons instr cont
423
  | MStep (il, i, vl)   -> instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont
424
  | MBranch (g, hl)     -> instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl)) cont
425

    
426
and instrs_replace_var fvar instrs cont =
427
  List.fold_right (instr_replace_var fvar) instrs cont
428

    
429
let step_replace_var fvar step =
430
  (* Some outputs may have been replaced by locals.
431
     We then need to rename those outputs
432
     without changing their clocks, etc *)
433
  let outputs' =
434
    List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs in
435
  let locals'  =
436
    List.fold_left (fun res l ->
437
      let l' = fvar l in
438
      if List.exists (fun o -> o.var_id = l'.var_id) outputs'
439
      then res
440
      else Utils.add_cons l' res)
441
      [] step.step_locals in
442
  { step with
443
    step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks;
444
    step_outputs = outputs';
445
    step_locals = locals';
446
    step_instrs = instrs_replace_var fvar step.step_instrs [];
447
}
448

    
449
let rec machine_replace_variables fvar m =
450
  { m with
451
    mstep = step_replace_var fvar m.mstep
452
  }
453

    
454
let machine_reuse_variables m reuse =
455
  let fvar v =
456
    try
457
      Hashtbl.find reuse v.var_id
458
    with Not_found -> v in
459
  machine_replace_variables fvar m
460

    
461
let machines_reuse_variables prog reuse_tables =
462
  List.map 
463
    (fun m -> 
464
      machine_reuse_variables m (Utils.IMap.find m.mname.node_id reuse_tables)
465
    ) prog
466

    
467
let rec instr_assign res instr =
468
  match instr with
469
  | MLocalAssign (i, _) -> Disjunction.CISet.add i res
470
  | MStateAssign (i, _) -> Disjunction.CISet.add i res
471
  | MBranch (g, hl)     -> List.fold_left (fun res (h, b) -> instrs_assign res b) res hl
472
  | MStep (il, _, _)    -> List.fold_right Disjunction.CISet.add il res
473
  | _                   -> res
474

    
475
and instrs_assign res instrs =
476
  List.fold_left instr_assign res instrs
477

    
478
let rec instr_constant_assign var instr =
479
  match instr with
480
  | MLocalAssign (i, { value_desc = Cst (Const_tag _); _ })
481
  | MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) -> i = var
482
  | MBranch (g, hl)                     -> List.for_all (fun (h, b) -> instrs_constant_assign var b) hl
483
  | _                                   -> false
484

    
485
and instrs_constant_assign var instrs =
486
  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
487

    
488
let rec instr_reduce branches instr1 cont =
489
  match instr1 with
490
  | MLocalAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont)
491
  | MStateAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont)
492
  | MBranch (g, hl)                     -> MBranch (g, List.map (fun (h, b) -> (h, instrs_reduce branches b [])) hl) :: cont
493
  | _                                   -> instr1 :: cont
494

    
495
and instrs_reduce branches instrs cont =
496
 match instrs with
497
 | []        -> cont
498
 | [i]       -> instr_reduce branches i cont
499
 | i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont
500

    
501
let rec instrs_fusion instrs =
502
  match instrs with
503
  | []
504
  | [_]                                                               ->
505
    instrs
506
  | i1::(MBranch ({ value_desc = LocalVar v; _}, hl))::q when instr_constant_assign v i1 ->
507
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q)
508
  | i1::(MBranch ({ value_desc = StateVar v; _}, hl))::q when instr_constant_assign v i1 ->
509
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q) 
510
  | i1::i2::q                                                         ->
511
    i1 :: instrs_fusion (i2::q)
512

    
513
let step_fusion step =
514
  { step with
515
    step_instrs = instrs_fusion step.step_instrs;
516
  }
517

    
518
let rec machine_fusion m =
519
  { m with
520
    mstep = step_fusion m.mstep
521
  }
522

    
523
let machines_fusion prog =
524
  List.map machine_fusion prog
525

    
526
(* Local Variables: *)
527
(* compile-command:"make -C .." *)
528
(* End: *)