Revision 3b2bd83d 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 
34 
 MNoReset i > instr 

33  35 
 MStep (il, i, vl) > MStep(il, i, List.map e_expr vl) 
34  36 
 MBranch (g,hl) > 
35  37 
MBranch 
...  ...  
41  43 
) 
42  44 

43  45 
and eliminate_expr elim expr = 
44 
match expr with 

45 
 StateVar v 

46 
match expr.value_desc with 

46  47 
 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 

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


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


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


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


52 
 Cst _  StateVar _ > expr


52  53  
53  54 
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 
Dimension.expr_replace_expr 

56 
(fun v > try 

57 
dimension_of_value (IMap.find v elim) 

58 
with Not_found > mkdim_ident dim.dim_loc v) 

59 
dim 

55  60  
56  61 
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 

62 
List.fold_left 

63 
(fun res > (function  Index i > mk_val (Access (res, value_of_dimension m i)) 

64 
(Types.array_element_type res.value_type) 

65 
 Field f > Format.eprintf "internal error: not yet implemented !"; assert false)) 

66 
expr offset 

58  67  
59 
let rec simplify_cst_expr m offset cst = 

68 
let rec simplify_cst_expr m offset typ cst =


60  69 
match offset, cst with 
61  70 
 [] , _ 
62 
> Cst cst


71 
> mk_val (Cst cst) typ


63  72 
 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)) 

73 
> let elt_typ = Types.array_element_type typ in 

74 
simplify_cst_expr m q elt_typ (List.nth cl (Dimension.size_const_dimension i)) 

65  75 
 Index i :: q, Const_array cl 
66 
> unfold_expr_offset m [Index i] (Array (List.map (simplify_cst_expr m q) cl)) 

76 
> let elt_typ = Types.array_element_type typ in 

77 
unfold_expr_offset m [Index i] (mk_val (Array (List.map (simplify_cst_expr m q elt_typ) cl)) typ) 

67  78 
 Field f :: q, Const_struct fl 
68 
> simplify_cst_expr m q (List.assoc f fl) 

79 
> let fld_typ = Types.struct_field_type typ f in 

80 
simplify_cst_expr m q fld_typ (List.assoc f fl) 

69  81 
 _ > (Format.eprintf "internal error: Optimize_machine.simplify_cst_expr %a@." Printers.pp_const cst; assert false) 
70  82  
71  83 
let simplify_expr_offset m expr = 
72  84 
let rec simplify offset expr = 
73 
match offset, expr with 

85 
match offset, expr.value_desc with


74  86 
 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)


87 
 _ , Fun (id, vl) when Basic_library.is_value_internal_fun expr


88 
> mk_val (Fun (id, List.map (simplify offset) vl)) expr.value_type


77  89 
 _ , Fun _ 
78  90 
 _ , StateVar _ 
79  91 
 _ , LocalVar _ > unfold_expr_offset m offset expr 
80 
 _ , Cst cst > simplify_cst_expr m offset cst 

92 
 _ , Cst cst > simplify_cst_expr m offset expr.value_type cst


81  93 
 _ , Access (expr, i) > simplify (Index (dimension_of_value i) :: offset) expr 
82  94 
 [] , _ > expr 
83  95 
 Index _ :: q, Power (expr, _) > simplify q expr 
84  96 
 Index i :: q, Array vl when Dimension.is_dimension_const i 
85  97 
> 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) 

98 
 Index i :: q, Array vl > unfold_expr_offset m [Index i] (mk_val (Array (List.map (simplify q) vl)) expr.value_type) 

