Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / optimize_machine.ml @ 79614a15

History | View | Annotate | Download (16.8 KB)

1 b38ffff3 ploc
(********************************************************************)
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 307aba8d xthirioux
open Utils
13 3ab9437b ploc
open LustreSpec 
14
open Corelang
15 6aeb3388 xthirioux
open Causality
16 3ab9437b ploc
open Machine_code 
17 01d48bb0 xthirioux
open Dimension
18 3ab9437b ploc
19 79614a15 xthirioux
(* Some optimizations may yield denormalized values. Similar to normalize_expr *)
20
(*
21
let normalize_value v =
22
  let rec norm_cst offset cst =
23
    match cst, offset with
24
    | Const_int   _   , _
25
    | Const_real  _   , _ 
26
    | Const_float _   , _          -> cst
27
    | Const_array args, Index i::q -> if Dimension.is_dimension_const 
28
    | Const_tag of label
29
    | Const_string of string (* used only for annotations *)
30
    | Const_struct of (label * constant) list
31
  let rec norm_value offset v =
32
    match v with
33
    | Cst _ 
34
    | LocalVar _
35
    | StateVar _ -> v
36
    | Fun (id, args) -> Fun (id, List.map normalize_value args)
37
    | Array args -> Array List.map normalize_value args
38
    | Access of value_t * value_t
39
    | Power of value_t * value_t
40
  in norm [] v
41
*)
42 307aba8d xthirioux
let pp_elim fmt elim =
43
  begin
44
    Format.fprintf fmt "{ /* elim table: */@.";
45
    IMap.iter (fun v expr -> Format.fprintf fmt "%s |-> %a@." v pp_val expr) elim;
46
    Format.fprintf fmt "}@.";
47
  end
48
49 3ab9437b ploc
let rec eliminate elim instr =
50
  let e_expr = eliminate_expr elim in
51
  match instr with  
52
  | MLocalAssign (i,v) -> MLocalAssign (i, e_expr v)
53
  | MStateAssign (i,v) -> MStateAssign (i, e_expr v)
54
  | MReset i           -> instr
55
  | MStep (il, i, vl)  -> MStep(il, i, List.map e_expr vl)
56
  | MBranch (g,hl)     -> 
57
    MBranch
58
      (e_expr g, 
59
       (List.map 
60
	  (fun (l, il) -> l, List.map (eliminate elim) il) 
61
	  hl
62
       )
63
      )
64
    
65
and eliminate_expr elim expr =
66
  match expr with
67 b3b0dd56 xthirioux
  | StateVar v
68 307aba8d xthirioux
  | LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr)
69 3ab9437b ploc
  | Fun (id, vl) -> Fun (id, List.map (eliminate_expr elim) vl)
70
  | Array(vl) -> Array(List.map (eliminate_expr elim) vl)
71
  | Access(v1, v2) -> Access(eliminate_expr elim v1, eliminate_expr elim v2)
72 307aba8d xthirioux
  | Power(v1, v2) -> Power(eliminate_expr elim v1, eliminate_expr elim v2)
73 b3b0dd56 xthirioux
  | Cst _ -> expr
74 3ab9437b ploc
75 01d48bb0 xthirioux
let eliminate_dim elim dim =
76
  Dimension.expr_replace_expr (fun v -> try dimension_of_value (IMap.find v elim) with Not_found -> mkdim_ident dim.dim_loc v) dim
77
78 307aba8d xthirioux
let is_scalar_const c =
79
  match c with
80
  | Const_int _
81
  | Const_real _
82
  | Const_float _
83
  | Const_tag _   -> true
84
  | _             -> false
85
86 b3b0dd56 xthirioux
let basic_unfoldable_expr expr =
87
  match expr with
88
  | Cst c when is_scalar_const c -> true
89
  | LocalVar _
90
  | StateVar _                   -> true
91
  | _                            -> false
92
93 307aba8d xthirioux
let unfoldable_assign fanin v expr =
94
  try
