Revision 53206908 src/optimize_machine.ml
src/optimize_machine.ml  

26  26  
27  27 
let rec eliminate elim instr = 
28  28 
let e_expr = eliminate_expr elim in 
29 
match instr with 

29 
match instr with 

30 
 MComment _ > instr 

30  31 
 MLocalAssign (i,v) > MLocalAssign (i, e_expr v) 
31  32 
 MStateAssign (i,v) > MStateAssign (i, e_expr v) 
32  33 
 MReset i > instr 
...  ...  
41  42 
) 
42  43 

43  44 
and eliminate_expr elim expr = 
44 
match expr with 

45 
 StateVar v 

45 
match expr.value_desc with 

46  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 unfold_expr_offset m offset expr = 

57 
List.fold_left (fun res > (function Index i > Access(res, value_of_dimension m i)  Field f > failwith "not yet implemented")) expr offset 

58  
59 
let rec simplify_cst_expr m offset cst = 

60 
match offset, cst with 

61 
 [] , _ 

62 
> Cst cst 

63 
 Index i :: q, Const_array cl when Dimension.is_dimension_const i 

64 
> simplify_cst_expr m q (List.nth cl (Dimension.size_const_dimension i)) 

65 
 Index i :: q, Const_array cl 

66 
> unfold_expr_offset m [Index i] (Array (List.map (simplify_cst_expr m q) cl)) 

67 
 Field f :: q, Const_struct fl 

68 
> simplify_cst_expr m q (List.assoc f fl) 

69 
 _ > (Format.eprintf "internal error: Optimize_machine.simplify_cst_expr %a@." Printers.pp_const cst; assert false) 

70  
71 
let simplify_expr_offset m expr = 

72 
let rec simplify offset expr = 

73 
match offset, expr with 

74 
 Field f ::q , _ > failwith "not yet implemented" 

75 
 _ , Fun (id, vl) when Basic_library.is_internal_fun id 

76 
> Fun (id, List.map (simplify offset) vl) 

77 
 _ , Fun _ 

78 
 _ , StateVar _ 

79 
 _ , LocalVar _ > unfold_expr_offset m offset expr 

80 
 _ , Cst cst > simplify_cst_expr m offset cst 

81 
 _ , Access (expr, i) > simplify (Index (dimension_of_value i) :: offset) expr 

82 
 [] , _ > expr 

83 
 Index _ :: q, Power (expr, _) > simplify q expr 

84 
 Index i :: q, Array vl when Dimension.is_dimension_const i 

85 
> simplify q (List.nth vl (Dimension.size_const_dimension i)) 

86 
 Index i :: q, Array vl > unfold_expr_offset m [Index i] (Array (List.map (simplify q) vl)) 

87 
 _ > (Format.eprintf "internal error: Optimize_machine.simplify_expr_offset %a@." pp_val expr; assert false) 

