lustrec / src / optimize_machine.ml @ 53206908
History  View  Annotate  Download (17.3 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 
 MComment _ > instr 
31 
 MLocalAssign (i,v) > MLocalAssign (i, e_expr v) 
32 
 MStateAssign (i,v) > MStateAssign (i, e_expr v) 
33 
 MReset i > instr 
34 
 MStep (il, i, vl) > MStep(il, i, List.map e_expr vl) 
35 
 MBranch (g,hl) > 
36 
MBranch 
37 
(e_expr g, 
38 
(List.map 
39 
(fun (l, il) > l, List.map (eliminate elim) il) 
40 
hl 
41 
) 
42 
) 
43 

44 
and eliminate_expr elim expr = 
45 
match expr.value_desc with 
46 
 LocalVar v > (try IMap.find v.var_id elim with Not_found > expr) 
47 
 Fun (id, vl) > {expr with value_desc = Fun (id, List.map (eliminate_expr elim) vl)} 
48 
 Array(vl) > {expr with value_desc = Array(List.map (eliminate_expr elim) vl)} 
49 
 Access(v1, v2) > { expr with value_desc = Access(eliminate_expr elim v1, eliminate_expr elim v2)} 
50 
 Power(v1, v2) > { expr with value_desc = Power(eliminate_expr elim v1, eliminate_expr elim v2)} 
51 
 Cst _  StateVar _ > expr 
52  
53 
let is_scalar_const c = 
54 
match c with 
55 
 Const_real _ 
56 
 Const_int _ 
57 
 Const_tag _ > true 
58 
 _ > false 
59  
60 
let basic_unfoldable_expr expr = 
61 
match expr.value_desc with 
62 
 Cst c when is_scalar_const c > true 
63 
 LocalVar _ 
64 
 StateVar _ > true 
65 
 _ > false 
66  
67 
let rec basic_unfoldable_assign fanin v expr = 
68 
try 
69 
let d = Hashtbl.find fanin v.var_id 
70 
in match expr.value_desc with 
71 
 Cst c when is_scalar_const c > true 
72 
 Cst c when d < 2 > true 
73 
 LocalVar _ 
74 
 StateVar _ > true 
75 
 Fun (id, [a]) when d < 2 && Basic_library.is_value_internal_fun expr > basic_unfoldable_assign fanin v a 
76 
 _ > false 
77 
with Not_found > false 
78  
79 
let unfoldable_assign fanin v expr = 
80 
(if !Options.mpfr then Mpfr.unfoldable_value expr else true) 
81 
&& basic_unfoldable_assign fanin v expr 
82  
83 
let merge_elim elim1 elim2 = 
84 
let merge k e1 e2 = 
85 
match e1, e2 with 
86 
 Some e1, Some e2 > if e1 = e2 then Some e1 else None 
87 
 _ , Some e2 > Some e2 
88 
 Some e1, _ > Some e1 
89 
 _ > None 
90 
in IMap.merge merge elim1 elim2 
91  
92 
(* see if elim has to take in account the provided instr: 
93 
if so, update elim and return the remove flag, 
94 
otherwise, the expression should be kept and elim is left untouched *) 
95 
let rec instrs_unfold fanin elim instrs = 
96 
let elim, rev_instrs = 
97 
List.fold_left (fun (elim, instrs) instr > 
98 
(* each subexpression in instr that could be rewritten by the elim set is 
99 
rewritten *) 
100 
let instr = eliminate elim instr in 
101 
(* if instr is a simple local assign, then (a) elim is simplified with it (b) it 
102 
is stored as the elim set *) 
103 
instr_unfold fanin instrs elim instr 
104 
) (elim, []) instrs 
105 
in elim, List.rev rev_instrs 
106  
107 
and instr_unfold fanin instrs elim instr = 
108 
(* Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*) 
109 
match instr with 
110 
(* Simple cases*) 
111 
 MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type) 
112 
> instr_unfold fanin instrs elim (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type)) 
113 
 MLocalAssign(v, expr) when unfoldable_assign fanin v expr 
