Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / optimize_machine.ml @ 53206908

History | View | Annotate | Download (17.3 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
  | 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.value_desc with
46
  | LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr)
47
  | Fun (id, vl) -> {expr with value_desc = Fun (id, List.map (eliminate_expr elim) vl)}
48
  | Array(vl) -> {expr with value_desc = Array(List.map (eliminate_expr elim) vl)}
49
  | Access(v1, v2) -> { expr with value_desc = Access(eliminate_expr elim v1, eliminate_expr elim v2)}
50
  | Power(v1, v2) -> { expr with value_desc = Power(eliminate_expr elim v1, eliminate_expr elim v2)}
51
  | Cst _ | StateVar _ -> expr
52

    
53
let is_scalar_const c =
54
  match c with
55
  | Const_real _
56
  | Const_int _
57
  | Const_tag _   -> true
58
  | _             -> false
59

    
60
let basic_unfoldable_expr expr =
61
  match expr.value_desc with
62
  | Cst c when is_scalar_const c -> true
63
  | LocalVar _
64
  | StateVar _                   -> true
65
  | _                            -> false
66

    
67
let rec basic_unfoldable_assign fanin v expr =
68
  try
69
    let d = Hashtbl.find fanin v.var_id
70
    in match expr.value_desc with
71
    | Cst c when is_scalar_const c -> true
72
    | Cst c when d < 2             -> true
73
    | LocalVar _
74
    | StateVar _                   -> true
75
    | Fun (id, [a]) when d < 2 && Basic_library.is_value_internal_fun expr -> basic_unfoldable_assign fanin v a
76
    | _                                                          -> false
77
  with Not_found -> false
78

    
79
let unfoldable_assign fanin v expr =
80
   (if !Options.mpfr then Mpfr.unfoldable_value expr else true)
81
&& basic_unfoldable_assign fanin v expr
82

    
83
let merge_elim elim1 elim2 =
84
  let merge k e1 e2 =
85
    match e1, e2 with
86
    | Some e1, Some e2 -> if e1 = e2 then Some e1 else None
87
    | _      , Some e2 -> Some e2
88
    | Some e1, _       -> Some e1
89
    | _                -> None
90
  in IMap.merge merge elim1 elim2
91

    
92
(* see if elim has to take in account the provided instr:
93
   if so, update elim and return the remove flag,
94
   otherwise, the expression should be kept and elim is left untouched *)
95
let rec instrs_unfold fanin elim instrs =
96
  let elim, rev_instrs = 
97
    List.fold_left (fun (elim, instrs) instr ->
98
      (* each subexpression in instr that could be rewritten by the elim set is
99
	 rewritten *)
100
      let instr = eliminate elim instr in
101
      (* if instr is a simple local assign, then (a) elim is simplified with it (b) it
102
	 is stored as the elim set *)
103
      instr_unfold fanin instrs elim instr
104
    ) (elim, []) instrs
105
  in elim, List.rev rev_instrs
106

    
107
and instr_unfold fanin instrs elim instr =
108
(*  Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*)
109
  match instr with
110
  (* Simple cases*)
111
  | MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type)
112
    -> instr_unfold fanin instrs elim (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type))
113
  | MLocalAssign(v, expr) when unfoldable_assign fanin v expr
114
    -> (IMap.add v.var_id expr elim, instrs)
115
  | MBranch(g, hl) when false
116
    -> let elim_branches = List.map (fun (h, l) -> (h, instrs_unfold fanin elim l)) hl in
117
       let (elim, branches) =
118
	 List.fold_right
119
	   (fun (h, (e, l)) (elim, branches) -> (merge_elim elim e, (h, l)::branches))
120
	   elim_branches (elim, [])
121
       in elim, (MBranch (g, branches) :: instrs)
122
  | _
123
    -> (elim, instr :: instrs)
124
    (* default case, we keep the instruction and do not modify elim *)
125
  
126

    
127
(** We iterate in the order, recording simple local assigns in an accumulator
128
    1. each expression is rewritten according to the accumulator
129
    2. local assigns then rewrite occurrences of the lhs in the computed accumulator
130
*)
131

    
132
let static_call_unfold elim (inst, (n, args)) =
133
  let replace v =
134
    try
135
      Machine_code.dimension_of_value (IMap.find v elim)
136
    with Not_found -> Dimension.mkdim_ident Location.dummy_loc v
