Project

General

Profile

Download (25.6 KB) Statistics
| Branch: | Tag: | Revision:
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 Lustre_types 
14
open Machine_code_types
15
open Corelang
16
open Causality
17
open Machine_code_common
18
open Dimension
19

    
20

    
21
let pp_elim fmt elim =
22
  begin
23
    Format.fprintf fmt "@[{ /* elim table: */@ ";
24
    IMap.iter (fun v expr -> Format.fprintf fmt "%s |-> %a@ " v pp_val expr) elim;
25
    Format.fprintf fmt "}@ @]";
26
  end
27

    
28
let rec eliminate elim instr =
29
  let e_expr = eliminate_expr elim in
30
  match get_instr_desc instr with
31
  | MComment _         -> instr
32
  | MLocalAssign (i,v) -> update_instr_desc instr (MLocalAssign (i, e_expr v))
33
  | MStateAssign (i,v) -> update_instr_desc instr (MStateAssign (i, e_expr v))
34
  | MReset i           -> instr
35
  | MNoReset i         -> instr
36
  | MStep (il, i, vl)  -> update_instr_desc instr (MStep(il, i, List.map e_expr vl))
37
  | MBranch (g,hl)     -> 
38
     update_instr_desc instr (
39
       MBranch
40
	 (e_expr g, 
41
	  (List.map 
42
	     (fun (l, il) -> l, List.map (eliminate elim) il) 
43
	     hl
44
	  )
45
	 )
46
     )
47
    
48
and eliminate_expr elim expr =
49
  match expr.value_desc with
50
  | LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr)
51
  | Fun (id, vl) -> {expr with value_desc = Fun (id, List.map (eliminate_expr elim) vl)}
52
  | Array(vl) -> {expr with value_desc = Array(List.map (eliminate_expr elim) vl)}
53
  | Access(v1, v2) -> { expr with value_desc = Access(eliminate_expr elim v1, eliminate_expr elim v2)}
54
  | Power(v1, v2) -> { expr with value_desc = Power(eliminate_expr elim v1, eliminate_expr elim v2)}
55
  | Cst _ | StateVar _ -> expr
56

    
57
let eliminate_dim elim dim =
58
  Dimension.expr_replace_expr 
59
    (fun v -> try
60
		dimension_of_value (IMap.find v elim) 
61
      with Not_found -> mkdim_ident dim.dim_loc v) 
62
    dim
63

    
64

    
65
(* 8th Jan 2016: issues when merging salsa with horn_encoding: The following
66
   functions seem unsused. They have to be adapted to the new type for expr
67
*)
68

    
69
let unfold_expr_offset m offset expr =
70
  List.fold_left
71
    (fun res -> (function | Index i -> mk_val (Access (res, value_of_dimension m i))
72
					      (Types.array_element_type res.value_type)
73
                          | Field f -> Format.eprintf "internal error: not yet implemented !"; assert false))
74
    expr offset
75

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

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

    
111
let rec simplify_instr_offset m instr =
112
  match get_instr_desc instr with
113
  | MLocalAssign (v, expr) -> update_instr_desc instr (MLocalAssign (v, simplify_expr_offset m expr))
114
  | MStateAssign (v, expr) -> update_instr_desc instr (MStateAssign (v, simplify_expr_offset m expr))
115
  | MReset id              -> instr
116
  | MNoReset id            -> instr
117
  | MStep (outputs, id, inputs) -> update_instr_desc instr (MStep (outputs, id, List.map (simplify_expr_offset m) inputs))
118
  | MBranch (cond, brl)
119
    -> update_instr_desc instr (
120
      MBranch(simplify_expr_offset m cond, List.map (fun (l, il) -> l, simplify_instrs_offset m il) brl)
121
    )
122
  | MComment _             -> instr
123

    
124
and simplify_instrs_offset m instrs =
125
  List.map (simplify_instr_offset m) instrs
126

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

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

    
169
let basic_unfoldable_assign fanin v expr =
170
  try
171
    let d = Hashtbl.find fanin v.var_id
172
    in is_unfoldable_expr d expr
173
  with Not_found -> false
174

    
175
let unfoldable_assign fanin v expr =
176
   (if !Options.mpfr then Mpfr.unfoldable_value expr else true)
177
&& basic_unfoldable_assign fanin v expr
178

    
179
let merge_elim elim1 elim2 =
180
  let merge k e1 e2 =
181
    match e1, e2 with
182
    | Some e1, Some e2 -> if e1 = e2 then Some e1 else None
183
    | _      , Some e2 -> Some e2
184
    | Some e1, _       -> Some e1
185
    | _                -> None
186
  in IMap.merge merge elim1 elim2
187

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

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

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

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

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

    
263
let instr_of_const top_const =
264
  let const = const_of_top top_const in