114 
> (IMap.add v.var_id expr elim, instrs) 
115 
 MBranch(g, hl) when false 
116 
> let elim_branches = List.map (fun (h, l) > (h, instrs_unfold fanin elim l)) hl in 
117 
let (elim, branches) = 
118 
List.fold_right 
119 
(fun (h, (e, l)) (elim, branches) > (merge_elim elim e, (h, l)::branches)) 
120 
elim_branches (elim, []) 
121 
in elim, (MBranch (g, branches) :: instrs) 
122 
 _ 
123 
> (elim, instr :: instrs) 
124 
(* default case, we keep the instruction and do not modify elim *) 
125 

126  
127 
(** We iterate in the order, recording simple local assigns in an accumulator 
128 
1. each expression is rewritten according to the accumulator 
129 
2. local assigns then rewrite occurrences of the lhs in the computed accumulator 
130 
*) 
131  
132 
let static_call_unfold elim (inst, (n, args)) = 
133 
let replace v = 
134 
try 
135 
Machine_code.dimension_of_value (IMap.find v elim) 
136 
with Not_found > Dimension.mkdim_ident Location.dummy_loc v 
137 
in (inst, (n, List.map (Dimension.expr_replace_expr replace) args)) 
138  
139 
(** Perform optimization on machine code: 
140 
 iterate through step instructions and remove simple local assigns 
141 

142 
*) 
143 
let machine_unfold fanin elim machine = 
144 
(*Log.report ~level:1 (fun fmt > Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*) 
145 
let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in 
146 
let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in 
147 
(*let instrs = simplify_instrs_offset machine instrs in*) 
148 
let checks = List.map (fun (loc, check) > loc, eliminate_expr elim_vars check) machine.mstep.step_checks in 
149 
let locals = List.filter (fun v > not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in 
150 
let minstances = List.map (static_call_unfold elim_consts) machine.minstances in 
151 
let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls 
152 
in 
153 
{ 
154 
machine with 
155 
mstep = { 
156 
machine.mstep with 
157 
step_locals = locals; 
158 
step_instrs = instrs; 
159 
step_checks = checks 
160 
}; 
161 
mconst = mconst; 
162 
minstances = minstances; 
163 
mcalls = mcalls; 
164 
}, 
165 
elim_vars 
166  
167 
let instr_of_const top_const = 
168 
let const = const_of_top top_const in 
169 
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 
170 
let vdecl = { vdecl with var_type = const.const_type } 
171 
in MLocalAssign (vdecl, mk_val (Cst const.const_value) vdecl.var_type) 
172  
173 
let machines_unfold consts node_schs machines = 
174 
List.fold_right (fun m (machines, removed) > 
175 
let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in 
176 
let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts) in 
177 
let (m, removed_m) = machine_unfold fanin elim_consts m in 
178 
(m::machines, IMap.add m.mname.node_id removed_m removed) 
179 
) 
180 
machines 
181 
([], IMap.empty) 
182  
183 
let get_assign_lhs instr = 
184 
match instr with 
185 
 MLocalAssign(v, e) > mk_val (LocalVar v) e.value_type 
186 
 MStateAssign(v, e) > mk_val (StateVar v) e.value_type 
187 
 _ > assert false 
188  
189 
let get_assign_rhs instr = 
190 
match instr with 
191 
 MLocalAssign(_, e) 
192 
 MStateAssign(_, e) > e 
193 
 _ > assert false 
194  
195 
let is_assign instr = 
196 
match instr with 
197 
 MLocalAssign _ 
198 
 MStateAssign _ > true 
199 
 _ > false 
200  
201 
let mk_assign v e = 
202 
match v.value_desc with 
203 
 LocalVar v > MLocalAssign(v, e) 
204 
 StateVar v > MStateAssign(v, e) 
205 
 _ > assert false 
206  
207 
let rec assigns_instr instr assign = 
208 
match instr with 
209 
 MLocalAssign (i,_) 
210 
 MStateAssign (i,_) > ISet.add i assign 
211 
 MStep (ol, _, _) > List.fold_right ISet.add ol assign 
212 
 MBranch (_,hl) > List.fold_right (fun (_, il) > assigns_instrs il) hl assign 
213 
 _ > assign 
214  
215 
and assigns_instrs instrs assign = 
216 
List.fold_left (fun assign instr > assigns_instr instr assign) assign instrs 
217  
218 
(* 
219 
and substitute_expr subst expr = 
220 
match expr with 
221 
 StateVar v 
222 
 LocalVar v > (try IMap.find expr subst with Not_found > expr) 
223 
 Fun (id, vl) > Fun (id, List.map (substitute_expr subst) vl) 
224 
 Array(vl) > Array(List.map (substitute_expr subst) vl) 
225 
 Access(v1, v2) > Access(substitute_expr subst v1, substitute_expr subst v2) 
226 
 Power(v1, v2) > Power(substitute_expr subst v1, substitute_expr subst v2) 
227 
 Cst _ > expr 
228 
*) 
229 
(** Finds a substitute for [instr] in [instrs], 
230 
i.e. another instr' with the same rhs expression. 
231 
Then substitute this expression with the first assigned var 
232 
*) 
233 
let subst_instr subst instrs instr = 
234 
(*Format.eprintf "subst instr: %a@." Machine_code.pp_instr instr;*) 
235 
let instr = eliminate subst instr in 
236 
let v = get_assign_lhs instr in 
237 
let e = get_assign_rhs instr in 
238 
try 
239 
let instr' = List.find (fun instr' > is_assign instr' && get_assign_rhs instr' = e) instrs in 
240 
match v.value_desc with 
241 
 LocalVar v > 
