Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / optimize_machine.ml @ b3b0dd56

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
let pp_elim fmt elim =
20
  begin
21
    Format.fprintf fmt "{ /* elim table: */@.";
22
    IMap.iter (fun v expr -> Format.fprintf fmt "%s |-> %a@." v pp_val expr) elim;
23
    Format.fprintf fmt "}@.";
24
  end
25

    
26
let rec eliminate elim instr =
27
  let e_expr = eliminate_expr elim in
28
  match instr with  
29
  | MLocalAssign (i,v) -> MLocalAssign (i, e_expr v)
30
  | MStateAssign (i,v) -> MStateAssign (i, e_expr v)
31
  | MReset i           -> instr
32
  | MStep (il, i, vl)  -> MStep(il, i, List.map e_expr vl)
33
  | MBranch (g,hl)     -> 
34
    MBranch
35
      (e_expr g, 
36
       (List.map 
37
	  (fun (l, il) -> l, List.map (eliminate elim) il) 
38
	  hl
39
       )
40
      )
41
    
42
and eliminate_expr elim expr =
43
  match expr with
44
  | StateVar v
45
  | LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr)
46
  | Fun (id, vl) -> Fun (id, List.map (eliminate_expr elim) vl)
47
  | Array(vl) -> Array(List.map (eliminate_expr elim) vl)
48
  | Access(v1, v2) -> Access(eliminate_expr elim v1, eliminate_expr elim v2)
49
  | Power(v1, v2) -> Power(eliminate_expr elim v1, eliminate_expr elim v2)
50
  | Cst _ -> expr
51

    
52
let eliminate_dim elim dim =
53
  Dimension.expr_replace_expr (fun v -> try dimension_of_value (IMap.find v elim) with Not_found -> mkdim_ident dim.dim_loc v) dim
54

    
55
let is_scalar_const c =
56
  match c with
57
  | Const_int _
58
  | Const_real _
59
  | Const_float _
60
  | Const_tag _   -> true
61
  | _             -> false
62

    
63
let basic_unfoldable_expr expr =
64
  match expr with
65
  | Cst c when is_scalar_const c -> true
66
  | LocalVar _
67
  | StateVar _                   -> true
68
  | _                            -> false
69

    
70
let unfoldable_assign fanin v expr =
71
  try
72
    let d = Hashtbl.find fanin v.var_id
73
    in basic_unfoldable_expr expr ||
74
    match expr with
75
    | Cst c when d < 2                                           -> true
76
    | Fun (id, _) when d < 2 && Basic_library.is_internal_fun id -> true
77
    | _                                                          -> false
78
  with Not_found -> false
79

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

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

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

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

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

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

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

    
166
let machines_unfold consts node_schs machines =
167
  List.map
168
    (fun m ->
169
      let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in
170
      let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts)
171
      in machine_unfold fanin elim_consts m)
172
    machines
173

    
174
let get_assign_lhs instr =
175
  match instr with
176
  | MLocalAssign(v, _) -> LocalVar v
177
  | MStateAssign(v, _) -> StateVar v
178
  | _                  -> assert false
179

    
180
let get_assign_rhs instr =
181
  match instr with
182
  | MLocalAssign(_, e)
183
  | MStateAssign(_, e) -> e
184
  | _                  -> assert false
185

    
186
let is_assign instr =
187
  match instr with
188
  | MLocalAssign _
189
  | MStateAssign _ -> true
190
  | _              -> false
191

    
192
let mk_assign v e =
193
 match v with
194
 | LocalVar v -> MLocalAssign(v, e)
195
 | StateVar v -> MStateAssign(v, e)
196
 | _          -> assert false
197

    
198
let rec assigns_instr instr assign =
199
  match instr with  
200
  | MLocalAssign (i,_)
201
  | MStateAssign (i,_) -> ISet.add i assign
202
  | MStep (ol, _, _)   -> List.fold_right ISet.add ol assign
203
  | MBranch (_,hl)     -> List.fold_right (fun (_, il) -> assigns_instrs il) hl assign
204
  | _                  -> assign
205

    
206
and assigns_instrs instrs assign =
207
  List.fold_left (fun assign instr -> assigns_instr instr assign) assign instrs
208

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

    
265
(** Apply common sub-expression elimination to a sequence of instrs
266
*)
267
let rec instrs_cse subst instrs =
268
  let subst, rev_instrs = 
269
    List.fold_left instr_cse (subst, []) instrs
270
  in subst, List.rev rev_instrs
271

    
272
(** Apply common sub-expression elimination to a machine
273
    - iterate through step instructions and remove simple local assigns
274
*)
275
let machine_cse subst machine =
276
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_cse %a@." pp_elim subst);*)
277
  let subst, instrs = instrs_cse subst machine.mstep.step_instrs in
278
  let assigned = assigns_instrs instrs ISet.empty
279
  in
280
  {
281
    machine with
282
      mmemory = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mmemory;
283
      mstep = { 
284
	machine.mstep with 
285
	  step_locals = List.filter (fun vdecl -> ISet.mem vdecl assigned) machine.mstep.step_locals;
286
	  step_instrs = instrs
287
      }
288
  }
289

    
290
let machines_cse machines =
291
  List.map
292
    (machine_cse IMap.empty)
293
    machines
294

    
295
(* variable substitution for optimizing purposes *)
296

    
297
(* checks whether an [instr] is skip and can be removed from program *)
298
let rec instr_is_skip instr =
299
  match instr with
300
  | MLocalAssign (i, LocalVar v) when i = v -> true
