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