242 
IMap.add v.var_id (get_assign_lhs instr') subst, instrs 
243 
 StateVar v > 
244 
let lhs' = get_assign_lhs instr' in 
245 
let typ' = lhs'.value_type in 
246 
(match lhs'.value_desc with 
247 
 LocalVar v' > 
248 
let instr = eliminate subst (mk_assign (mk_val (StateVar v) typ') (mk_val (LocalVar v') typ')) in 
249 
subst, instr :: instrs 
250 
 StateVar v' > 
251 
let subst_v' = IMap.add v'.var_id (mk_val (StateVar v) typ') IMap.empty in 
252 
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 
253 
IMap.add v'.var_id (mk_val (StateVar v) typ') subst, instr :: instrs' 
254 
 _ > assert false) 
255 
 _ > assert false 
256 
with Not_found > subst, instr :: instrs 
257 

258 
(** Common subexpression elimination for machine instructions *) 
259 
(*  [subst] : hashtable from ident to (simple) definition 
260 
it is an equivalence table 
261 
 [elim] : set of eliminated variables 
262 
 [instrs] : previous instructions, which [instr] is compared against 
263 
 [instr] : current instruction, normalized by [subst] 
264 
*) 
265 
let rec instr_cse (subst, instrs) instr = 
266 
match instr with 
267 
(* Simple cases*) 
268 
 MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type) 
269 
> instr_cse (subst, instrs) (MLocalAssign (v, (mk_val (Fun (id, vl)) v.var_type))) 
270 
 MLocalAssign(v, expr) when basic_unfoldable_expr expr 
271 
> (IMap.add v.var_id expr subst, instr :: instrs) 
272 
 _ when is_assign instr 
273 
> subst_instr subst instrs instr 
274 
 _ > (subst, instr :: instrs) 
275  
276 
(** Apply common subexpression elimination to a sequence of instrs 
277 
*) 
278 
let rec instrs_cse subst instrs = 
279 
let subst, rev_instrs = 
280 
List.fold_left instr_cse (subst, []) instrs 
281 
in subst, List.rev rev_instrs 
282  
283 
(** Apply common subexpression elimination to a machine 
284 
 iterate through step instructions and remove simple local assigns 
285 
*) 
286 
let machine_cse subst machine = 
287 
(*Log.report ~level:1 (fun fmt > Format.fprintf fmt "machine_cse %a@." pp_elim subst);*) 
288 
let subst, instrs = instrs_cse subst machine.mstep.step_instrs in 
289 
let assigned = assigns_instrs instrs ISet.empty 
290 
in 
291 
{ 
292 
machine with 
293 
mmemory = List.filter (fun vdecl > ISet.mem vdecl assigned) machine.mmemory; 
294 
mstep = { 
295 
machine.mstep with 
296 
step_locals = List.filter (fun vdecl > ISet.mem vdecl assigned) machine.mstep.step_locals; 
297 
step_instrs = instrs 
298 
} 
299 
} 
300  
301 
let machines_cse machines = 
302 
List.map 
303 
(machine_cse IMap.empty) 
304 
machines 
305  
306 
(* variable substitution for optimizing purposes *) 
307  
308 
(* checks whether an [instr] is skip and can be removed from program *) 
309 
let rec instr_is_skip instr = 
310 
match instr with 
311 
 MLocalAssign (i, { value_desc = (LocalVar v) ; _}) when i = v > true 
312 
 MStateAssign (i, { value_desc = StateVar v; _}) when i = v > true 
313 
 MBranch (g, hl) > List.for_all (fun (_, il) > instrs_are_skip il) hl 
314 
 _ > false 
315 
and instrs_are_skip instrs = 
316 
List.for_all instr_is_skip instrs 
317  
318 
let instr_cons instr cont = 
319 
if instr_is_skip instr then cont else instr::cont 
320  
321 
let rec instr_remove_skip instr cont = 
322 
match instr with 
323 
 MLocalAssign (i, { value_desc = LocalVar v; _ }) when i = v > cont 
324 
 MStateAssign (i, { value_desc = StateVar v; _ }) when i = v > cont 
325 
 MBranch (g, hl) > MBranch (g, List.map (fun (h, il) > (h, instrs_remove_skip il [])) hl) :: cont 
326 
 _ > instr::cont 
327  
328 
and instrs_remove_skip instrs cont = 
329 
List.fold_right instr_remove_skip instrs cont 
330  
331 
let rec value_replace_var fvar value = 
332 
match value.value_desc with 
333 
 Cst c > value 
334 
 LocalVar v > { value with value_desc = LocalVar (fvar v) } 
335 
 StateVar v > value 
336 
 Fun (id, args) > { value with value_desc = Fun (id, List.map (value_replace_var fvar) args) } 
337 
 Array vl > { value with value_desc = Array (List.map (value_replace_var fvar) vl)} 
338 
 Access (t, i) > { value with value_desc = Access(value_replace_var fvar t, i)} 
339 
 Power (v, n) > { value with value_desc = Power(value_replace_var fvar v, n)} 
340  
341 
let rec instr_replace_var fvar instr cont = 
342 
match instr with 
343 
 MComment _ > instr_cons instr cont 
344 
 MLocalAssign (i, v) > instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont 
345 
 MStateAssign (i, v) > instr_cons (MStateAssign (i, value_replace_var fvar v)) cont 
346 
 MReset i > instr_cons instr cont 
347 
 MStep (il, i, vl) > instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont 
348 
 MBranch (g, hl) > instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) > (h, instrs_replace_var fvar il [])) hl)) cont 