137
  in (inst, (n, List.map (Dimension.expr_replace_expr replace) args))
138

    
139
(** Perform optimization on machine code:
140
    - iterate through step instructions and remove simple local assigns
141
    
142
*)
143
let machine_unfold fanin elim machine =
144
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*)
145
  let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in
146
  let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in
147
  (*let instrs = simplify_instrs_offset machine instrs in*)
148
  let checks = List.map (fun (loc, check) -> loc, eliminate_expr elim_vars check) machine.mstep.step_checks in
149
  let locals = List.filter (fun v -> not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in
150
  let minstances = List.map (static_call_unfold elim_consts) machine.minstances in
151
  let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls
152
  in
153
  {
154
    machine with
155
      mstep = { 
156
	machine.mstep with 
157
	  step_locals = locals;
158
	  step_instrs = instrs;
159
	  step_checks = checks
160
      };
161
      mconst = mconst;
162
      minstances = minstances;
163
      mcalls = mcalls;
164
  },
165
  elim_vars
166

    
167
let instr_of_const top_const =
168
  let const = const_of_top top_const in
169
  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
170
  let vdecl = { vdecl with var_type = const.const_type }
171
  in MLocalAssign (vdecl, mk_val (Cst const.const_value) vdecl.var_type)
172

    
173
let machines_unfold consts node_schs machines =
174
  List.fold_right (fun m (machines, removed) ->
175
    let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in
176
    let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts) in
177
    let (m, removed_m) =  machine_unfold fanin elim_consts m in
178
    (m::machines, IMap.add m.mname.node_id removed_m removed)
179
    )
180
    machines
181
    ([], IMap.empty)
182

    
183
let get_assign_lhs instr =
184
  match instr with
185
  | MLocalAssign(v, e) -> mk_val (LocalVar v) e.value_type
186
  | MStateAssign(v, e) -> mk_val (StateVar v) e.value_type
187
  | _                  -> assert false
188

    
189
let get_assign_rhs instr =
190
  match instr with
191
  | MLocalAssign(_, e)
192
  | MStateAssign(_, e) -> e
193
  | _                  -> assert false
194

    
195
let is_assign instr =
196
  match instr with
197
  | MLocalAssign _
198
  | MStateAssign _ -> true
199
  | _              -> false
200

    
201
let mk_assign v e =
202
 match v.value_desc with
203
 | LocalVar v -> MLocalAssign(v, e)
204
 | StateVar v -> MStateAssign(v, e)
205
 | _          -> assert false
206

    
207
let rec assigns_instr instr assign =
208
  match instr with  
209
  | MLocalAssign (i,_)
210
  | MStateAssign (i,_) -> ISet.add i assign
211
  | MStep (ol, _, _)   -> List.fold_right ISet.add ol assign
212
  | MBranch (_,hl)     -> List.fold_right (fun (_, il) -> assigns_instrs il) hl assign
213
  | _                  -> assign
214

    
215
and assigns_instrs instrs assign =
216
  List.fold_left (fun assign instr -> assigns_instr instr assign) assign instrs
217

    
218
(*    
219
and substitute_expr subst expr =
220
  match expr with
221
  | StateVar v
222
  | LocalVar v -> (try IMap.find expr subst with Not_found -> expr)
223
  | Fun (id, vl) -> Fun (id, List.map (substitute_expr subst) vl)
224
  | Array(vl) -> Array(List.map (substitute_expr subst) vl)
225
  | Access(v1, v2) -> Access(substitute_expr subst v1, substitute_expr subst v2)
226
  | Power(v1, v2) -> Power(substitute_expr subst v1, substitute_expr subst v2)
227
  | Cst _  -> expr
228
*)
229
(** Finds a substitute for [instr] in [instrs], 
230
   i.e. another instr' with the same rhs expression.
231
   Then substitute this expression with the first assigned var
232
*)
233
let subst_instr subst instrs instr =
234
  (*Format.eprintf "subst instr: %a@." Machine_code.pp_instr instr;*)
235
  let instr = eliminate subst instr in
236
  let v = get_assign_lhs instr in
237
  let e = get_assign_rhs instr in
238
  try
239
    let instr' = List.find (fun instr' -> is_assign instr' && get_assign_rhs instr' = e) instrs in
240
    match v.value_desc with
241
    | LocalVar v ->