88  99 
(*Format.eprintf "simplify_expr %a %a = %a@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset pp_val res; res) 
89  100 
with e > (Format.eprintf "simplify_expr %a %a = <FAIL>@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset; raise e*) 
90  101 
in simplify [] expr 
...  ...  
94  105 
 MLocalAssign (v, expr) > MLocalAssign (v, simplify_expr_offset m expr) 
95  106 
 MStateAssign (v, expr) > MStateAssign (v, simplify_expr_offset m expr) 
96  107 
 MReset id > instr 
108 
 MNoReset id > instr 

97  109 
 MStep (outputs, id, inputs) > MStep (outputs, id, List.map (simplify_expr_offset m) inputs) 
98  110 
 MBranch (cond, brl) 
99  111 
> MBranch(simplify_expr_offset m cond, List.map (fun (l, il) > l, simplify_instrs_offset m il) brl) 
112 
 MComment _ > instr 

100  113  
101  114 
and simplify_instrs_offset m instrs = 
102  115 
List.map (simplify_instr_offset m) instrs 
103  116  
104  117 
let is_scalar_const c = 
105  118 
match c with 
106 
 Const_int _ 

107  119 
 Const_real _ 
108 
 Const_float _


120 
 Const_int _


109  121 
 Const_tag _ > true 
110  122 
 _ > false 
111  123  
...  ...  
119  131 
match offset, cst with 
120  132 
 _ , Const_int _ 
121  133 
 _ , Const_real _ 
122 
 _ , Const_float _ 

123  134 
 _ , Const_tag _ > true 
124  135 
 Field f :: q, Const_struct fl > unfold_const q (List.assoc f fl) 
125  136 
 [] , Const_struct _ > false 
...  ...  
128  139 
 _ , Const_array _ > false 
129  140 
 _ > assert false in 
130  141 
let rec unfold offset expr = 
131 
match offset, expr with 

142 
match offset, expr.value_desc with


132  143 
 _ , Cst cst > unfold_const offset cst 
133  144 
 _ , LocalVar _ 
134  145 
 _ , StateVar _ > true 
...  ...  
139  150 
> unfold q (List.nth vl (Dimension.size_const_dimension i)) 
140  151 
 _ , Array _ > false 
141  152 
 _ , Access (v, i) > unfold (Index (dimension_of_value i) :: offset) v 
142 
 _ , Fun (id, vl) when fanin < 2 && Basic_library.is_internal_fun id


153 
 _ , Fun (id, vl) when fanin < 2 && Basic_library.is_value_internal_fun expr


143  154 
> List.for_all (unfold offset) vl 
144  155 
 _ , Fun _ > false 
145  156 
 _ > assert false 
146  157 
in unfold [] expr 
147  158  
148 
let unfoldable_assign fanin v expr = 

159 
let basic_unfoldable_assign fanin v expr =


149  160 
try 
150  161 
let d = Hashtbl.find fanin v.var_id 
151  162 
in is_unfoldable_expr d expr 
152  163 
with Not_found > false 
153 
(* 

164  
154  165 
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 

161 
 _ > false 

162 
with Not_found > false 

163 
*) 

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

167 
&& basic_unfoldable_assign fanin v expr 

168  
164  169 
let merge_elim elim1 elim2 = 
165  170 
let merge k e1 e2 = 
166  171 
match e1, e2 with 
...  ...  
189  194 
(* Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*) 
190  195 
match instr with 
191  196 
(* 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)))


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


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


194  199 
 MLocalAssign(v, expr) when unfoldable_assign fanin v expr 
195  200 
> (IMap.add v.var_id expr elim, instrs) 
196  201 
 MBranch(g, hl) when false 
...  ...  
242  247 
mconst = mconst; 
243  248 
minstances = minstances; 
244  249 
mcalls = mcalls; 
245 
} 

250 
}, 

251 
elim_vars 

246  252  
247  253 
let instr_of_const top_const = 
248  254 
let const = const_of_top top_const in 
249  255 
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  256 
let vdecl = { vdecl with var_type = const.const_type } 
251 
in MLocalAssign (vdecl, Cst const.const_value)


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


252  258  
253  259 
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) 

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

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

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

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

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

265 
) 

259  266 
machines 
267 
([], IMap.empty) 

260  268  
261  269 
let get_assign_lhs instr = 
262  270 
match instr with 
263 
 MLocalAssign(v, _) > LocalVar v


264 
 MStateAssign(v, _) > StateVar v


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


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


265  273 
 _ > assert false 
266  274  
267  275 
let get_assign_rhs instr = 
...  ...  
277  285 
 _ > false 
278  286  
279  287 
let mk_assign v e = 
280 
match v with 

288 
match v.value_desc with


281  289 
 LocalVar v > MLocalAssign(v, e) 
282  290 
 StateVar v > MStateAssign(v, e) 
283  291 
 _ > assert false 
...  ...  
315  323 
let e = get_assign_rhs instr in 
316  324 
try 
317  325 
let instr' = List.find (fun instr' > is_assign instr' && get_assign_rhs instr' = e) instrs in 
318 
match v with 

326 
match v.value_desc with


319  327 
 LocalVar v > 