88 
(*Format.eprintf "simplify_expr %a %a = %a@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset pp_val res; res) 

89 
with e > (Format.eprintf "simplify_expr %a %a = <FAIL>@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset; raise e*) 

90 
in simplify [] expr 

91  
92 
let rec simplify_instr_offset m instr = 

93 
match instr with 

94 
 MLocalAssign (v, expr) > MLocalAssign (v, simplify_expr_offset m expr) 

95 
 MStateAssign (v, expr) > MStateAssign (v, simplify_expr_offset m expr) 

96 
 MReset id > instr 

97 
 MStep (outputs, id, inputs) > MStep (outputs, id, List.map (simplify_expr_offset m) inputs) 

98 
 MBranch (cond, brl) 

99 
> MBranch(simplify_expr_offset m cond, List.map (fun (l, il) > l, simplify_instrs_offset m il) brl) 

100  
101 
and simplify_instrs_offset m instrs = 

102 
List.map (simplify_instr_offset m) instrs 

47 
 Fun (id, vl) > {expr with value_desc = Fun (id, List.map (eliminate_expr elim) vl)} 

48 
 Array(vl) > {expr with value_desc = Array(List.map (eliminate_expr elim) vl)} 

49 
 Access(v1, v2) > { expr with value_desc = Access(eliminate_expr elim v1, eliminate_expr elim v2)} 

50 
 Power(v1, v2) > { expr with value_desc = Power(eliminate_expr elim v1, eliminate_expr elim v2)} 

51 
 Cst _  StateVar _ > expr 

103  52  
104  53 
let is_scalar_const c = 
105  54 
match c with 
106 
 Const_int _ 

107  55 
 Const_real _ 
108 
 Const_float _


56 
 Const_int _


109  57 
 Const_tag _ > true 
110  58 
 _ > false 
111  59  
112 
(* An instruction v = expr may (and will) be unfolded iff: 

113 
 either expr is atomic 

114 
(no complex expressions, only const, vars and array/struct accesses) 

115 
 or v has a fanin <= 1 (used at most once) 

116 
*) 

117 
let is_unfoldable_expr fanin expr = 

118 
let rec unfold_const offset cst = 

119 
match offset, cst with 

120 
 _ , Const_int _ 

121 
 _ , Const_real _ 

122 
 _ , Const_float _ 

123 
 _ , Const_tag _ > true 

124 
 Field f :: q, Const_struct fl > unfold_const q (List.assoc f fl) 

125 
 [] , Const_struct _ > false 

126 
 Index i :: q, Const_array cl when Dimension.is_dimension_const i 

127 
> unfold_const q (List.nth cl (Dimension.size_const_dimension i)) 

128 
 _ , Const_array _ > false 

129 
 _ > assert false in 

130 
let rec unfold offset expr = 

131 
match offset, expr with 

132 
 _ , Cst cst > unfold_const offset cst 

133 
 _ , LocalVar _ 

134 
 _ , StateVar _ > true 

135 
 [] , Power _ 

136 
 [] , Array _ > false 

137 
 Index i :: q, Power (v, _) > unfold q v 

138 
 Index i :: q, Array vl when Dimension.is_dimension_const i 

139 
> unfold q (List.nth vl (Dimension.size_const_dimension i)) 

140 
 _ , Array _ > false 

141 
 _ , Access (v, i) > unfold (Index (dimension_of_value i) :: offset) v 

142 
 _ , Fun (id, vl) when fanin < 2 && Basic_library.is_internal_fun id 

143 
> List.for_all (unfold offset) vl 

144 
 _ , Fun _ > false 

145 
 _ > assert false 

146 
in unfold [] expr 

60 
let basic_unfoldable_expr expr = 

61 
match expr.value_desc with 

62 
 Cst c when is_scalar_const c > true 

63 
 LocalVar _ 

64 
 StateVar _ > true 

65 
 _ > false 

147  66  
148 
let unfoldable_assign fanin v expr = 

67 
let rec basic_unfoldable_assign fanin v expr =


149  68 
try 
150  69 
let d = Hashtbl.find fanin v.var_id 
151 
in is_unfoldable_expr d expr 

152 
with Not_found > false 

153 
(* 

154 
let unfoldable_assign fanin v expr = 

155 
try 

156 
let d = Hashtbl.find fanin v.var_id 

157 
in is_basic_expr expr  

158 
match expr with 

159 
 Cst c when d < 2 > true 

160 
 Fun (id, _) when d < 2 && Basic_library.is_internal_fun id > true 

70 
in match expr.value_desc with 

71 
 Cst c when is_scalar_const c > true 

72 
 Cst c when d < 2 > true 

73 
 LocalVar _ 

74 
 StateVar _ > true 

75 
 Fun (id, [a]) when d < 2 && Basic_library.is_value_internal_fun expr > basic_unfoldable_assign fanin v a 

161  76 
 _ > false 
162  77 
with Not_found > false 
163 
*) 

78  
79 
let unfoldable_assign fanin v expr = 

80 
(if !Options.mpfr then Mpfr.unfoldable_value expr else true) 

81 
&& basic_unfoldable_assign fanin v expr 

82  
164  83 
let merge_elim elim1 elim2 = 
165  84 
let merge k e1 e2 = 
166  85 
match e1, e2 with 
...  ...  
189  108 
(* Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*) 
190  109 
match instr with 
191  110 
(* Simple cases*) 
192 
 MStep([v], id, vl) when Basic_library.is_internal_fun id


193 
> instr_unfold fanin instrs elim (MLocalAssign (v, Fun (id, vl)))


111 
 MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type)


112 
> instr_unfold fanin instrs elim (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type))


194  113 
 MLocalAssign(v, expr) when unfoldable_assign fanin v expr 
195  114 
> (IMap.add v.var_id expr elim, instrs) 
196  115 
 MBranch(g, hl) when false 
...  ...  
225  144 
(*Log.report ~level:1 (fun fmt > Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*) 
226  145 
let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in 
227  146 
let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in 
228 
let instrs = simplify_instrs_offset machine instrs in


147 
(*let instrs = simplify_instrs_offset machine instrs in*)


229  148 
let checks = List.map (fun (loc, check) > loc, eliminate_expr elim_vars check) machine.mstep.step_checks in 
230  149 
let locals = List.filter (fun v > not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in 
231  150 
let minstances = List.map (static_call_unfold elim_consts) machine.minstances in 
...  ...  
242  161 
mconst = mconst; 
243  162 
minstances = minstances; 
244  163 
mcalls = mcalls; 
245 
} 

164 
}, 

165 
elim_vars 