349  
350 
and instrs_replace_var fvar instrs cont = 
351 
List.fold_right (instr_replace_var fvar) instrs cont 
352  
353 
let step_replace_var fvar step = 
354 
(* Some outputs may have been replaced by locals. 
355 
We then need to rename those outputs 
356 
without changing their clocks, etc *) 
357 
let outputs' = 
358 
List.map (fun o > { o with var_id = (fvar o).var_id }) step.step_outputs in 
359 
let locals' = 
360 
List.fold_left (fun res l > 
361 
let l' = fvar l in 
362 
if List.exists (fun o > o.var_id = l'.var_id) outputs' 
363 
then res 
364 
else Utils.add_cons l' res) 
365 
[] step.step_locals in 
366 
{ step with 
367 
step_checks = List.map (fun (l, v) > (l, value_replace_var fvar v)) step.step_checks; 
368 
step_outputs = outputs'; 
369 
step_locals = locals'; 
370 
step_instrs = instrs_replace_var fvar step.step_instrs []; 
371 
} 
372  
373 
let rec machine_replace_variables fvar m = 
374 
{ m with 
375 
mstep = step_replace_var fvar m.mstep 
376 
} 
377  
378 
let machine_reuse_variables m reuse = 
379 
let fvar v = 
380 
try 
381 
Hashtbl.find reuse v.var_id 
382 
with Not_found > v in 
383 
machine_replace_variables fvar m 
384  
385 
let machines_reuse_variables prog reuse_tables = 
386 
List.map 
387 
(fun m > 
388 
machine_reuse_variables m (Utils.IMap.find m.mname.node_id reuse_tables) 
389 
) prog 
390  
391 
let rec instr_assign res instr = 
392 
match instr with 
393 
 MLocalAssign (i, _) > Disjunction.CISet.add i res 
394 
 MStateAssign (i, _) > Disjunction.CISet.add i res 
395 
 MBranch (g, hl) > List.fold_left (fun res (h, b) > instrs_assign res b) res hl 
396 
 MStep (il, _, _) > List.fold_right Disjunction.CISet.add il res 
397 
 _ > res 
398  
399 
and instrs_assign res instrs = 
400 
List.fold_left instr_assign res instrs 
401  
402 
let rec instr_constant_assign var instr = 
403 
match instr with 
404 
 MLocalAssign (i, { value_desc = Cst (Const_tag _); _ }) 
405 
 MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) > i = var 
406 
 MBranch (g, hl) > List.for_all (fun (h, b) > instrs_constant_assign var b) hl 
407 
 _ > false 
408  
409 
and instrs_constant_assign var instrs = 
410 
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 
411  
412 
let rec instr_reduce branches instr1 cont = 
413 
match instr1 with 
414 
 MLocalAssign (_, { value_desc = Cst (Const_tag c); _}) > instr1 :: (List.assoc c branches @ cont) 
415 
 MStateAssign (_, { value_desc = Cst (Const_tag c); _}) > instr1 :: (List.assoc c branches @ cont) 
416 
 MBranch (g, hl) > MBranch (g, List.map (fun (h, b) > (h, instrs_reduce branches b [])) hl) :: cont 
417 
 _ > instr1 :: cont 
418  
419 
and instrs_reduce branches instrs cont = 
420 
match instrs with 
421 
 [] > cont 
422 
 [i] > instr_reduce branches i cont 
423 
 i1::i2::q > i1 :: instrs_reduce branches (i2::q) cont 
424  
425 
let rec instrs_fusion instrs = 
426 
match instrs with 
427 
 [] 
428 
 [_] > 
429 
instrs 
430 
 i1::(MBranch ({ value_desc = LocalVar v; _}, hl))::q when instr_constant_assign v i1 > 
431 
instr_reduce (List.map (fun (h, b) > h, instrs_fusion b) hl) i1 (instrs_fusion q) 
432 
 i1::(MBranch ({ value_desc = StateVar v; _}, hl))::q when instr_constant_assign v i1 > 
433 
instr_reduce (List.map (fun (h, b) > h, instrs_fusion b) hl) i1 (instrs_fusion q) 
434 
 i1::i2::q > 
435 
i1 :: instrs_fusion (i2::q) 
436  
437 
let step_fusion step = 
438 
{ step with 
439 
step_instrs = instrs_fusion step.step_instrs; 
440 
} 
441  
442 
let rec machine_fusion m = 
443 
{ m with 
444 
mstep = step_fusion m.mstep 
445 
} 
446  
447 
let machines_fusion prog = 
448 
List.map machine_fusion prog 
449  
450 
(* Local Variables: *) 
451 
(* compilecommand:"make C .." *) 
452 
(* End: *) 