301
  | MStateAssign (i, StateVar v) when i = v -> true
302
  | MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl
303
  | _               -> false
304
and instrs_are_skip instrs =
305
  List.for_all instr_is_skip instrs
306

    
307
let instr_cons instr cont =
308
 if instr_is_skip instr then cont else instr::cont
309

    
310
let rec instr_remove_skip instr cont =
311
  match instr with
312
  | MLocalAssign (i, LocalVar v) when i = v -> cont
313
  | MStateAssign (i, StateVar v) when i = v -> cont
314
  | MBranch (g, hl) -> MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl) :: cont
315
  | _               -> instr::cont
316

    
317
and instrs_remove_skip instrs cont =
318
  List.fold_right instr_remove_skip instrs cont
319

    
320
let rec value_replace_var fvar value =
321
  match value with
322
  | Cst c -> value
323
  | LocalVar v -> LocalVar (fvar v)
324
  | StateVar v -> value
325
  | Fun (id, args) -> Fun (id, List.map (value_replace_var fvar) args) 
326
  | Array vl -> Array (List.map (value_replace_var fvar) vl)
327
  | Access (t, i) -> Access(value_replace_var fvar t, i)
328
  | Power (v, n) -> Power(value_replace_var fvar v, n)
329

    
330
let rec instr_replace_var fvar instr cont =
331
  match instr with
332
  | MLocalAssign (i, v) -> instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont
333
  | MStateAssign (i, v) -> instr_cons (MStateAssign (i, value_replace_var fvar v)) cont
334
  | MReset i            -> instr_cons instr cont
335
  | MStep (il, i, vl)   -> instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont
336
  | MBranch (g, hl)     -> instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl)) cont
337

    
338
and instrs_replace_var fvar instrs cont =
339
  List.fold_right (instr_replace_var fvar) instrs cont
340

    
341
let step_replace_var fvar step =
342
  (* Some outputs may have been replaced by locals.
343
     We then need to rename those outputs
344
     without changing their clocks, etc *)
345
  let outputs' =
346
    List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs in
347
  let locals'  =
348
    List.fold_left (fun res l ->
349
      let l' = fvar l in
350
      if List.exists (fun o -> o.var_id = l'.var_id) outputs'
351
      then res
352
      else Utils.add_cons l' res)
353
      [] step.step_locals in
354
  { step with
355
    step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks;
356
    step_outputs = outputs';
357
    step_locals = locals';
358
    step_instrs = instrs_replace_var fvar step.step_instrs [];
359
}
360

    
361
let rec machine_replace_variables fvar m =
362
  { m with
363
    mstep = step_replace_var fvar m.mstep
364
  }
365

    
366
let machine_reuse_variables m reuse =
367
  let fvar v =
368
    try
369
      Hashtbl.find reuse v.var_id
370
    with Not_found -> v in
371
  machine_replace_variables fvar m
372

    
373
let machines_reuse_variables prog node_schs =
374
  List.map 
375
    (fun m -> 
376
      machine_reuse_variables m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table
377
    ) prog
378

    
379
let rec instr_assign res instr =
380
  match instr with
381
  | MLocalAssign (i, _) -> Disjunction.CISet.add i res
382
  | MStateAssign (i, _) -> Disjunction.CISet.add i res
383
  | MBranch (g, hl)     -> List.fold_left (fun res (h, b) -> instrs_assign res b) res hl
384
  | MStep (il, _, _)    -> List.fold_right Disjunction.CISet.add il res
385
  | _                   -> res
386

    
387
and instrs_assign res instrs =
388
  List.fold_left instr_assign res instrs
389

    
390
let rec instr_constant_assign var instr =
391
  match instr with
392
  | MLocalAssign (i, Cst (Const_tag _))
393
  | MStateAssign (i, Cst (Const_tag _)) -> i = var
394
  | MBranch (g, hl)                     -> List.for_all (fun (h, b) -> instrs_constant_assign var b) hl
395
  | _                                   -> false
396

    
397
and instrs_constant_assign var instrs =
398
  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
399

    
400
let rec instr_reduce branches instr1 cont =
401
  match instr1 with
402
  | MLocalAssign (_, Cst (Const_tag c)) -> instr1 :: (List.assoc c branches @ cont)
403
  | MStateAssign (_, Cst (Const_tag c)) -> instr1 :: (List.assoc c branches @ cont)
404
  | MBranch (g, hl)                     -> MBranch (g, List.map (fun (h, b) -> (h, instrs_reduce branches b [])) hl) :: cont
405
  | _                                   -> instr1 :: cont
406

    
407
and instrs_reduce branches instrs cont =
408
 match instrs with
409
 | []        -> cont
410
 | [i]       -> instr_reduce branches i cont
411
 | i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont
412

    
413
let rec instrs_fusion instrs =
414
  match instrs with
415
  | []
416
  | [_]                                                               ->
417
    instrs
418
  | i1::(MBranch (LocalVar v, hl))::q when instr_constant_assign v i1 ->
419
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q)
420
  | i1::(MBranch (StateVar v, hl))::q when instr_constant_assign v i1 ->
421
    instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q) 
422
  | i1::i2::q                                                         ->
423
    i1 :: instrs_fusion (i2::q)
424

    
425
let step_fusion step =
426
  { step with
427
    step_instrs = instrs_fusion step.step_instrs;
428
  }
429

    
430
let rec machine_fusion m =
431
  { m with
432
    mstep = step_fusion m.mstep
433
  }
434

    
435
let machines_fusion prog =
436
  List.map machine_fusion prog
437

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