246  166  
247  167 
let instr_of_const top_const = 
248  168 
let const = const_of_top top_const in 
249  169 
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 
250  170 
let vdecl = { vdecl with var_type = const.const_type } 
251 
in MLocalAssign (vdecl, Cst const.const_value)


171 
in MLocalAssign (vdecl, mk_val (Cst const.const_value) vdecl.var_type)


252  172  
253  173 
let machines_unfold consts node_schs machines = 
254 
List.map 

255 
(fun m > 

256 
let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in 

257 
let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts) 

258 
in machine_unfold fanin elim_consts m) 

174 
List.fold_right (fun m (machines, removed) > 

175 
let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in 

176 
let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts) in 

177 
let (m, removed_m) = machine_unfold fanin elim_consts m in 

178 
(m::machines, IMap.add m.mname.node_id removed_m removed) 

179 
) 

259  180 
machines 
181 
([], IMap.empty) 

260  182  
261  183 
let get_assign_lhs instr = 
262  184 
match instr with 
263 
 MLocalAssign(v, _) > LocalVar v


264 
 MStateAssign(v, _) > StateVar v


185 
 MLocalAssign(v, e) > mk_val (LocalVar v) e.value_type


186 
 MStateAssign(v, e) > mk_val (StateVar v) e.value_type


265  187 
 _ > assert false 
266  188  
267  189 
let get_assign_rhs instr = 
...  ...  
277  199 
 _ > false 
278  200  
279  201 
let mk_assign v e = 
280 
match v with 

202 
match v.value_desc with


281  203 
 LocalVar v > MLocalAssign(v, e) 
282  204 
 StateVar v > MStateAssign(v, e) 
283  205 
 _ > assert false 
...  ...  
315  237 
let e = get_assign_rhs instr in 
316  238 
try 
317  239 
let instr' = List.find (fun instr' > is_assign instr' && get_assign_rhs instr' = e) instrs in 
318 
match v with 

240 
match v.value_desc with


319  241 
 LocalVar v > 
