lustrec / src / optimize_machine.ml @ 55537f48
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 sub-expression 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 sub-expression 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 sub-expression 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 |
(* compile-command:"make -C .." *) |
441 |
(* End: *) |