Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / optimize_machine.ml @ 79614a15

History | View | Annotate | Download (16.8 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
(* 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
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
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
  | StateVar v
68
  | LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr)
69
  | 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
  | Power(v1, v2) -> Power(eliminate_expr elim v1, eliminate_expr elim v2)
73
  | Cst _ -> expr
74

    
75
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
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
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
let unfoldable_assign fanin v expr =
94
  try
95
    let d = Hashtbl.find fanin v.var_id
96
    in basic_unfoldable_expr expr ||
97
    match expr with
98
    | Cst c when d < 2                                           -> true
99
    | 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
(* see if elim has to take in account the provided instr:
113
   if so, update elim and return the remove flag,
114
   otherwise, the expression should be kept and elim is left untouched *)
115
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
(*  Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*)
129
  match instr with
130
  (* Simple cases*)
131
  | 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
    (* 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
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
(** Perform optimization on machine code:
160
    - iterate through step instructions and remove simple local assigns
161
    
162
*)
163
let machine_unfold fanin elim machine =
164
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*)
165
  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
  in
171
  {
172
    machine with
173
      mstep = { 
174
	machine.mstep with 
175
	  step_locals = locals;
176
	  step_instrs = instrs
177
      };
178
      mconst = mconst;
179
      minstances = minstances;
180
      mcalls = mcalls;
181
  }
182

    
183
let instr_of_const top_const =
184
  let const = const_of_top top_const in
185
  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
  let vdecl = { vdecl with var_type = const.const_type }
187
  in MLocalAssign (vdecl, Cst const.const_value)
188

    
189
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

    
197
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
(* 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
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

    
461
(* Local Variables: *)
462
(* compile-command:"make -C .." *)
463
(* End: *)