Project

General

Profile

Revision 53206908 src/optimize_machine.ml

View differences:

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