265
  let vdecl = mkvar_decl Location.dummy_loc (const.const_id, mktyp Location.dummy_loc Tydec_any, mkclock Location.dummy_loc Ckdec_any, true, None, None) in
266
  let vdecl = { vdecl with var_type = const.const_type }
267
  in mkinstr (MLocalAssign (vdecl, mk_val (Cst const.const_value) vdecl.var_type))
268

    
269
let machines_unfold consts node_schs machines =
270
  List.fold_right (fun m (machines, removed) ->
271
    let fanin = (IMap.find m.mname.node_id node_schs).Scheduling_type.fanin_table in
272
    let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts) in
273
    let (m, removed_m) =  machine_unfold fanin elim_consts m in
274
    (m::machines, IMap.add m.mname.node_id removed_m removed)
275
    )
276
    machines
277
    ([], IMap.empty)
278

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

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

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

    
297
let mk_assign v e =
298
 match v.value_desc 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 get_instr_desc instr with  
305
  | MLocalAssign (i,_)
306
  | MStateAssign (i,_) -> VSet.add i assign
307
  | MStep (ol, _, _)   -> List.fold_right VSet.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
  (* Difficulties to merge with unstable. Here is the other code:
335

    
336
try
337
    let instr' = List.find (fun instr' -> is_assign instr' && get_assign_rhs instr' = e) instrs in
338
    match v.value_desc with
339
    | LocalVar v ->
340
      IMap.add v.var_id (get_assign_lhs instr') subst, instrs
341
    | StateVar v ->
342
      let lhs' = get_assign_lhs instr' in
343
      let typ' = lhs'.value_type in
344
      (match lhs'.value_desc with
345
      | LocalVar v' ->
346
	let instr = eliminate subst (mk_assign (mk_val (StateVar v) typ') (mk_val (LocalVar v') typ')) in
347
	subst, instr :: instrs
348
      | StateVar v' ->
349
	let subst_v' = IMap.add v'.var_id (mk_val (StateVar v) typ') IMap.empty in
350
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
351
	IMap.add v'.var_id (mk_val (StateVar v) typ') subst, instr :: instrs'
352
      | _           -> assert false)
353
    | _          -> assert false
354
  with Not_found -> subst, instr :: instrs
355
 
356
*)
357

    
358
try
359
    let instr' = List.find (fun instr' -> is_assign instr' && get_assign_rhs instr' = e) instrs in
360
    match v.value_desc with
361
    | LocalVar v ->
362
      IMap.add v.var_id (get_assign_lhs instr') subst, instrs
363
    | StateVar stv ->
364
       let lhs = get_assign_lhs instr' in
365
      (match lhs.value_desc with
366
      | LocalVar v' ->
367
        let instr = eliminate subst (update_instr_desc instr (mk_assign v lhs)) in
368
	subst, instr :: instrs
369
      | StateVar stv' ->
370
	let subst_v' = IMap.add stv'.var_id v IMap.empty in
371
	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
372
	IMap.add stv'.var_id v subst, instr :: instrs'
373
      | _           -> assert false)
374
    | _          -> assert false
375
  with Not_found -> subst, instr :: instrs
376
 
377
(** Common sub-expression elimination for machine instructions *)
378
(* - [subst] : hashtable from ident to (simple) definition
379
               it is an equivalence table
380
   - [elim]   : set of eliminated variables
381
   - [instrs] : previous instructions, which [instr] is compared against
382
   - [instr] : current instruction, normalized by [subst]
383
*)
384
let rec instr_cse (subst, instrs) instr =
385
  match get_instr_desc instr with
386
  (* Simple cases*)
387
  | MStep([v], id, vl) when Basic_library.is_internal_fun id (List.map (fun v -> v.value_type) vl)
388
      -> instr_cse (subst, instrs) (update_instr_desc instr (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type)))
389
  | MLocalAssign(v, expr) when is_unfoldable_expr 2 expr
390
      -> (IMap.add v.var_id expr subst, instr :: instrs)
391
  | _ when is_assign instr
392
      -> subst_instr subst instrs instr
393
  | _ -> (subst, instr :: instrs)
394

    
395
(** Apply common sub-expression elimination to a sequence of instrs
396
*)
397
let rec instrs_cse subst instrs =
398
  let subst, rev_instrs = 
399
    List.fold_left instr_cse (subst, []) instrs
400
  in subst, List.rev rev_instrs
401

    
402
(** Apply common sub-expression elimination to a machine
403
    - iterate through step instructions and remove simple local assigns
404
*)
405
let machine_cse subst machine =
406
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_cse %a@." pp_elim subst);*)
407
  let subst, instrs = instrs_cse subst machine.mstep.step_instrs in
408
  let assigned = assigns_instrs instrs VSet.empty
409
  in
