lustrec / src / optimize_machine.ml @ 01d48bb0
History  View  Annotate  Download (11.6 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 
 LocalVar v > (try IMap.find v.var_id elim with Not_found > expr) 
45 
 Fun (id, vl) > Fun (id, List.map (eliminate_expr elim) vl) 
46 
 Array(vl) > Array(List.map (eliminate_expr elim) vl) 
47 
 Access(v1, v2) > Access(eliminate_expr elim v1, eliminate_expr elim v2) 
48 
 Power(v1, v2) > Power(eliminate_expr elim v1, eliminate_expr elim v2) 
49 
 Cst _  StateVar _ > expr 
50  
51 
let eliminate_dim elim dim = 
52 
Dimension.expr_replace_expr (fun v > try dimension_of_value (IMap.find v elim) with Not_found > mkdim_ident dim.dim_loc v) dim 
53  
54 
let is_scalar_const c = 
55 
match c with 
56 
 Const_int _ 
57 
 Const_real _ 
58 
 Const_float _ 
59 
 Const_tag _ > true 
60 
 _ > false 
61  
62 
let unfoldable_assign fanin v expr = 
63 
try 
64 
let d = Hashtbl.find fanin v.var_id 
65 
in match expr with 
66 
 Cst c when is_scalar_const c > true 
67 
 Cst c when d < 2 > true 
68 
 LocalVar _ 
69 
 StateVar _ > true 
70 
 Fun (id, _) when d < 2 && Basic_library.is_internal_fun id > true 
71 
 _ > false 
72 
with Not_found > false 
73  
74 
let merge_elim elim1 elim2 = 
75 
let merge k e1 e2 = 
76 
match e1, e2 with 
77 
 Some e1, Some e2 > if e1 = e2 then Some e1 else None 
78 
 _ , Some e2 > Some e2 
79 
 Some e1, _ > Some e1 
80 
 _ > None 
81 
in IMap.merge merge elim1 elim2 
82  
83 
(* see if elim has to take in account the provided instr: 
84 
if so, update elim and return the remove flag, 
85 
otherwise, the expression should be kept and elim is left untouched *) 
86 
let rec instrs_unfold fanin elim instrs = 
87 
let elim, rev_instrs = 
88 
List.fold_left (fun (elim, instrs) instr > 
89 
(* each subexpression in instr that could be rewritten by the elim set is 
90 
rewritten *) 
91 
let instr = eliminate elim instr in 
92 
(* if instr is a simple local assign, then (a) elim is simplified with it (b) it 
93 
is stored as the elim set *) 
94 
instr_unfold fanin instrs elim instr 
95 
) (elim, []) instrs 
96 
in elim, List.rev rev_instrs 
97  
98 
and instr_unfold fanin instrs elim instr = 
99 
(* Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*) 
100 
match instr with 
101 
(* Simple cases*) 
102 
 MStep([v], id, vl) when Basic_library.is_internal_fun id 
103 
> instr_unfold fanin instrs elim (MLocalAssign (v, Fun (id, vl))) 
104 
 MLocalAssign(v, expr) when unfoldable_assign fanin v expr 
105 
> (IMap.add v.var_id expr elim, instrs) 
106 
 MBranch(g, hl) when false 
107 
> let elim_branches = List.map (fun (h, l) > (h, instrs_unfold fanin elim l)) hl in 
108 
let (elim, branches) = 
109 
List.fold_right 
110 
(fun (h, (e, l)) (elim, branches) > (merge_elim elim e, (h, l)::branches)) 
111 
elim_branches (elim, []) 
112 
in elim, (MBranch (g, branches) :: instrs) 
113 
 _ 
114 
> (elim, instr :: instrs) 
115 
(* default case, we keep the instruction and do not modify elim *) 
116 

117  
118 
(** We iterate in the order, recording simple local assigns in an accumulator 
119 
1. each expression is rewritten according to the accumulator 
120 
2. local assigns then rewrite occurrences of the lhs in the computed accumulator 
121 
*) 
122  
123 
let static_call_unfold elim (inst, (n, args)) = 
124 
let replace v = 
125 
try 
126 
Machine_code.dimension_of_value (IMap.find v elim) 
127 
with Not_found > Dimension.mkdim_ident Location.dummy_loc v 
128 
in (inst, (n, List.map (Dimension.expr_replace_expr replace) args)) 
129  
130 
(** Perform optimization on machine code: 
131 
 iterate through step instructions and remove simple local assigns 
132 

133 
*) 
134 
let machine_unfold fanin elim machine = 
135 
(*Log.report ~level:1 (fun fmt > Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*) 
136 
let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in 
137 
let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in 
138 
let locals = List.filter (fun v > not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in 
139 
let minstances = List.map (static_call_unfold elim_consts) machine.minstances in 
140 
let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls 
141 
in 
142 
{ 
143 
machine with 
144 
mstep = { 
145 
machine.mstep with 
146 
step_locals = locals; 
147 
step_instrs = instrs 
148 
}; 
149 
mconst = mconst; 
150 
minstances = minstances; 
151 
mcalls = mcalls; 
152 
} 
153  
154 
let instr_of_const top_const = 
155 
let const = const_of_top top_const in 
156 
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 
157 
let vdecl = { vdecl with var_type = const.const_type } 
158 
in MLocalAssign (vdecl, Cst const.const_value) 
159  
160 
let machines_unfold consts node_schs machines = 
161 
List.map 
162 
(fun m > 
163 
let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in 
164 
let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts) 
165 
in machine_unfold fanin elim_consts m) 
166 
machines 
167  
168 
(* variable substitution for optimizing purposes *) 
169  
170 
(* checks whether an [instr] is skip and can be removed from program *) 
171 
let rec instr_is_skip instr = 
172 
match instr with 
173 
 MLocalAssign (i, LocalVar v) when i = v > true 
174 
 MStateAssign (i, StateVar v) when i = v > true 
175 
 MBranch (g, hl) > List.for_all (fun (_, il) > instrs_are_skip il) hl 
176 
 _ > false 
177 
and instrs_are_skip instrs = 
178 
List.for_all instr_is_skip instrs 
179  
180 
let instr_cons instr cont = 
181 
if instr_is_skip instr then cont else instr::cont 
182  
183 
let rec instr_remove_skip instr cont = 
184 
match instr with 
185 
 MLocalAssign (i, LocalVar v) when i = v > cont 
186 
 MStateAssign (i, StateVar v) when i = v > cont 
187 
 MBranch (g, hl) > MBranch (g, List.map (fun (h, il) > (h, instrs_remove_skip il [])) hl) :: cont 
188 
 _ > instr::cont 
189  
190 
and instrs_remove_skip instrs cont = 
191 
List.fold_right instr_remove_skip instrs cont 
192  
193 
let rec value_replace_var fvar value = 
194 
match value with 
195 
 Cst c > value 
196 
 LocalVar v > LocalVar (fvar v) 
197 
 StateVar v > value 
198 
 Fun (id, args) > Fun (id, List.map (value_replace_var fvar) args) 
199 
 Array vl > Array (List.map (value_replace_var fvar) vl) 
200 
 Access (t, i) > Access(value_replace_var fvar t, i) 
201 
 Power (v, n) > Power(value_replace_var fvar v, n) 
202  
203 
let rec instr_replace_var fvar instr cont = 
204 
match instr with 
205 
 MLocalAssign (i, v) > instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont 
206 
 MStateAssign (i, v) > instr_cons (MStateAssign (i, value_replace_var fvar v)) cont 
207 
 MReset i > instr_cons instr cont 
208 
 MStep (il, i, vl) > instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont 
209 
 MBranch (g, hl) > instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) > (h, instrs_replace_var fvar il [])) hl)) cont 
