Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / optimize_machine.ml @ 3b2bd83d

History | View | Annotate | Download (21.7 KB)

1 e2068500 Temesghen Kahsai
(********************************************************************)
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 a1daa793 Temesghen Kahsai
20 e2068500 Temesghen Kahsai
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 3b2bd83d Teme
  match instr with
30
  | MComment _         -> instr
31 e2068500 Temesghen Kahsai
  | MLocalAssign (i,v) -> MLocalAssign (i, e_expr v)
32
  | MStateAssign (i,v) -> MStateAssign (i, e_expr v)
33
  | MReset i           -> instr
34 3b2bd83d Teme
  | MNoReset i         -> instr
35 e2068500 Temesghen Kahsai
  | 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 3b2bd83d Teme
  match expr.value_desc with
47 e2068500 Temesghen Kahsai
  | LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr)
48 3b2bd83d Teme
  | 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 e2068500 Temesghen Kahsai
54
let eliminate_dim elim dim =
55 3b2bd83d Teme
  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 e2068500 Temesghen Kahsai
61 a1daa793 Temesghen Kahsai
let unfold_expr_offset m offset expr =
62 3b2bd83d Teme
  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 a1daa793 Temesghen Kahsai
68 3b2bd83d Teme
let rec simplify_cst_expr m offset typ cst =
69 a1daa793 Temesghen Kahsai
    match offset, cst with
70
    | []          , _
71 3b2bd83d Teme
      -> mk_val (Cst cst) typ
72 a1daa793 Temesghen Kahsai
    | Index i :: q, Const_array cl when Dimension.is_dimension_const i
73 3b2bd83d Teme
      -> 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 a1daa793 Temesghen Kahsai
    | Index i :: q, Const_array cl
76 3b2bd83d Teme
      -> 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 a1daa793 Temesghen Kahsai
    | Field f :: q, Const_struct fl
79 3b2bd83d Teme
      -> let fld_typ = Types.struct_field_type typ f in
80
         simplify_cst_expr m q fld_typ (List.assoc f fl)
