Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / optimize_machine.ml @ 55537f48

History | View | Annotate | Download (16 KB)

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