410
  {
411
    machine with
412
      mmemory = List.filter (fun vdecl -> VSet.mem vdecl assigned) machine.mmemory;
413
      mstep = { 
414
	machine.mstep with 
415
	  step_locals = List.filter (fun vdecl -> VSet.mem vdecl assigned) machine.mstep.step_locals;
416
	  step_instrs = instrs
417
      }
418
  }
419

    
420
let machines_cse machines =
421
  List.map
422
    (machine_cse IMap.empty)
423
    machines
424

    
425
(* variable substitution for optimizing purposes *)
426

    
427
(* checks whether an [instr] is skip and can be removed from program *)
428
let rec instr_is_skip instr =
429
  match get_instr_desc instr with
430
  | MLocalAssign (i, { value_desc = (LocalVar v) ; _}) when i = v -> true
431
  | MStateAssign (i, { value_desc = StateVar v; _}) when i = v -> true
432
  | MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl
433
  | _               -> false
434
and instrs_are_skip instrs =
435
  List.for_all instr_is_skip instrs
436

    
437
let instr_cons instr cont =
438
 if instr_is_skip instr then cont else instr::cont
439

    
440
let rec instr_remove_skip instr cont =
441
  match get_instr_desc instr with
442
  | MLocalAssign (i, { value_desc = LocalVar v; _ }) when i = v -> cont
443
  | MStateAssign (i, { value_desc = StateVar v; _ }) when i = v -> cont
444
  | MBranch (g, hl) -> update_instr_desc instr (MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl)) :: cont
445
  | _               -> instr::cont
446

    
447
and instrs_remove_skip instrs cont =
448
  List.fold_right instr_remove_skip instrs cont
449

    
450
let rec value_replace_var fvar value =
451
  match value.value_desc with
452
  | Cst c -> value
453
  | LocalVar v -> { value with value_desc = LocalVar (fvar v) }
454
  | StateVar v -> value
455
  | Fun (id, args) -> { value with value_desc = Fun (id, List.map (value_replace_var fvar) args) }
456
  | Array vl -> { value with value_desc = Array (List.map (value_replace_var fvar) vl)}
457
  | Access (t, i) -> { value with value_desc = Access(value_replace_var fvar t, i)}
458
  | Power (v, n) -> { value with value_desc = Power(value_replace_var fvar v, n)}
459

    
460
let rec instr_replace_var fvar instr cont =
461
  match get_instr_desc instr with
462
  | MComment _          -> instr_cons instr cont
463
  | MLocalAssign (i, v) -> instr_cons (update_instr_desc instr (MLocalAssign (fvar i, value_replace_var fvar v))) cont
464
  | MStateAssign (i, v) -> instr_cons (update_instr_desc instr (MStateAssign (i, value_replace_var fvar v))) cont
465
  | MReset i            -> instr_cons instr cont
466
  | MNoReset i          -> instr_cons instr cont
467
  | MStep (il, i, vl)   -> instr_cons (update_instr_desc instr (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl))) cont
468
  | MBranch (g, hl)     -> instr_cons (update_instr_desc instr (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl))) cont
469

    
470
and instrs_replace_var fvar instrs cont =
471
  List.fold_right (instr_replace_var fvar) instrs cont
472

    
473
let step_replace_var fvar step =
474
  (* Some outputs may have been replaced by locals.
475
     We then need to rename those outputs
476
     without changing their clocks, etc *)
477
  let outputs' =
478
    List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs in
479
  let locals'  =
480
    List.fold_left (fun res l ->
481
      let l' = fvar l in
482
      if List.exists (fun o -> o.var_id = l'.var_id) outputs'
483
      then res
484
      else Utils.add_cons l' res)
485
      [] step.step_locals in
486
  { step with
487
    step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks;
488
    step_outputs = outputs';
489
    step_locals = locals';
490
    step_instrs = instrs_replace_var fvar step.step_instrs [];
491
}
492

    
493
let rec machine_replace_variables fvar m =
494
  { m with
495
    mstep = step_replace_var fvar m.mstep
496
  }
497

    
498
let machine_reuse_variables m reuse =
499
  let fvar v =
500
    try
501
      Hashtbl.find reuse v.var_id
502
    with Not_found -> v in
503
  machine_replace_variables fvar m
504

    
505
let machines_reuse_variables prog reuse_tables =
506
  List.map 
507
    (fun m -> 
508
      machine_reuse_variables m (Utils.IMap.find m.mname.node_id reuse_tables)
509
    ) prog
510

    
511
let rec instr_assign res instr =
512
  match get_instr_desc instr with
513
  | MLocalAssign (i, _) -> Disjunction.CISet.add i res
514
  | MStateAssign (i, _) -> Disjunction.CISet.add i res
515
  | MBranch (g, hl)     -> List.fold_left (fun res (h, b) -> instrs_assign res b) res hl
516
  | MStep (il, _, _)    -> List.fold_right Disjunction.CISet.add il res
517
  | _                   -> res
518

    
519
and instrs_assign res instrs =
520
  List.fold_left instr_assign res instrs
521

    
522
let rec instr_constant_assign var instr =
523
  match get_instr_desc instr with
524
  | MLocalAssign (i, { value_desc = Cst (Const_tag _); _ })
525
  | MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) -> i = var
526
  | MBranch (g, hl)                     -> List.for_all (fun (h, b) -> instrs_constant_assign var b) hl
527
  | _                                   -> false
528

    
529
and instrs_constant_assign var instrs =
530
  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
531

    
532
let rec instr_reduce branches instr1 cont =
533
  match get_instr_desc instr1 with
534
  | MLocalAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont)