320  242 
IMap.add v.var_id (get_assign_lhs instr') subst, instrs 
321  243 
 StateVar v > 
322 
(match get_assign_lhs instr' with 

244 
let lhs' = get_assign_lhs instr' in 

245 
let typ' = lhs'.value_type in 

246 
(match lhs'.value_desc with 

323  247 
 LocalVar v' > 
324 
let instr = eliminate subst (mk_assign (StateVar v) (LocalVar v')) in


248 
let instr = eliminate subst (mk_assign (mk_val (StateVar v) typ') (mk_val (LocalVar v') typ')) in


325  249 
subst, instr :: instrs 
326  250 
 StateVar v' > 
327 
let subst_v' = IMap.add v'.var_id (StateVar v) IMap.empty in


328 
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


329 
IMap.add v'.var_id (StateVar v) subst, instr :: instrs'


251 
let subst_v' = IMap.add v'.var_id (mk_val (StateVar v) typ') IMap.empty in


252 
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 

253 
IMap.add v'.var_id (mk_val (StateVar v) typ') subst, instr :: instrs'


330  254 
 _ > assert false) 
331  255 
 _ > assert false 
332  256 
with Not_found > subst, instr :: instrs 
...  ...  
341  265 
let rec instr_cse (subst, instrs) instr = 
342  266 
match instr with 
343  267 
(* Simple cases*) 
344 
 MStep([v], id, vl) when Basic_library.is_internal_fun id


345 
> instr_cse (subst, instrs) (MLocalAssign (v, Fun (id, vl)))


346 
 MLocalAssign(v, expr) when is_unfoldable_expr 2 expr


268 
 MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type)


269 
> instr_cse (subst, instrs) (MLocalAssign (v, (mk_val (Fun (id, vl)) v.var_type)))


270 
 MLocalAssign(v, expr) when basic_unfoldable_expr expr


347  271 
> (IMap.add v.var_id expr subst, instr :: instrs) 
348  272 
 _ when is_assign instr 
349  273 
> subst_instr subst instrs instr 
...  ...  
384  308 
(* checks whether an [instr] is skip and can be removed from program *) 
385  309 
let rec instr_is_skip instr = 
386  310 
match instr with 
387 
 MLocalAssign (i, LocalVar v) when i = v > true


388 
 MStateAssign (i, StateVar v) when i = v > true


311 
 MLocalAssign (i, { value_desc = (LocalVar v) ; _}) when i = v > true


312 
 MStateAssign (i, { value_desc = StateVar v; _}) when i = v > true


389  313 
 MBranch (g, hl) > List.for_all (fun (_, il) > instrs_are_skip il) hl 
390  314 
 _ > false 
391  315 
and instrs_are_skip instrs = 
...  ...  
396  320  
397  321 
let rec instr_remove_skip instr cont = 
398  322 
match instr with 
399 
 MLocalAssign (i, LocalVar v) when i = v > cont


400 
 MStateAssign (i, StateVar v) when i = v > cont


323 
 MLocalAssign (i, { value_desc = LocalVar v; _ }) when i = v > cont


324 
 MStateAssign (i, { value_desc = StateVar v; _ }) when i = v > cont


401  325 
 MBranch (g, hl) > MBranch (g, List.map (fun (h, il) > (h, instrs_remove_skip il [])) hl) :: cont 
402  326 
 _ > instr::cont 
403  327  
...  ...  
405  329 
List.fold_right instr_remove_skip instrs cont 
406  330  
407  331 
let rec value_replace_var fvar value = 
408 
match value with 

332 
match value.value_desc with


409  333 
 Cst c > value 
410 
 LocalVar v > LocalVar (fvar v)


334 
 LocalVar v > { value with value_desc = LocalVar (fvar v) }


411  335 
 StateVar v > value 
412 
 Fun (id, args) > Fun (id, List.map (value_replace_var fvar) args)


413 
 Array vl > Array (List.map (value_replace_var fvar) vl)


414 
 Access (t, i) > Access(value_replace_var fvar t, i)


415 
 Power (v, n) > Power(value_replace_var fvar v, n)


336 
 Fun (id, args) > { value with value_desc = Fun (id, List.map (value_replace_var fvar) args) }


337 
 Array vl > { value with value_desc = Array (List.map (value_replace_var fvar) vl)}


338 
 Access (t, i) > { value with value_desc = Access(value_replace_var fvar t, i)}


339 
 Power (v, n) > { value with value_desc = Power(value_replace_var fvar v, n)}


416  340  
417  341 
let rec instr_replace_var fvar instr cont = 
418  342 
match instr with 
343 
 MComment _ > instr_cons instr cont 

419  344 
 MLocalAssign (i, v) > instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont 
420  345 
 MStateAssign (i, v) > instr_cons (MStateAssign (i, value_replace_var fvar v)) cont 
421  346 
 MReset i > instr_cons instr cont 
...  ...  
457  382 
with Not_found > v in 
458  383 
machine_replace_variables fvar m 
459  384  
460 
let machines_reuse_variables prog node_schs =


385 
let machines_reuse_variables prog reuse_tables =


461  386 
List.map 
462  387 
(fun m > 
463 
machine_reuse_variables m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table


388 
machine_reuse_variables m (Utils.IMap.find m.mname.node_id reuse_tables)


464  389 
) prog 
465  390  
466  391 
let rec instr_assign res instr = 
...  ...  
476  401  
477  402 
let rec instr_constant_assign var instr = 
478  403 
match instr with 
479 
 MLocalAssign (i, Cst (Const_tag _))


480 
 MStateAssign (i, Cst (Const_tag _)) > i = var


404 
 MLocalAssign (i, { value_desc = Cst (Const_tag _); _ })


405 
 MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) > i = var


481  406 
 MBranch (g, hl) > List.for_all (fun (h, b) > instrs_constant_assign var b) hl 
482  407 
 _ > false 
483  408  
...  ...  
486  411  
487  412 
let rec instr_reduce branches instr1 cont = 
488  413 
match instr1 with 
489 
 MLocalAssign (_, Cst (Const_tag c)) > instr1 :: (List.assoc c branches @ cont)


490 
 MStateAssign (_, Cst (Const_tag c)) > instr1 :: (List.assoc c branches @ cont)


414 
 MLocalAssign (_, { value_desc = Cst (Const_tag c); _}) > instr1 :: (List.assoc c branches @ cont)


415 
 MStateAssign (_, { value_desc = Cst (Const_tag c); _}) > instr1 :: (List.assoc c branches @ cont)


491  416 
 MBranch (g, hl) > MBranch (g, List.map (fun (h, b) > (h, instrs_reduce branches b [])) hl) :: cont 
492  417 
 _ > instr1 :: cont 
493  418  
...  ...  
502  427 
 [] 
503  428 
 [_] > 
504  429 
instrs 
505 
 i1::(MBranch (LocalVar v, hl))::q when instr_constant_assign v i1 >


430 
 i1::(MBranch ({ value_desc = LocalVar v; _}, hl))::q when instr_constant_assign v i1 >


506  431 
instr_reduce (List.map (fun (h, b) > h, instrs_fusion b) hl) i1 (instrs_fusion q) 
507 
 i1::(MBranch (StateVar v, hl))::q when instr_constant_assign v i1 >


432 
 i1::(MBranch ({ value_desc = StateVar v; _}, hl))::q when instr_constant_assign v i1 >


508  433 
instr_reduce (List.map (fun (h, b) > h, instrs_fusion b) hl) i1 (instrs_fusion q) 
509  434 
 i1::i2::q > 
510  435 
i1 :: instrs_fusion (i2::q) 
Also available in: Unified diff