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 sub-expression 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 sub-expression 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 sub-expression 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 |
(* compile-command:"make -C .." *) |
463 |
(* End: *) |