lustrec / src / optimize_machine.ml @ 307aba8d
History | View | Annotate | Download (10.9 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 |
|
18 |
let pp_elim fmt elim = |
19 |
begin |
20 |
Format.fprintf fmt "{ /* elim table: */@."; |
21 |
IMap.iter (fun v expr -> Format.fprintf fmt "%s |-> %a@." v pp_val expr) elim; |
22 |
Format.fprintf fmt "}@."; |
23 |
end |
24 |
|
25 |
let rec eliminate elim instr = |
26 |
let e_expr = eliminate_expr elim in |
27 |
match instr with |
28 |
| MLocalAssign (i,v) -> MLocalAssign (i, e_expr v) |
29 |
| MStateAssign (i,v) -> MStateAssign (i, e_expr v) |
30 |
| MReset i -> instr |
31 |
| MStep (il, i, vl) -> MStep(il, i, List.map e_expr vl) |
32 |
| MBranch (g,hl) -> |
33 |
MBranch |
34 |
(e_expr g, |
35 |
(List.map |
36 |
(fun (l, il) -> l, List.map (eliminate elim) il) |
37 |
hl |
38 |
) |
39 |
) |
40 |
|
41 |
and eliminate_expr elim expr = |
42 |
match expr with |
43 |
| LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr) |
44 |
| Fun (id, vl) -> Fun (id, List.map (eliminate_expr elim) vl) |
45 |
| Array(vl) -> Array(List.map (eliminate_expr elim) vl) |
46 |
| Access(v1, v2) -> Access(eliminate_expr elim v1, eliminate_expr elim v2) |
47 |
| Power(v1, v2) -> Power(eliminate_expr elim v1, eliminate_expr elim v2) |
48 |
| Cst _ | StateVar _ -> expr |
49 |
|
50 |
let is_scalar_const c = |
51 |
match c with |
52 |
| Const_int _ |
53 |
| Const_real _ |
54 |
| Const_float _ |
55 |
| Const_tag _ -> true |
56 |
| _ -> false |
57 |
|
58 |
let unfoldable_assign fanin v expr = |
59 |
try |
60 |
let d = Hashtbl.find fanin v.var_id |
61 |
in match expr with |
62 |
| Cst c when is_scalar_const c -> true |
63 |
| Cst c when d < 2 -> true |
64 |
| LocalVar _ |
65 |
| StateVar _ -> true |
66 |
| Fun (id, _) when d < 2 && Basic_library.is_internal_fun id -> true |
67 |
| _ -> false |
68 |
with Not_found -> false |
69 |
|
70 |
let merge_elim elim1 elim2 = |
71 |
let merge k e1 e2 = |
72 |
match e1, e2 with |
73 |
| Some e1, Some e2 -> if e1 = e2 then Some e1 else None |
74 |
| _ , Some e2 -> Some e2 |
75 |
| Some e1, _ -> Some e1 |
76 |
| _ -> None |
77 |
in IMap.merge merge elim1 elim2 |
78 |
|
79 |
(* see if elim has to take in account the provided instr: |
80 |
if so, update elim and return the remove flag, |
81 |
otherwise, the expression should be kept and elim is left untouched *) |
82 |
let rec instrs_unfold fanin elim instrs = |
83 |
let elim, rev_instrs = |
84 |
List.fold_left (fun (elim, instrs) instr -> |
85 |
(* each subexpression in instr that could be rewritten by the elim set is |
86 |
rewritten *) |
87 |
let instr = eliminate elim instr in |
88 |
(* if instr is a simple local assign, then (a) elim is simplified with it (b) it |
89 |
is stored as the elim set *) |
90 |
instr_unfold fanin instrs elim instr |
91 |
) (elim, []) instrs |
92 |
in elim, List.rev rev_instrs |
93 |
|
94 |
and instr_unfold fanin instrs elim instr = |
95 |
(* Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*) |
96 |
match instr with |
97 |
(* Simple cases*) |
98 |
| MStep([v], id, vl) when Basic_library.is_internal_fun id |
99 |
-> instr_unfold fanin instrs elim (MLocalAssign (v, Fun (id, vl))) |
100 |
| MLocalAssign(v, expr) when unfoldable_assign fanin v expr |
101 |
-> (IMap.add v.var_id expr elim, instrs) |
102 |
| MBranch(g, hl) when false |
103 |
-> let elim_branches = List.map (fun (h, l) -> (h, instrs_unfold fanin elim l)) hl in |
104 |
let (elim, branches) = |
105 |
List.fold_right |
106 |
(fun (h, (e, l)) (elim, branches) -> (merge_elim elim e, (h, l)::branches)) |
107 |
elim_branches (elim, []) |
108 |
in elim, (MBranch (g, branches) :: instrs) |
109 |
| _ |
110 |
-> (elim, instr :: instrs) |
111 |
(* default case, we keep the instruction and do not modify elim *) |
112 |
|
113 |
|
114 |
(** We iterate in the order, recording simple local assigns in an accumulator |
115 |
1. each expression is rewritten according to the accumulator |
116 |
2. local assigns then rewrite occurrences of the lhs in the computed accumulator |
117 |
*) |
118 |
|
119 |
(** Perform optimization on machine code: |
120 |
- iterate through step instructions and remove simple local assigns |
121 |
|
122 |
*) |
123 |
let machine_unfold fanin elim machine = |
124 |
(*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*) |
125 |
let eliminated_vars, new_instrs = instrs_unfold fanin elim machine.mstep.step_instrs in |
126 |
let new_locals = List.filter (fun v -> not (IMap.mem v.var_id eliminated_vars)) machine.mstep.step_locals |
127 |
in |
128 |
{ |
129 |
machine with |
130 |
mstep = { |
131 |
machine.mstep with |
132 |
step_locals = new_locals; |
133 |
step_instrs = new_instrs |
134 |
} |
135 |
} |
136 |
|
137 |
let instr_of_const top_const = |
138 |
let const = const_of_top top_const in |
139 |
let vdecl = mkvar_decl Location.dummy_loc (const.const_id, mktyp Location.dummy_loc Tydec_any, mkclock Location.dummy_loc Ckdec_any, true) in |
140 |
let vdecl = { vdecl with var_type = const.const_type } |
141 |
in MLocalAssign (vdecl, Cst const.const_value) |
142 |
|
143 |
let machines_unfold consts node_schs machines = |
144 |
List.map |
145 |
(fun m -> |
146 |
let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in |
147 |
let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts) |
148 |
in machine_unfold fanin elim_consts m) |
149 |
machines |
150 |
|
151 |
(* variable substitution for optimizing purposes *) |
152 |
|
153 |
(* checks whether an [instr] is skip and can be removed from program *) |
154 |
let rec instr_is_skip instr = |
155 |
match instr with |
156 |
| MLocalAssign (i, LocalVar v) when i = v -> true |
157 |
| MStateAssign (i, StateVar v) when i = v -> true |
158 |
| MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl |
159 |
| _ -> false |
160 |
and instrs_are_skip instrs = |
161 |
List.for_all instr_is_skip instrs |
162 |
|
163 |
let instr_cons instr cont = |
164 |
if instr_is_skip instr then cont else instr::cont |
165 |
|
166 |
let rec instr_remove_skip instr cont = |
167 |
match instr with |
168 |
| MLocalAssign (i, LocalVar v) when i = v -> cont |
169 |
| MStateAssign (i, StateVar v) when i = v -> cont |
170 |
| MBranch (g, hl) -> MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl) :: cont |
171 |
| _ -> instr::cont |
172 |
|
173 |
and instrs_remove_skip instrs cont = |
174 |
List.fold_right instr_remove_skip instrs cont |
175 |
|
176 |
let rec value_replace_var fvar value = |
177 |
match value with |
178 |
| Cst c -> value |
179 |
| LocalVar v -> LocalVar (fvar v) |
180 |
| StateVar v -> value |
181 |
| Fun (id, args) -> Fun (id, List.map (value_replace_var fvar) args) |
182 |
| Array vl -> Array (List.map (value_replace_var fvar) vl) |
183 |
| Access (t, i) -> Access(value_replace_var fvar t, i) |
184 |
| Power (v, n) -> Power(value_replace_var fvar v, n) |
185 |
|
186 |
let rec instr_replace_var fvar instr cont = |
187 |
match instr with |
188 |
| MLocalAssign (i, v) -> instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont |
189 |
| MStateAssign (i, v) -> instr_cons (MStateAssign (i, value_replace_var fvar v)) cont |
190 |
| MReset i -> instr_cons instr cont |
191 |
| MStep (il, i, vl) -> instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont |
192 |
| MBranch (g, hl) -> instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl)) cont |
193 |
|
194 |
and instrs_replace_var fvar instrs cont = |
195 |
List.fold_right (instr_replace_var fvar) instrs cont |
196 |
|
197 |
let step_replace_var fvar step = |
198 |
(* Some outputs may have been replaced by locals. |
199 |
We then need to rename those outputs |
200 |
without changing their clocks, etc *) |
201 |
let outputs' = |
202 |
List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs in |
203 |
let locals' = |
204 |
List.fold_left (fun res l -> |
205 |
let l' = fvar l in |
206 |
if List.exists (fun o -> o.var_id = l'.var_id) outputs' |
207 |
then res |
208 |
else Utils.add_cons l' res) |
209 |
[] step.step_locals in |
210 |
{ step with |
211 |
step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks; |
212 |
step_outputs = outputs'; |
213 |
step_locals = locals'; |
214 |
step_instrs = instrs_replace_var fvar step.step_instrs []; |
215 |
} |
216 |
|
217 |
let rec machine_replace_variables fvar m = |
218 |
{ m with |
219 |
mstep = step_replace_var fvar m.mstep |
220 |
} |
221 |
|
222 |
let machine_reuse_variables m reuse = |
223 |
let fvar v = |
224 |
try |
225 |
Hashtbl.find reuse v.var_id |
226 |
with Not_found -> v in |
227 |
machine_replace_variables fvar m |
228 |
|
229 |
let machines_reuse_variables prog node_schs = |
230 |
List.map |
231 |
(fun m -> |
232 |
machine_reuse_variables m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table |
233 |
) prog |
234 |
|
235 |
let rec instr_assign res instr = |
236 |
match instr with |
237 |
| MLocalAssign (i, _) -> Disjunction.CISet.add i res |
238 |
| MStateAssign (i, _) -> Disjunction.CISet.add i res |
239 |
| MBranch (g, hl) -> List.fold_left (fun res (h, b) -> instrs_assign res b) res hl |
240 |
| MStep (il, _, _) -> List.fold_right Disjunction.CISet.add il res |
241 |
| _ -> res |
242 |
|
243 |
and instrs_assign res instrs = |
244 |
List.fold_left instr_assign res instrs |
245 |
|
246 |
let rec instr_constant_assign var instr = |
247 |
match instr with |
248 |
| MLocalAssign (i, Cst (Const_tag _)) |
249 |
| MStateAssign (i, Cst (Const_tag _)) -> i = var |
250 |
| MBranch (g, hl) -> List.for_all (fun (h, b) -> instrs_constant_assign var b) hl |
251 |
| _ -> false |
252 |
|
253 |
and instrs_constant_assign var instrs = |
254 |
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 |
255 |
|
256 |
let rec instr_reduce branches instr1 cont = |
257 |
match instr1 with |
258 |
| MLocalAssign (_, Cst (Const_tag c)) -> instr1 :: (List.assoc c branches @ cont) |
259 |
| MStateAssign (_, Cst (Const_tag c)) -> instr1 :: (List.assoc c branches @ cont) |
260 |
| MBranch (g, hl) -> MBranch (g, List.map (fun (h, b) -> (h, instrs_reduce branches b [])) hl) :: cont |
261 |
| _ -> instr1 :: cont |
262 |
|
263 |
and instrs_reduce branches instrs cont = |
264 |
match instrs with |
265 |
| [] -> cont |
266 |
| [i] -> instr_reduce branches i cont |
267 |
| i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont |
268 |
|
269 |
let rec instrs_fusion instrs = |
270 |
match instrs with |
271 |
| [] |
272 |
| [_] -> |
273 |
instrs |
274 |
| i1::(MBranch (LocalVar v, hl))::q when instr_constant_assign v i1 -> |
275 |
instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q) |
276 |
| i1::(MBranch (StateVar v, hl))::q when instr_constant_assign v i1 -> |
277 |
instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q) |
278 |
| i1::i2::q -> |
279 |
i1 :: instrs_fusion (i2::q) |
280 |
|
281 |
let step_fusion step = |
282 |
{ step with |
283 |
step_instrs = instrs_fusion step.step_instrs; |
284 |
} |
285 |
|
286 |
let rec machine_fusion m = |
287 |
{ m with |
288 |
mstep = step_fusion m.mstep |
289 |
} |
290 |
|
291 |
let machines_fusion prog = |
292 |
List.map machine_fusion prog |
293 |
|
294 |
(* Local Variables: *) |
295 |
(* compile-command:"make -C .." *) |
296 |
(* End: *) |