95
    let d = Hashtbl.find fanin v.var_id
96 b3b0dd56 xthirioux
    in basic_unfoldable_expr expr ||
97
    match expr with
98
    | Cst c when d < 2                                           -> true
99 307aba8d xthirioux
    | Fun (id, _) when d < 2 && Basic_library.is_internal_fun id -> true
100
    | _                                                          -> false
101
  with Not_found -> false
102
103
let merge_elim elim1 elim2 =
104
  let merge k e1 e2 =
105
    match e1, e2 with
106
    | Some e1, Some e2 -> if e1 = e2 then Some e1 else None
107
    | _      , Some e2 -> Some e2
108
    | Some e1, _       -> Some e1
109
    | _                -> None
110
  in IMap.merge merge elim1 elim2
111
112 3ab9437b ploc
(* see if elim has to take in account the provided instr:
113 6a1a01d2 xthirioux
   if so, update elim and return the remove flag,
114 3ab9437b ploc
   otherwise, the expression should be kept and elim is left untouched *)
115 307aba8d xthirioux
let rec instrs_unfold fanin elim instrs =
116
  let elim, rev_instrs = 
117
    List.fold_left (fun (elim, instrs) instr ->
118
      (* each subexpression in instr that could be rewritten by the elim set is
119
	 rewritten *)
120
      let instr = eliminate elim instr in
121
      (* if instr is a simple local assign, then (a) elim is simplified with it (b) it
122
	 is stored as the elim set *)
123
      instr_unfold fanin instrs elim instr
124
    ) (elim, []) instrs
125
  in elim, List.rev rev_instrs
126
127
and instr_unfold fanin instrs elim instr =
128 7a6b5deb ploc
(*  Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*)
129 3ab9437b ploc
  match instr with
130
  (* Simple cases*)
131 307aba8d xthirioux
  | MStep([v], id, vl) when Basic_library.is_internal_fun id
132
    -> instr_unfold fanin instrs elim (MLocalAssign (v, Fun (id, vl)))
133
  | MLocalAssign(v, expr) when unfoldable_assign fanin v expr
134
    -> (IMap.add v.var_id expr elim, instrs)
135
  | MBranch(g, hl) when false
136
    -> let elim_branches = List.map (fun (h, l) -> (h, instrs_unfold fanin elim l)) hl in
137
       let (elim, branches) =
138
	 List.fold_right
139
	   (fun (h, (e, l)) (elim, branches) -> (merge_elim elim e, (h, l)::branches))
140
	   elim_branches (elim, [])
141
       in elim, (MBranch (g, branches) :: instrs)
142
  | _
143
    -> (elim, instr :: instrs)
144 3ab9437b ploc
    (* default case, we keep the instruction and do not modify elim *)
145
  
146
147
(** We iterate in the order, recording simple local assigns in an accumulator
148
    1. each expression is rewritten according to the accumulator
149
    2. local assigns then rewrite occurrences of the lhs in the computed accumulator
150
*)
151
152 01d48bb0 xthirioux
let static_call_unfold elim (inst, (n, args)) =
153
  let replace v =
154
    try
155
      Machine_code.dimension_of_value (IMap.find v elim)
156
    with Not_found -> Dimension.mkdim_ident Location.dummy_loc v
157
  in (inst, (n, List.map (Dimension.expr_replace_expr replace) args))
158
159 3ab9437b ploc
(** Perform optimization on machine code:
160
    - iterate through step instructions and remove simple local assigns
161
    
162
*)
163 307aba8d xthirioux
let machine_unfold fanin elim machine =
164
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*)
165 01d48bb0 xthirioux
  let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in
166
  let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in
