lustrec / src / optimize_machine.ml @ c287ba28
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 subexpression 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 subexpression 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 subexpression 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 
(* compilecommand:"make C .." *) 
440 
(* End: *) 