Project

General

Profile

Revision 3b2bd83d 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
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