167
  let locals = List.filter (fun v -> not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in
168
  let minstances = List.map (static_call_unfold elim_consts) machine.minstances in
169
  let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls
170 3ab9437b ploc
  in
171
  {
172
    machine with
173
      mstep = { 
174
	machine.mstep with 
175 01d48bb0 xthirioux
	  step_locals = locals;
176
	  step_instrs = instrs
177
      };
178
      mconst = mconst;
179
      minstances = minstances;
180
      mcalls = mcalls;
181 3ab9437b ploc
  }
182
183 307aba8d xthirioux
let instr_of_const top_const =
184
  let const = const_of_top top_const in
185 01d48bb0 xthirioux
  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
186 307aba8d xthirioux
  let vdecl = { vdecl with var_type = const.const_type }
187
  in MLocalAssign (vdecl, Cst const.const_value)
188 3ab9437b ploc
189 307aba8d xthirioux
let machines_unfold consts node_schs machines =
190
  List.map
191
    (fun m ->
192
      let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in
193
      let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts)
194
      in machine_unfold fanin elim_consts m)
195
    machines
196 3ab9437b ploc
197 b3b0dd56 xthirioux
let get_assign_lhs instr =
198
  match instr with
199
  | MLocalAssign(v, _) -> LocalVar v
200
  | MStateAssign(v, _) -> StateVar v
201
  | _                  -> assert false
202
203
let get_assign_rhs instr =
204
  match instr with
205
  | MLocalAssign(_, e)
206
  | MStateAssign(_, e) -> e
207
  | _                  -> assert false
208
209
let is_assign instr =
210
  match instr with
211
  | MLocalAssign _
212
  | MStateAssign _ -> true
213
  | _              -> false
214
215
let mk_assign v e =
216
 match v with
217
 | LocalVar v -> MLocalAssign(v, e)
218
 | StateVar v -> MStateAssign(v, e)
219
 | _          -> assert false
220
221
let rec assigns_instr instr assign =
222
  match instr with  
223
  | MLocalAssign (i,_)
224
  | MStateAssign (i,_) -> ISet.add i assign
225
  | MStep (ol, _, _)   -> List.fold_right ISet.add ol assign
226
  | MBranch (_,hl)     -> List.fold_right (fun (_, il) -> assigns_instrs il) hl assign
227
  | _                  -> assign
228
229
and assigns_instrs instrs assign =
230
  List.fold_left (fun assign instr -> assigns_instr instr assign) assign instrs
231
232
(*    
233
and substitute_expr subst expr =
234
  match expr with
235
  | StateVar v
236
  | LocalVar v -> (try IMap.find expr subst with Not_found -> expr)
237
  | Fun (id, vl) -> Fun (id, List.map (substitute_expr subst) vl)
238
  | Array(vl) -> Array(List.map (substitute_expr subst) vl)
239
  | Access(v1, v2) -> Access(substitute_expr subst v1, substitute_expr subst v2)
240
  | Power(v1, v2) -> Power(substitute_expr subst v1, substitute_expr subst v2)
241
  | Cst _  -> expr
242
*)
243
(** Finds a substitute for [instr] in [instrs], 
244
   i.e. another instr' with the same rhs expression.
245
   Then substitute this expression with the first assigned var
246
*)
247
let subst_instr subst instrs instr =
248
  (*Format.eprintf "subst instr: %a@." Machine_code.pp_instr instr;*)
249
  let instr = eliminate subst instr in
250
  let v = get_assign_lhs instr in
251
  let e = get_assign_rhs instr in
252
  try
253
    let instr' = List.find (fun instr' -> is_assign instr' && get_assign_rhs instr' = e) instrs in
254
    match v with
255
    | LocalVar v ->