535
  | MStateAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont)
536
  | MBranch (g, hl)                     -> (update_instr_desc instr1 (MBranch (g, List.map (fun (h, b) -> (h, instrs_reduce branches b [])) hl))) :: cont
537
  | _                                   -> instr1 :: cont
538

    
539
and instrs_reduce branches instrs cont =
540
 match instrs with
541
 | []        -> cont
542
 | [i]       -> instr_reduce branches i cont
543
 | i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont
544

    
545
let rec instrs_fusion instrs =
546
  match instrs, List.map get_instr_desc instrs with
547
  | [], []
548
  | [_], [_]                                                               ->
549
    instrs
550
  | i1::i2::q, i1_desc::(MBranch ({ value_desc = LocalVar v; _}, hl))::q_desc when instr_constant_assign v i1 ->
551
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q)
552
  | i1::i2::q, i1_desc::(MBranch ({ value_desc = StateVar v; _}, hl))::q_desc when instr_constant_assign v i1 ->
553
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q) 
554
  | i1::i2::q, _                                                         ->
555
    i1 :: instrs_fusion (i2::q)
556
  | _ -> assert false (* Other cases should not happen since both lists are of same size *)
557
     
558
let step_fusion step =
559
  { step with
560
    step_instrs = instrs_fusion step.step_instrs;
561
  }
562

    
563
let rec machine_fusion m =
564
  { m with
565
    mstep = step_fusion m.mstep
566
  }
567

    
568
let machines_fusion prog =
569
  List.map machine_fusion prog
570

    
571

    
572
(*** Main function ***)
573
    
574
let optimize prog node_schs machine_code =
575
  let machine_code =
576
    if !Options.optimization >= 4 (* && !Options.output <> "horn" *) then
577
      begin
578
	Log.report ~level:1 
579
	  (fun fmt -> Format.fprintf fmt ".. machines optimization: sub-expression elimination@,");
580
	let machine_code = machines_cse machine_code in
581
	Log.report ~level:3 (fun fmt -> Format.fprintf fmt ".. generated machines (sub-expr elim):@ %a@ "pp_machines machine_code);
582
	machine_code
583
      end
584
    else
585
      machine_code
586
  in
587
  (* Optimize machine code *)
588
  let machine_code, removed_table = 
589
    if !Options.optimization >= 2 && !Options.output <> "emf" (*&& !Options.output <> "horn"*) then
590
      begin
591
	Log.report ~level:1 (fun fmt -> Format.fprintf fmt 
592
	  ".. machines optimization: const. inlining (partial eval. with const)@,");
593
	let machine_code, removed_table = machines_unfold (Corelang.get_consts prog) node_schs machine_code in
594
	Log.report ~level:3 (fun fmt -> Format.fprintf fmt "\t@[Eliminated constants: @[%a@]@]@ "
595
	  (pp_imap pp_elim) removed_table);
596
	Log.report ~level:3 (fun fmt -> Format.fprintf fmt ".. generated machines (const inlining):@ %a@ "pp_machines machine_code);	
597
	machine_code, removed_table
598
      end
599
    else
600
      machine_code, IMap.empty
601
  in  
602
  (* Optimize machine code *)
603
  let machine_code =
604
    if !Options.optimization >= 3 && not (Backends.is_functional ()) then
605
      begin
606
	Log.report ~level:1 (fun fmt -> Format.fprintf fmt ".. machines optimization: minimize stack usage by reusing variables@,");
607
	let node_schs    = Scheduling.remove_prog_inlined_locals removed_table node_schs in
608
	let reuse_tables = Scheduling.compute_prog_reuse_table node_schs in
609
	machines_fusion (machines_reuse_variables machine_code reuse_tables)
610
      end
611
    else
612
      machine_code
613
  in
614
  
615

    
616
    machine_code  
617
    
618
    
619
(* Local Variables: *)
620
(* compile-command:"make -C .." *)
621
(* End: *)
(53-53/77)