210  
211 
and instrs_replace_var fvar instrs cont = 
212 
List.fold_right (instr_replace_var fvar) instrs cont 
213  
214 
let step_replace_var fvar step = 
215 
(* Some outputs may have been replaced by locals. 
216 
We then need to rename those outputs 
217 
without changing their clocks, etc *) 
218 
let outputs' = 
219 
List.map (fun o > { o with var_id = (fvar o).var_id }) step.step_outputs in 
220 
let locals' = 
221 
List.fold_left (fun res l > 
222 
let l' = fvar l in 
223 
if List.exists (fun o > o.var_id = l'.var_id) outputs' 
224 
then res 
225 
else Utils.add_cons l' res) 
226 
[] step.step_locals in 
227 
{ step with 
228 
step_checks = List.map (fun (l, v) > (l, value_replace_var fvar v)) step.step_checks; 
229 
step_outputs = outputs'; 
230 
step_locals = locals'; 
231 
step_instrs = instrs_replace_var fvar step.step_instrs []; 
232 
} 
233  
234 
let rec machine_replace_variables fvar m = 
235 
{ m with 
236 
mstep = step_replace_var fvar m.mstep 
237 
} 
238  
239 
let machine_reuse_variables m reuse = 
240 
let fvar v = 
241 
try 
242 
Hashtbl.find reuse v.var_id 
243 
with Not_found > v in 
244 
machine_replace_variables fvar m 
245  
246 
let machines_reuse_variables prog node_schs = 
247 
List.map 
248 
(fun m > 
249 
machine_reuse_variables m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table 
250 
) prog 
251  
252 
let rec instr_assign res instr = 
253 
match instr with 
254 
 MLocalAssign (i, _) > Disjunction.CISet.add i res 
255 
 MStateAssign (i, _) > Disjunction.CISet.add i res 
256 
 MBranch (g, hl) > List.fold_left (fun res (h, b) > instrs_assign res b) res hl 
257 
 MStep (il, _, _) > List.fold_right Disjunction.CISet.add il res 
258 
 _ > res 
259  
260 
and instrs_assign res instrs = 
261 
List.fold_left instr_assign res instrs 
262  
263 
let rec instr_constant_assign var instr = 
264 
match instr with 
265 
 MLocalAssign (i, Cst (Const_tag _)) 
266 
 MStateAssign (i, Cst (Const_tag _)) > i = var 
267 
 MBranch (g, hl) > List.for_all (fun (h, b) > instrs_constant_assign var b) hl 
268 
 _ > false 
269  
270 
and instrs_constant_assign var instrs = 
271 
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 
272  
273 
let rec instr_reduce branches instr1 cont = 
274 
match instr1 with 
275 
 MLocalAssign (_, Cst (Const_tag c)) > instr1 :: (List.assoc c branches @ cont) 
276 
 MStateAssign (_, Cst (Const_tag c)) > instr1 :: (List.assoc c branches @ cont) 
277 
 MBranch (g, hl) > MBranch (g, List.map (fun (h, b) > (h, instrs_reduce branches b [])) hl) :: cont 
278 
 _ > instr1 :: cont 
279  
280 
and instrs_reduce branches instrs cont = 
281 
match instrs with 
282 
 [] > cont 
283 
 [i] > instr_reduce branches i cont 
284 
 i1::i2::q > i1 :: instrs_reduce branches (i2::q) cont 
285  
286 
let rec instrs_fusion instrs = 
287 
match instrs with 
288 
 [] 
289 
 [_] > 
290 
instrs 
291 
 i1::(MBranch (LocalVar v, hl))::q when instr_constant_assign v i1 > 
292 
instr_reduce (List.map (fun (h, b) > h, instrs_fusion b) hl) i1 (instrs_fusion q) 
293 
 i1::(MBranch (StateVar v, hl))::q when instr_constant_assign v i1 > 
294 
instr_reduce (List.map (fun (h, b) > h, instrs_fusion b) hl) i1 (instrs_fusion q) 
295 
 i1::i2::q > 
296 
i1 :: instrs_fusion (i2::q) 
297  
298 
let step_fusion step = 
299 
{ step with 
300 
step_instrs = instrs_fusion step.step_instrs; 
301 
} 
302  
303 
let rec machine_fusion m = 
304 
{ m with 
305 
mstep = step_fusion m.mstep 
306 
} 
307  
308 
let machines_fusion prog = 
309 
List.map machine_fusion prog 
310  
311 
(* Local Variables: *) 
312 
(* compilecommand:"make C .." *) 
313 
(* End: *) 