Revision 3b2bd83d
Added by Teme Kahsai about 8 years ago
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
updating to onera version 30f766a:2016-12-04