242
      IMap.add v.var_id (get_assign_lhs instr') subst, instrs
243
    | StateVar v ->
244
      let lhs' = get_assign_lhs instr' in
245
      let typ' = lhs'.value_type in
246
      (match lhs'.value_desc with
247
      | LocalVar v' ->
248
	let instr = eliminate subst (mk_assign (mk_val (StateVar v) typ') (mk_val (LocalVar v') typ')) in
249
	subst, instr :: instrs
250
      | StateVar v' ->
251
	let subst_v' = IMap.add v'.var_id (mk_val (StateVar v) typ') IMap.empty in
252
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
253
	IMap.add v'.var_id (mk_val (StateVar v) typ') subst, instr :: instrs'
254
      | _           -> assert false)
255
    | _          -> assert false
256
  with Not_found -> subst, instr :: instrs
257
 
258
(** Common sub-expression elimination for machine instructions *)
259
(* - [subst] : hashtable from ident to (simple) definition
260
               it is an equivalence table
261
   - [elim]   : set of eliminated variables
262
   - [instrs] : previous instructions, which [instr] is compared against
263
   - [instr] : current instruction, normalized by [subst]
264
*)
265
let rec instr_cse (subst, instrs) instr =
266
  match instr with
267
  (* Simple cases*)
268
  | MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type)
269
      -> instr_cse (subst, instrs) (MLocalAssign (v, (mk_val (Fun (id, vl)) v.var_type)))
270
  | MLocalAssign(v, expr) when basic_unfoldable_expr expr
271
      -> (IMap.add v.var_id expr subst, instr :: instrs)
272
  | _ when is_assign instr
273
      -> subst_instr subst instrs instr
274
  | _ -> (subst, instr :: instrs)
275

    
276
(** Apply common sub-expression elimination to a sequence of instrs
277
*)
278
let rec instrs_cse subst instrs =
279
  let subst, rev_instrs = 
280
    List.fold_left instr_cse (subst, []) instrs
281
  in subst, List.rev rev_instrs
282

    
283
(** Apply common sub-expression elimination to a machine
284
    - iterate through step instructions and remove simple local assigns
285
*)
286
let machine_cse subst machine =
287
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_cse %a@." pp_elim subst);*)
288
  let subst, instrs = instrs_cse subst machine.mstep.step_instrs in
289
  let assigned = assigns_instrs instrs ISet.empty
290
  in
291
  {
292
    machine with
293
      mmemory = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mmemory;
294
      mstep = { 
295
	machine.mstep with 
296
	  step_locals = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mstep.step_locals;
297
	  step_instrs = instrs
298
      }
299
  }
300

    
301
let machines_cse machines =
302
  List.map
303
    (machine_cse IMap.empty)
304
    machines
305

    
306
(* variable substitution for optimizing purposes *)
307

    
308
(* checks whether an [instr] is skip and can be removed from program *)
309
let rec instr_is_skip instr =
310
  match instr with
311
  | MLocalAssign (i, { value_desc = (LocalVar v) ; _}) when i = v -> true
312
  | MStateAssign (i, { value_desc = StateVar v; _}) when i = v -> true
313
  | MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl
314
  | _               -> false
315
and instrs_are_skip instrs =
316
  List.for_all instr_is_skip instrs
317

    
318
let instr_cons instr cont =
319
 if instr_is_skip instr then cont else instr::cont
320

    
321
let rec instr_remove_skip instr cont =
322
  match instr with
323
  | MLocalAssign (i, { value_desc = LocalVar v; _ }) when i = v -> cont
324
  | MStateAssign (i, { value_desc = StateVar v; _ }) when i = v -> cont
325
  | MBranch (g, hl) -> MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl) :: cont
326
  | _               -> instr::cont
327

    
328
and instrs_remove_skip instrs cont =
329
  List.fold_right instr_remove_skip instrs cont
330

    
331
let rec value_replace_var fvar value =
332
  match value.value_desc with
333
  | Cst c -> value
334
  | LocalVar v -> { value with value_desc = LocalVar (fvar v) }
335
  | StateVar v -> value
336
  | Fun (id, args) -> { value with value_desc = Fun (id, List.map (value_replace_var fvar) args) }
337
  | Array vl -> { value with value_desc = Array (List.map (value_replace_var fvar) vl)}
338
  | Access (t, i) -> { value with value_desc = Access(value_replace_var fvar t, i)}
339
  | Power (v, n) -> { value with value_desc = Power(value_replace_var fvar v, n)}
