Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / optimize_machine.ml @ da07e470

History | View | Annotate | Download (16 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
  | 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
  | StateVar v
46
  | LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr)
47
  | 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
  | Power(v1, v2) -> Power(eliminate_expr elim v1, eliminate_expr elim v2)
51
  | Cst _ -> expr
52

    
53
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
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
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
let unfoldable_assign fanin v expr =
72
  try
73
    let d = Hashtbl.find fanin v.var_id
74
    in basic_unfoldable_expr expr ||
75
    match expr with
76
    | Cst c when d < 2                                           -> true
77
    | 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
(* see if elim has to take in account the provided instr:
91
   if so, update elim and return the remove flag,
92
   otherwise, the expression should be kept and elim is left untouched *)
93
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
(*  Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*)
107
  match instr with
108
  (* Simple cases*)
109
  | 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
    (* 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
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
(** Perform optimization on machine code:
138
    - iterate through step instructions and remove simple local assigns
139
    
140
*)
141
let machine_unfold fanin elim machine =
142
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*)
143
  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
  in
149
  {
150
    machine with
151
      mstep = { 
152
	machine.mstep with 
153
	  step_locals = locals;
154
	  step_instrs = instrs
155
      };
156
      mconst = mconst;
157
      minstances = minstances;
158
      mcalls = mcalls;
159
  }
160

    
161
let instr_of_const top_const =
162
  let const = const_of_top top_const in
163
  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
  let vdecl = { vdecl with var_type = const.const_type }
165
  in MLocalAssign (vdecl, Cst const.const_value)
166

    
167
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

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

    
439
(* Local Variables: *)
440
(* compile-command:"make -C .." *)
441
(* End: *)