320  328 
IMap.add v.var_id (get_assign_lhs instr') subst, instrs 
321 
 StateVar v > 

322 
(match get_assign_lhs instr' with 

329 
 StateVar stv > 

330 
let lhs = get_assign_lhs instr' in 

331 
(match lhs.value_desc with 

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


333 
let instr = eliminate subst (mk_assign v lhs) in


325  334 
subst, instr :: instrs 
326 
 StateVar v' > 

327 
let subst_v' = IMap.add v'.var_id (StateVar v) IMap.empty in


335 
 StateVar stv' >


336 
let subst_v' = IMap.add stv'.var_id v IMap.empty in


328  337 
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'


338 
IMap.add stv'.var_id v subst, instr :: instrs'


330  339 
 _ > assert false) 
331  340 
 _ > assert false 
332  341 
with Not_found > subst, instr :: instrs 
...  ...  
341  350 
let rec instr_cse (subst, instrs) instr = 
342  351 
match instr with 
343  352 
(* Simple cases*) 
344 
 MStep([v], id, vl) when Basic_library.is_internal_fun id 

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


353 
 MStep([v], id, vl) when Basic_library.is_internal_fun id (List.map (fun v > v.value_type) vl)


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


346  355 
 MLocalAssign(v, expr) when is_unfoldable_expr 2 expr 
347  356 
> (IMap.add v.var_id expr subst, instr :: instrs) 
348  357 
 _ when is_assign instr 
...  ...  
384  393 
(* checks whether an [instr] is skip and can be removed from program *) 
385  394 
let rec instr_is_skip instr = 
386  395 
match instr with 
387 
 MLocalAssign (i, LocalVar v) when i = v > true


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


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


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


389  398 
 MBranch (g, hl) > List.for_all (fun (_, il) > instrs_are_skip il) hl 
390  399 
 _ > false 
391  400 
and instrs_are_skip instrs = 
...  ...  
396  405  
397  406 
let rec instr_remove_skip instr cont = 
398  407 
match instr with 
399 
 MLocalAssign (i, LocalVar v) when i = v > cont


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


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


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


401  410 
 MBranch (g, hl) > MBranch (g, List.map (fun (h, il) > (h, instrs_remove_skip il [])) hl) :: cont 
402  411 
 _ > instr::cont 
403  412  
...  ...  
405  414 
List.fold_right instr_remove_skip instrs cont 
406  415  
407  416 
let rec value_replace_var fvar value = 
408 
match value with 

417 
match value.value_desc with


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


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


411  420 
 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)


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


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


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


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


416  425  
417  426 
let rec instr_replace_var fvar instr cont = 
418  427 
match instr with 
428 
 MComment _ > instr_cons instr cont 

419  429 
 MLocalAssign (i, v) > instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont 
420  430 
 MStateAssign (i, v) > instr_cons (MStateAssign (i, value_replace_var fvar v)) cont 
421  431 
 MReset i > instr_cons instr cont 
432 
 MNoReset i > instr_cons instr cont 

422  433 
 MStep (il, i, vl) > instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont 
423  434 
 MBranch (g, hl) > instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) > (h, instrs_replace_var fvar il [])) hl)) cont 
424  435  
...  ...  
457  468 
with Not_found > v in 
458  469 
machine_replace_variables fvar m 
459  470  
460 
let machines_reuse_variables prog node_schs =


471 
let machines_reuse_variables prog reuse_tables =


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


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


464  475 
) prog 
465  476  
466  477 
let rec instr_assign res instr = 
...  ...  
476  487  
477  488 
let rec instr_constant_assign var instr = 
478  489 
match instr with 
479 
 MLocalAssign (i, Cst (Const_tag _))


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


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


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


481  492 
 MBranch (g, hl) > List.for_all (fun (h, b) > instrs_constant_assign var b) hl 
482  493 
 _ > false 
483  494  
...  ...  
486  497  
487  498 
let rec instr_reduce branches instr1 cont = 
488  499 
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)


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


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


491  502 
 MBranch (g, hl) > MBranch (g, List.map (fun (h, b) > (h, instrs_reduce branches b [])) hl) :: cont 
492  503 
 _ > instr1 :: cont 
493  504  
...  ...  
502  513 
 [] 
503  514 
 [_] > 
504  515 
instrs 
505 
 i1::(MBranch (LocalVar v, hl))::q when instr_constant_assign v i1 >


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


506  517 
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 >


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


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