256
      IMap.add v.var_id (get_assign_lhs instr') subst, instrs
257
    | StateVar v ->
258
      (match get_assign_lhs instr' with
259
      | LocalVar v' ->
260
	let instr = eliminate subst (mk_assign (StateVar v) (LocalVar v')) in
261
	subst, instr :: instrs
262
      | StateVar v' ->
263
	let subst_v' = IMap.add v'.var_id (StateVar v) IMap.empty in
264
	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
265
	IMap.add v'.var_id (StateVar v) subst, instr :: instrs'
266
      | _           -> assert false)
267
    | _          -> assert false
268
  with Not_found -> subst, instr :: instrs
269
 
270
(** Common sub-expression elimination for machine instructions *)
271
(* - [subst] : hashtable from ident to (simple) definition
272
               it is an equivalence table
273
   - [elim]   : set of eliminated variables
274
   - [instrs] : previous instructions, which [instr] is compared against
275
   - [instr] : current instruction, normalized by [subst]
276
*)
277
let rec instr_cse (subst, instrs) instr =
278
  match instr with
279
  (* Simple cases*)
280
  | MStep([v], id, vl) when Basic_library.is_internal_fun id
281
      -> instr_cse (subst, instrs) (MLocalAssign (v, Fun (id, vl)))
282
  | MLocalAssign(v, expr) when basic_unfoldable_expr expr
283
      -> (IMap.add v.var_id expr subst, instr :: instrs)
284
  | _ when is_assign instr
285
      -> subst_instr subst instrs instr
286
  | _ -> (subst, instr :: instrs)
287
288
(** Apply common sub-expression elimination to a sequence of instrs
289
*)
290
let rec instrs_cse subst instrs =
291
  let subst, rev_instrs = 
292
    List.fold_left instr_cse (subst, []) instrs
293
  in subst, List.rev rev_instrs
294
295
(** Apply common sub-expression elimination to a machine
296
    - iterate through step instructions and remove simple local assigns
297
*)
298
let machine_cse subst machine =
299
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_cse %a@." pp_elim subst);*)
300
  let subst, instrs = instrs_cse subst machine.mstep.step_instrs in
301
  let assigned = assigns_instrs instrs ISet.empty
302
  in
303
  {
304
    machine with
305
      mmemory = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mmemory;
306
      mstep = { 
307
	machine.mstep with 
308
	  step_locals = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mstep.step_locals;
309
	  step_instrs = instrs
310
      }
311
  }
312
313
let machines_cse machines =
314
  List.map
315
    (machine_cse IMap.empty)
316
    machines
317
318 01f1a1f4 xthirioux
(* variable substitution for optimizing purposes *)
319
320
(* checks whether an [instr] is skip and can be removed from program *)
321
let rec instr_is_skip instr =
322
  match instr with
323
  | MLocalAssign (i, LocalVar v) when i = v -> true
324
  | MStateAssign (i, StateVar v) when i = v -> true
325
  | MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl
326
  | _               -> false
327
and instrs_are_skip instrs =
328
  List.for_all instr_is_skip instrs
329
330
let instr_cons instr cont =
331
 if instr_is_skip instr then cont else instr::cont
332
333
let rec instr_remove_skip instr cont =
334
  match instr with
335
  | MLocalAssign (i, LocalVar v) when i = v -> cont
336
  | MStateAssign (i, StateVar v) when i = v -> cont
337
  | MBranch (g, hl) -> MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl) :: cont
338
  | _               -> instr::cont
339
340
and instrs_remove_skip instrs cont =
341
  List.fold_right instr_remove_skip instrs cont
342
343
let rec value_replace_var fvar value =
344
  match value with
345
  | Cst c -> value
346
  | LocalVar v -> LocalVar (fvar v)
347
  | StateVar v -> value
348
  | Fun (id, args) -> Fun (id, List.map (value_replace_var fvar) args) 
349
  | Array vl -> Array (List.map (value_replace_var fvar) vl)
350
  | Access (t, i) -> Access(value_replace_var fvar t, i)
351
  | Power (v, n) -> Power(value_replace_var fvar v, n)
352
353
let rec instr_replace_var fvar instr cont =
354
  match instr with
355
  | MLocalAssign (i, v) -> instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont
356
  | MStateAssign (i, v) -> instr_cons (MStateAssign (i, value_replace_var fvar v)) cont
357
  | MReset i            -> instr_cons instr cont
358
  | MStep (il, i, vl)   -> instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont
359
  | MBranch (g, hl)     -> instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl)) cont