340

    
341
let rec instr_replace_var fvar instr cont =
342
  match instr with
343
  | MComment _          -> instr_cons instr cont
344
  | MLocalAssign (i, v) -> instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont
345
  | MStateAssign (i, v) -> instr_cons (MStateAssign (i, value_replace_var fvar v)) cont
346
  | MReset i            -> instr_cons instr cont
347
  | MStep (il, i, vl)   -> instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont
348
  | MBranch (g, hl)     -> instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl)) cont
349

    
350
and instrs_replace_var fvar instrs cont =
351
  List.fold_right (instr_replace_var fvar) instrs cont
352

    
353
let step_replace_var fvar step =
354
  (* Some outputs may have been replaced by locals.
355
     We then need to rename those outputs
356
     without changing their clocks, etc *)
357
  let outputs' =
358
    List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs in
359
  let locals'  =
360
    List.fold_left (fun res l ->
361
      let l' = fvar l in
362
      if List.exists (fun o -> o.var_id = l'.var_id) outputs'
363
      then res
364
      else Utils.add_cons l' res)
365
      [] step.step_locals in
366
  { step with
367
    step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks;
368
    step_outputs = outputs';
369
    step_locals = locals';
370
    step_instrs = instrs_replace_var fvar step.step_instrs [];
371
}
372

    
373
let rec machine_replace_variables fvar m =
374
  { m with
375
    mstep = step_replace_var fvar m.mstep
376
  }
377

    
378
let machine_reuse_variables m reuse =
379
  let fvar v =
380
    try
381
      Hashtbl.find reuse v.var_id
382
    with Not_found -> v in
383
  machine_replace_variables fvar m
384

    
385
let machines_reuse_variables prog reuse_tables =
386
  List.map 
387
    (fun m -> 
388
      machine_reuse_variables m (Utils.IMap.find m.mname.node_id reuse_tables)
389
    ) prog
390

    
391
let rec instr_assign res instr =
392
  match instr with
393
  | MLocalAssign (i, _) -> Disjunction.CISet.add i res
394
  | MStateAssign (i, _) -> Disjunction.CISet.add i res
395
  | MBranch (g, hl)     -> List.fold_left (fun res (h, b) -> instrs_assign res b) res hl
396
  | MStep (il, _, _)    -> List.fold_right Disjunction.CISet.add il res
397
  | _                   -> res
398

    
399
and instrs_assign res instrs =
400
  List.fold_left instr_assign res instrs
401

    
402
let rec instr_constant_assign var instr =
403
  match instr with
404
  | MLocalAssign (i, { value_desc = Cst (Const_tag _); _ })
405
  | MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) -> i = var
406
  | MBranch (g, hl)                     -> List.for_all (fun (h, b) -> instrs_constant_assign var b) hl
407
  | _                                   -> false
408

    
409
and instrs_constant_assign var instrs =
410
  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
411

    
412
let rec instr_reduce branches instr1 cont =
413
  match instr1 with
414
  | MLocalAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont)
415
  | MStateAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont)
416
  | MBranch (g, hl)                     -> MBranch (g, List.map (fun (h, b) -> (h, instrs_reduce branches b [])) hl) :: cont
417
  | _                                   -> instr1 :: cont
418

    
419
and instrs_reduce branches instrs cont =
420
 match instrs with
421
 | []        -> cont
422
 | [i]       -> instr_reduce branches i cont
423
 | i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont
424

    
425
let rec instrs_fusion instrs =
426
  match instrs with
427
  | []
428
  | [_]                                                               ->
429
    instrs
430
  | i1::(MBranch ({ value_desc = LocalVar v; _}, hl))::q when instr_constant_assign v i1 ->
431
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q)
432
  | i1::(MBranch ({ value_desc = StateVar v; _}, hl))::q when instr_constant_assign v i1 ->
433
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q) 
434
  | i1::i2::q                                                         ->
435
    i1 :: instrs_fusion (i2::q)
436

    
437
let step_fusion step =
438
  { step with
439
    step_instrs = instrs_fusion step.step_instrs;
440
  }
441

    
442
let rec machine_fusion m =
443
  { m with
444
    mstep = step_fusion m.mstep
445
  }
446

    
447
let machines_fusion prog =
448
  List.map machine_fusion prog
449

    
450
(* Local Variables: *)
451
(* compile-command:"make -C .." *)
452
(* End: *)