81 a1daa793 Temesghen Kahsai
    | _ -> (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 3b2bd83d Teme
    match offset, expr.value_desc with
86 a1daa793 Temesghen Kahsai
    | Field f ::q , _                -> failwith "not yet implemented"
87 3b2bd83d Teme
    | _           , 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 a1daa793 Temesghen Kahsai
    | _           , Fun _
90
    | _           , StateVar _
91
    | _           , LocalVar _       -> unfold_expr_offset m offset expr
92 3b2bd83d Teme
    | _           , Cst cst          -> simplify_cst_expr m offset expr.value_type cst
93 a1daa793 Temesghen Kahsai
    | _           , 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 3b2bd83d Teme
    | Index i :: q, Array vl         -> unfold_expr_offset m [Index i] (mk_val (Array (List.map (simplify q) vl)) expr.value_type)
99 a1daa793 Temesghen Kahsai
    (*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 3b2bd83d Teme
  | MNoReset id            -> instr
109 a1daa793 Temesghen Kahsai
  | 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 3b2bd83d Teme
  | MComment _             -> instr
113 a1daa793 Temesghen Kahsai
114
and simplify_instrs_offset m instrs =
115
  List.map (simplify_instr_offset m) instrs
116
117 e2068500 Temesghen Kahsai
let is_scalar_const c =
118
  match c with
119
  | Const_real _
120 3b2bd83d Teme
  | Const_int _
121 e2068500 Temesghen Kahsai
  | Const_tag _   -> true
122
  | _             -> false
123
124 a1daa793 Temesghen Kahsai
(* 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 3b2bd83d Teme
    match offset, expr.value_desc with
143 a1daa793 Temesghen Kahsai
    | _           , 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 3b2bd83d Teme
    | _           , Fun (id, vl) when fanin < 2 && Basic_library.is_value_internal_fun expr
154 a1daa793 Temesghen Kahsai
                                                 -> List.for_all (unfold offset) vl
155
    | _           , Fun _                        -> false
156
    | _                                          -> assert false
157
  in unfold [] expr
158 e2068500 Temesghen Kahsai
159 3b2bd83d Teme
let basic_unfoldable_assign fanin v expr =
160 e2068500 Temesghen Kahsai
  try
161
    let d = Hashtbl.find fanin v.var_id
162 a1daa793 Temesghen Kahsai
    in is_unfoldable_expr d expr
163
  with Not_found -> false
164 3b2bd83d Teme
165 a1daa793 Temesghen Kahsai
let unfoldable_assign fanin v expr =
166 3b2bd83d Teme
   (if !Options.mpfr then Mpfr.unfoldable_value expr else true)
167
&& basic_unfoldable_assign fanin v expr
168
169 e2068500 Temesghen Kahsai
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 3b2bd83d Teme
  | 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 e2068500 Temesghen Kahsai
  | 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 a1daa793 Temesghen Kahsai
  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 e2068500 Temesghen Kahsai
  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 a1daa793 Temesghen Kahsai
	  step_instrs = instrs;
245
	  step_checks = checks
246 e2068500 Temesghen Kahsai
      };
247
      mconst = mconst;
248
      minstances = minstances;
249
      mcalls = mcalls;
250 3b2bd83d Teme
  },
251
  elim_vars
252 e2068500 Temesghen Kahsai
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 3b2bd83d Teme
  in MLocalAssign (vdecl, mk_val (Cst const.const_value) vdecl.var_type)
258 e2068500 Temesghen Kahsai
259
let machines_unfold consts node_schs machines =
260 3b2bd83d Teme
  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 e2068500 Temesghen Kahsai
    machines
267 3b2bd83d Teme
    ([], IMap.empty)
268 e2068500 Temesghen Kahsai
269
let get_assign_lhs instr =
270
  match instr with
271 3b2bd83d Teme
  | MLocalAssign(v, e) -> mk_val (LocalVar v) e.value_type
272
  | MStateAssign(v, e) -> mk_val (StateVar v) e.value_type
273 e2068500 Temesghen Kahsai
  | _                  -> 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 3b2bd83d Teme
 match v.value_desc with
289 e2068500 Temesghen Kahsai
 | 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 3b2bd83d Teme
    match v.value_desc with
327 e2068500 Temesghen Kahsai
    | LocalVar v ->
328
      IMap.add v.var_id (get_assign_lhs instr') subst, instrs
329 3b2bd83d Teme
    | StateVar stv ->
330
       let lhs = get_assign_lhs instr' in
331
      (match lhs.value_desc with
332 e2068500 Temesghen Kahsai
      | LocalVar v' ->
333 3b2bd83d Teme
        let instr = eliminate subst (mk_assign v lhs) in
334 e2068500 Temesghen Kahsai
	subst, instr :: instrs
335 3b2bd83d Teme
      | StateVar stv' ->
336
	let subst_v' = IMap.add stv'.var_id v IMap.empty in
337 e2068500 Temesghen Kahsai
	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 3b2bd83d Teme
	IMap.add stv'.var_id v subst, instr :: instrs'
339 e2068500 Temesghen Kahsai
      | _           -> assert false)
340
    | _          -> assert false
341
  with Not_found -> subst, instr :: instrs
342
 
343
(** Common sub-expression elimination for machine instructions *)
344
(* - [subst] : hashtable from ident to (simple) definition
345
               it is an equivalence table
346
   - [elim]   : set of eliminated variables
347
   - [instrs] : previous instructions, which [instr] is compared against
348
   - [instr] : current instruction, normalized by [subst]
349
*)
350
let rec instr_cse (subst, instrs) instr =
351
  match instr with
352
  (* Simple cases*)
353 3b2bd83d Teme
  | 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 a1daa793 Temesghen Kahsai
  | MLocalAssign(v, expr) when is_unfoldable_expr 2 expr
356 e2068500 Temesghen Kahsai
      -> (IMap.add v.var_id expr subst, instr :: instrs)
357
  | _ when is_assign instr
358
      -> subst_instr subst instrs instr
359
  | _ -> (subst, instr :: instrs)
360
361
(** Apply common sub-expression elimination to a sequence of instrs
362
*)
363
let rec instrs_cse subst instrs =
364
  let subst, rev_instrs = 
365
    List.fold_left instr_cse (subst, []) instrs
366
  in subst, List.rev rev_instrs
367
368
(** Apply common sub-expression elimination to a machine
369
    - iterate through step instructions and remove simple local assigns
370
*)
371
let machine_cse subst machine =
372
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_cse %a@." pp_elim subst);*)
373
  let subst, instrs = instrs_cse subst machine.mstep.step_instrs in
374
  let assigned = assigns_instrs instrs ISet.empty
375
  in
376
  {
377
    machine with
378
      mmemory = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mmemory;
379
      mstep = { 
380
	machine.mstep with 
381
	  step_locals = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mstep.step_locals;
382
	  step_instrs = instrs
383
      }
384
  }
385
386
let machines_cse machines =
387
  List.map
388
    (machine_cse IMap.empty)
389
    machines
390
391
(* variable substitution for optimizing purposes *)
392
393
(* checks whether an [instr] is skip and can be removed from program *)
394
let rec instr_is_skip instr =
395
  match instr with
396 3b2bd83d Teme
  | MLocalAssign (i, { value_desc = (LocalVar v) ; _}) when i = v -> true
397
  | MStateAssign (i, { value_desc = StateVar v; _}) when i = v -> true
398 e2068500 Temesghen Kahsai
  | 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 3b2bd83d Teme
  | MLocalAssign (i, { value_desc = LocalVar v; _ }) when i = v -> cont
409
  | MStateAssign (i, { value_desc = StateVar v; _ }) when i = v -> cont
410 e2068500 Temesghen Kahsai
  | 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 3b2bd83d Teme
  match value.value_desc with
418 e2068500 Temesghen Kahsai
  | Cst c -> value
419 3b2bd83d Teme
  | LocalVar v -> { value with value_desc = LocalVar (fvar v) }
420 e2068500 Temesghen Kahsai
  | StateVar v -> value
421 3b2bd83d Teme
  | 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 e2068500 Temesghen Kahsai
426
let rec instr_replace_var fvar instr cont =
427
  match instr with
428 3b2bd83d Teme
  | MComment _          -> instr_cons instr cont
429 e2068500 Temesghen Kahsai
  | 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 3b2bd83d Teme
  | MNoReset i          -> instr_cons instr cont
433 e2068500 Temesghen Kahsai
  | MStep (il, i, vl)   -> instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont
434
  | MBranch (g, hl)     -> instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl)) cont