360
361
and instrs_replace_var fvar instrs cont =
362
  List.fold_right (instr_replace_var fvar) instrs cont
363
364
let step_replace_var fvar step =
365
  (* Some outputs may have been replaced by locals.
366
     We then need to rename those outputs
367
     without changing their clocks, etc *)
368
  let outputs' =
369
    List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs in
370
  let locals'  =
371
    List.fold_left (fun res l ->
372
      let l' = fvar l in
373
      if List.exists (fun o -> o.var_id = l'.var_id) outputs'
374
      then res
375
      else Utils.add_cons l' res)
376
      [] step.step_locals in
377
  { step with
378
    step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks;
379
    step_outputs = outputs';
380
    step_locals = locals';
381
    step_instrs = instrs_replace_var fvar step.step_instrs [];
382
}
383
384
let rec machine_replace_variables fvar m =
385
  { m with
386
    mstep = step_replace_var fvar m.mstep
387
  }
388
389
let machine_reuse_variables m reuse =
390
  let fvar v =
391
    try
392
      Hashtbl.find reuse v.var_id
393
    with Not_found -> v in
394
  machine_replace_variables fvar m
395
396
let machines_reuse_variables prog node_schs =
397
  List.map 
398
    (fun m -> 
399
      machine_reuse_variables m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table
400
    ) prog
401
402 6aeb3388 xthirioux
let rec instr_assign res instr =
403
  match instr with
404
  | MLocalAssign (i, _) -> Disjunction.CISet.add i res
405
  | MStateAssign (i, _) -> Disjunction.CISet.add i res
406
  | MBranch (g, hl)     -> List.fold_left (fun res (h, b) -> instrs_assign res b) res hl
407
  | MStep (il, _, _)    -> List.fold_right Disjunction.CISet.add il res
408
  | _                   -> res
409
410
and instrs_assign res instrs =
411
  List.fold_left instr_assign res instrs
412
413
let rec instr_constant_assign var instr =
414
  match instr with
415
  | MLocalAssign (i, Cst (Const_tag _))
416
  | MStateAssign (i, Cst (Const_tag _)) -> i = var
417
  | MBranch (g, hl)                     -> List.for_all (fun (h, b) -> instrs_constant_assign var b) hl
418
  | _                                   -> false
419
420
and instrs_constant_assign var instrs =
421
  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
422
423
let rec instr_reduce branches instr1 cont =
424
  match instr1 with
425
  | MLocalAssign (_, Cst (Const_tag c)) -> instr1 :: (List.assoc c branches @ cont)
426
  | MStateAssign (_, Cst (Const_tag c)) -> instr1 :: (List.assoc c branches @ cont)
427
  | MBranch (g, hl)                     -> MBranch (g, List.map (fun (h, b) -> (h, instrs_reduce branches b [])) hl) :: cont
428
  | _                                   -> instr1 :: cont
429
430
and instrs_reduce branches instrs cont =
431
 match instrs with
432
 | []        -> cont
433
 | [i]       -> instr_reduce branches i cont
434
 | i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont
435
436
let rec instrs_fusion instrs =
437
  match instrs with
438
  | []
439
  | [_]                                                               ->
440
    instrs
441
  | i1::(MBranch (LocalVar v, hl))::q when instr_constant_assign v i1 ->
442
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q)
443
  | i1::(MBranch (StateVar v, hl))::q when instr_constant_assign v i1 ->
444
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q) 
445
  | i1::i2::q                                                         ->
446
    i1 :: instrs_fusion (i2::q)
447
448
let step_fusion step =
449
  { step with
450
    step_instrs = instrs_fusion step.step_instrs;
451
  }
452
453
let rec machine_fusion m =
454
  { m with
455
    mstep = step_fusion m.mstep
456
  }
457
458
let machines_fusion prog =
459
  List.map machine_fusion prog
460 3ab9437b ploc
461
(* Local Variables: *)
462
(* compile-command:"make -C .." *)
463
(* End: *)