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 subexpression 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 subexpression 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 subexpression 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 
(* compilecommand:"make C .." *) 
463 
(* End: *) 