lustrec / src / optimize_machine.ml @ 55537f48
History | View | Annotate | Download (16 KB)
1 | a2d97a3e | ploc | (********************************************************************) |
---|---|---|---|
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 | d0b1ec56 | xthirioux | open Utils |
13 | cf78a589 | ploc | open LustreSpec |
14 | open Corelang |
||
15 | b1655a21 | xthirioux | open Causality |
16 | cf78a589 | ploc | open Machine_code |
17 | ec433d69 | xthirioux | open Dimension |
18 | cf78a589 | ploc | |
19 | 55537f48 | xthirioux | |
20 | d0b1ec56 | xthirioux | 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 | cf78a589 | ploc | 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 | c287ba28 | xthirioux | | StateVar v |
46 | d0b1ec56 | xthirioux | | LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr) |
47 | cf78a589 | ploc | | 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 | d0b1ec56 | xthirioux | | Power(v1, v2) -> Power(eliminate_expr elim v1, eliminate_expr elim v2) |
51 | c287ba28 | xthirioux | | Cst _ -> expr |
52 | cf78a589 | ploc | |
53 | ec433d69 | xthirioux | 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 | d0b1ec56 | xthirioux | 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 | c287ba28 | xthirioux | 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 | d0b1ec56 | xthirioux | let unfoldable_assign fanin v expr = |
72 | try |
||
73 | let d = Hashtbl.find fanin v.var_id |
||
74 | c287ba28 | xthirioux | in basic_unfoldable_expr expr || |
75 | match expr with |
||
76 | | Cst c when d < 2 -> true |
||
77 | d0b1ec56 | xthirioux | | 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 | cf78a589 | ploc | (* see if elim has to take in account the provided instr: |
91 | 54d032f5 | xthirioux | if so, update elim and return the remove flag, |
92 | cf78a589 | ploc | otherwise, the expression should be kept and elim is left untouched *) |
93 | d0b1ec56 | xthirioux | 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 | 429ab729 | ploc | (* Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*) |
107 | cf78a589 | ploc | match instr with |
108 | (* Simple cases*) |
||
109 | d0b1ec56 | xthirioux | | 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 | cf78a589 | ploc | (* 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 | ec433d69 | xthirioux | 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 | cf78a589 | ploc | (** Perform optimization on machine code: |
138 | - iterate through step instructions and remove simple local assigns |
||
139 | |||
140 | *) |
||
141 | d0b1ec56 | xthirioux | let machine_unfold fanin elim machine = |
142 | (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*) |
||
143 | ec433d69 | xthirioux | 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 | cf78a589 | ploc | in |
149 | { |
||
150 | machine with |
||
151 | mstep = { |
||
152 | machine.mstep with |
||
153 | ec433d69 | xthirioux | step_locals = locals; |
154 | step_instrs = instrs |
||
155 | }; |
||
156 | mconst = mconst; |
||
157 | minstances = minstances; |
||
158 | mcalls = mcalls; |
||
159 | cf78a589 | ploc | } |
160 | |||
161 | d0b1ec56 | xthirioux | let instr_of_const top_const = |
162 | let const = const_of_top top_const in |
||
163 | ec433d69 | xthirioux | 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 | d0b1ec56 | xthirioux | let vdecl = { vdecl with var_type = const.const_type } |
165 | in MLocalAssign (vdecl, Cst const.const_value) |
||
166 | cf78a589 | ploc | |
167 | d0b1ec56 | xthirioux | 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 | cf78a589 | ploc | |
175 | c287ba28 | xthirioux | 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 | 45c13277 | xthirioux | (* 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 | b1655a21 | xthirioux | 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 | cf78a589 | ploc | |
439 | (* Local Variables: *) |
||
440 | (* compile-command:"make -C .." *) |
||
441 | (* End: *) |