435
436
and instrs_replace_var fvar instrs cont =
437
  List.fold_right (instr_replace_var fvar) instrs cont
438
439
let step_replace_var fvar step =
440
  (* Some outputs may have been replaced by locals.
441
     We then need to rename those outputs
442
     without changing their clocks, etc *)
443
  let outputs' =
444
    List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs in
445
  let locals'  =
446
    List.fold_left (fun res l ->
447
      let l' = fvar l in
448
      if List.exists (fun o -> o.var_id = l'.var_id) outputs'
449
      then res
450
      else Utils.add_cons l' res)
451
      [] step.step_locals in
452
  { step with
453
    step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks;
454
    step_outputs = outputs';
455
    step_locals = locals';
456
    step_instrs = instrs_replace_var fvar step.step_instrs [];
457
}
458
459
let rec machine_replace_variables fvar m =
460
  { m with
461
    mstep = step_replace_var fvar m.mstep
462
  }
463
464
let machine_reuse_variables m reuse =
465
  let fvar v =
466
    try
467
      Hashtbl.find reuse v.var_id
468
    with Not_found -> v in
469
  machine_replace_variables fvar m
470
471 3b2bd83d Teme
let machines_reuse_variables prog reuse_tables =
472 e2068500 Temesghen Kahsai
  List.map 
473
    (fun m -> 
474 3b2bd83d Teme
      machine_reuse_variables m (Utils.IMap.find m.mname.node_id reuse_tables)
475 e2068500 Temesghen Kahsai
    ) prog
476
477
let rec instr_assign res instr =
478
  match instr with
479
  | MLocalAssign (i, _) -> Disjunction.CISet.add i res
480
  | MStateAssign (i, _) -> Disjunction.CISet.add i res
481
  | MBranch (g, hl)     -> List.fold_left (fun res (h, b) -> instrs_assign res b) res hl
482
  | MStep (il, _, _)    -> List.fold_right Disjunction.CISet.add il res
483
  | _                   -> res
484
485
and instrs_assign res instrs =
486
  List.fold_left instr_assign res instrs
487
488
let rec instr_constant_assign var instr =
489
  match instr with
490 3b2bd83d Teme
  | MLocalAssign (i, { value_desc = Cst (Const_tag _); _ })
491
  | MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) -> i = var
492 e2068500 Temesghen Kahsai
  | MBranch (g, hl)                     -> List.for_all (fun (h, b) -> instrs_constant_assign var b) hl
493
  | _                                   -> false
494
495
and instrs_constant_assign var instrs =
496
  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
497
498
let rec instr_reduce branches instr1 cont =
499
  match instr1 with
500 3b2bd83d Teme
  | MLocalAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont)
501
  | MStateAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont)
502 e2068500 Temesghen Kahsai
  | MBranch (g, hl)                     -> MBranch (g, List.map (fun (h, b) -> (h, instrs_reduce branches b [])) hl) :: cont
503
  | _                                   -> instr1 :: cont
504
505
and instrs_reduce branches instrs cont =
506
 match instrs with
507
 | []        -> cont
508
 | [i]       -> instr_reduce branches i cont
509
 | i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont
510
511
let rec instrs_fusion instrs =
512
  match instrs with
513
  | []
514
  | [_]                                                               ->
515
    instrs
516 3b2bd83d Teme
  | i1::(MBranch ({ value_desc = LocalVar v; _}, hl))::q when instr_constant_assign v i1 ->
517 e2068500 Temesghen Kahsai
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q)
518 3b2bd83d Teme
  | i1::(MBranch ({ value_desc = StateVar v; _}, hl))::q when instr_constant_assign v i1 ->
519 e2068500 Temesghen Kahsai
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q) 
520
  | i1::i2::q                                                         ->
521
    i1 :: instrs_fusion (i2::q)
522
523
let step_fusion step =
524
  { step with
525
    step_instrs = instrs_fusion step.step_instrs;
526
  }
527
528
let rec machine_fusion m =
529
  { m with
530
    mstep = step_fusion m.mstep
531
  }
532
533
let machines_fusion prog =
534
  List.map machine_fusion prog
535
536
(* Local Variables: *)
537
(* compile-command:"make -C .." *)
538
(* End: *)