Project

General

Profile

Revision 8446bf03 src/plugins/salsa/machine_salsa_opt.ml

View differences:

src/plugins/salsa/machine_salsa_opt.ml
2 2
(* We try to avoid opening modules here *)
3 3
module ST = Salsa.Types
4 4
module SDT = SalsaDatatypes
5
module LT = LustreSpec
5
module LT = Lustre_types
6 6
module MC = Machine_code
7 7

  
8 8
(* Datatype for Salsa: FormalEnv, Ranges, Var set ... *)
......
29 29
(******************************************************************)    
30 30

  
31 31
(* Returns the set of vars that appear in the expression *)
32
let rec get_expr_real_vars e = 
33
  match e.LT.value_desc with
34
  | LT.LocalVar v | LT.StateVar v when Types.is_real_type v.LT.var_type -> Vars.singleton v
35
  | LT.LocalVar _| LT.StateVar _
36
  | LT.Cst _ -> Vars.empty 
37
  | LT.Fun (_, args) -> 
32
let rec get_expr_real_vars e =
33
  let open MT in 
34
  match e.value_desc with
35
  | LocalVar v | StateVar v when Types.is_real_type v.LT.var_type -> Vars.singleton v
36
  | LocalVar _| StateVar _
37
  | Cst _ -> Vars.empty 
38
  | Fun (_, args) -> 
38 39
    List.fold_left 
39 40
      (fun acc e -> Vars.union acc (get_expr_real_vars e)) 
40 41
      Vars.empty args
41
  | LT.Array _
42
  | LT.Access _
43
  | LT.Power _ -> assert false 
42
  | Array _
43
  | Access _
44
  | Power _ -> assert false 
44 45

  
45 46
(* Extract the variables to appear as free variables in expressions (lhs) *)
46 47
let rec get_read_vars instrs =
48
  let open MT in
47 49
  match instrs with
48 50
    [] -> Vars.empty
49 51
  | i::tl -> (
50 52
    let vars_tl = get_read_vars tl in 
51 53
    match Corelang.get_instr_desc i with
52
    | LT.MLocalAssign(_,e) 
53
    | LT.MStateAssign(_,e) -> Vars.union (get_expr_real_vars e) vars_tl
54
    | LT.MStep(_, _, el) -> List.fold_left (fun accu e -> Vars.union (get_expr_real_vars e) accu) vars_tl el
55
    | LT.MBranch(e, branches) -> (
54
    | MLocalAssign(_,e) 
55
    | MStateAssign(_,e) -> Vars.union (get_expr_real_vars e) vars_tl
56
    | MStep(_, _, el) -> List.fold_left (fun accu e -> Vars.union (get_expr_real_vars e) accu) vars_tl el
57
    | MBranch(e, branches) -> (
56 58
      let vars = Vars.union (get_expr_real_vars e) vars_tl in
57 59
      List.fold_left (fun vars (_, b) -> Vars.union vars (get_read_vars b) ) vars branches
58 60
    )
59
    | LT.MReset _ 
60
    | LT.MNoReset _ 
61
    | LT.MComment _ -> Vars.empty  
61
    | MReset _ 
62
    | MNoReset _ 
63
    | MComment _ -> Vars.empty  
62 64
  )
63 65

  
64 66
let rec get_written_vars instrs =
67
  let open MT in
65 68
  match instrs with
66 69
    [] -> Vars.empty
67 70
  | i::tl -> (
68 71
    let vars_tl = get_written_vars tl in 
69 72
    match Corelang.get_instr_desc i with
70
    | LT.MLocalAssign(v,_) 
71
    | LT.MStateAssign(v,_) -> Vars.add v vars_tl 
72
    | LT.MStep(vdl, _, _) -> List.fold_left (fun accu v -> Vars.add v accu) vars_tl vdl
73
    | LT.MBranch(_, branches) -> (
73
    | MLocalAssign(v,_) 
74
    | MStateAssign(v,_) -> Vars.add v vars_tl 
75
    | MStep(vdl, _, _) -> List.fold_left (fun accu v -> Vars.add v accu) vars_tl vdl
76
    | MBranch(_, branches) -> (
74 77
      List.fold_left (fun vars (_, b) -> Vars.union vars (get_written_vars b) ) vars_tl branches
75 78
    )
76
    | LT.MReset _ 
77
    | LT.MNoReset _ 
78
    | LT.MComment _ -> Vars.empty    
79
    | MReset _ 
80
    | MNoReset _ 
81
    | MComment _ -> Vars.empty    
79 82
  )
80 83

  
81 84

  
82 85
(* Optimize a given expression. It returns another expression and a computed range. *)
83
let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e : LT.value_t * RangesInt.t option = 
86
let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e : MT.value_t * RangesInt.t option = 
84 87
  let rec opt_expr ranges formalEnv e =
85
    match e.LT.value_desc with
86
    | LT.Cst cst ->
88
    let open MT in
89
    match e.value_desc with
90
    | Cst cst ->
87 91
      (* Format.eprintf "optmizing constant expr @ "; *)
88 92
      (* the expression is a constant, we optimize it directly if it is a real
89 93
  	 constant *)
......
91 95
      if Types.is_real_type typ then 
92 96
	opt_num_expr ranges formalEnv e 
93 97
      else e, None
94
    | LT.LocalVar v
95
    | LT.StateVar v -> 
98
    | LocalVar v
99
    | StateVar v -> 
96 100
      if not (Vars.mem v printed_vars) && 
97 101
	(* TODO xAvier: comment recuperer le type de l'expression? Parfois e.value_type vaut 'd *)
98
	(Types.is_real_type e.LT.value_type ||  Types.is_real_type v.LT.var_type) 
102
	(Types.is_real_type e.value_type ||  Types.is_real_type v.LT.var_type) 
99 103
      then
100 104
	opt_num_expr ranges formalEnv e 
101 105
      else 
......
103 107
    (* (\* optimize only numerical vars *\) *)
104 108
    (* if Type_predef.is_real_type v.LT.var_type then opt_num_expr ranges formalEnv e *)
105 109
    (* else e, None *)
106
    | LT.Fun (fun_id, args) -> (
110
    | Fun (fun_id, args) -> (
107 111
      (* necessarily, this is a basic function (ie. + - * / && || mod ... ) *)
108 112
      (* if the return type is real then optimize it, otherwise call recusrsively on arguments *)
109
      if Types.is_real_type e.LT.value_type then
113
      if Types.is_real_type e.value_type then
110 114
	opt_num_expr ranges formalEnv e 
111 115
      else (
112 116
	(* We do not care for computed local ranges. *)
113 117
  	let args' = List.map (fun arg -> let arg', _ = opt_expr ranges formalEnv arg in arg') args in
114
  	{ e with LT.value_desc = LT.Fun(fun_id, args')}, None	  
118
  	{ e with value_desc = Fun(fun_id, args')}, None	  
115 119
      )
116 120
    )
117
    | LT.Array _
118
    | LT.Access _
119
    | LT.Power _ -> assert false  
121
    | Array _
122
    | Access _
123
    | Power _ -> assert false  
120 124
  and opt_num_expr ranges formalEnv e = 
121 125
     (* if !debug then Format.eprintf "Optimizing expression %a with Salsa@ " MC.pp_val e;  *)
122 126
    let fresh_id = "toto"  in (* TODO more meaningful name *)
......
237 241
	let e, r = optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv v_def in
238 242
	let instr_desc = 
239 243
	  if try (get_var vars_env v.LT.var_id).is_local with Not_found -> assert false then
240
	    LT.MLocalAssign(v, e)
244
	    MT.MLocalAssign(v, e)
241 245
	  else
242
	    LT.MStateAssign(v, e)
246
	    MT.MStateAssign(v, e)
243 247
	in
244 248
	(Corelang.mkinstr instr_desc)::accu_instr, 
245 249
	(match r with 
......
283 287
       Format.eprintf "Hdlist@.";
284 288
       let hd_instrs, ranges, formalEnv, printed_vars, vars_to_print =
285 289
	 match Corelang.get_instr_desc hd_instr with 
286
	 | LT.MLocalAssign(vd,vt) when Types.is_real_type vd.LT.var_type  && not (Vars.mem vd vars_to_print) -> 
290
	 | MT.MLocalAssign(vd,vt) when Types.is_real_type vd.LT.var_type  && not (Vars.mem vd vars_to_print) -> 
287 291
       Format.eprintf "local assign@.";
288 292
	    (* LocalAssign are injected into formalEnv *)
289 293
	    (* if !debug then Format.eprintf "Registering local assign %a@ " MC.pp_instr hd_instr; *)
......
295 299
	    printed_vars,              (* no new printed vars *)
296 300
	    vars_to_print              (* no more or less variables to print *)
297 301
	      
298
	 | LT.MLocalAssign(vd,vt) when Types.is_real_type vd.LT.var_type && Vars.mem vd vars_to_print ->
302
	 | MT.MLocalAssign(vd,vt) when Types.is_real_type vd.LT.var_type && Vars.mem vd vars_to_print ->
299 303
       Format.eprintf "local assign 2@.";
300 304

  
301 305
            (* if !debug then Format.eprintf "Registering and producing state assign %a@ " MC.pp_instr hd_instr; *)
......
314 318
	    Vars.add vd printed_vars,        (* adding vd to new printed vars *)
315 319
	    Vars.remove vd vars_to_print     (* removed vd from variables to print *)
316 320

  
317
	 | LT.MStateAssign(vd,vt) when Types.is_real_type vd.LT.var_type (* && Vars.mem vd vars_to_print  *)-> 
321
	 | MT.MStateAssign(vd,vt) when Types.is_real_type vd.LT.var_type (* && Vars.mem vd vars_to_print  *)-> 
318 322
	    Format.eprintf "state assign of real type@.";
319 323

  
320 324
	    (* StateAssign are produced since they are required by the function. We still
......
335 339
	    Vars.add vd printed_vars,        (* adding vd to new printed vars *)
336 340
	    Vars.remove vd vars_to_print     (* removed vd from variables to print *)
337 341

  
338
	 | (LT.MLocalAssign(vd,vt) | LT.MStateAssign(vd,vt))  ->
342
	 | (MT.MLocalAssign(vd,vt) | MT.MStateAssign(vd,vt))  ->
339 343
	    Format.eprintf "other assign %a@." MC.pp_instr hd_instr;
340 344

  
341 345
	    (* We have to produce the instruction. But we may have to produce as
......
353 357
	    let vt', _ = optimize_expr nodename m constEnv (Vars.union required_vars printed_vars) vars_env ranges formalEnv vt in
354 358
	    let new_instr = 
355 359
	      match Corelang.get_instr_desc hd_instr with
356
	      | LT.MLocalAssign _ -> Corelang.update_instr_desc hd_instr (LT.MLocalAssign(vd,vt'))
357
	      | _ -> Corelang.update_instr_desc hd_instr (LT.MStateAssign(vd,vt'))
360
	      | MT.MLocalAssign _ -> Corelang.update_instr_desc hd_instr (MT.MLocalAssign(vd,vt'))
361
	      | _ -> Corelang.update_instr_desc hd_instr (MT.MStateAssign(vd,vt'))
358 362
	    in
359 363
	    let written_vars = Vars.add vd required_vars in
360 364
	    prefix_instr@[new_instr],
......
365 369
	    Vars.diff vars_to_print written_vars (* removed vd + dependencies from
366 370
						  variables to print *)
367 371

  
368
	 | LT.MStep(vdl,id,vtl) ->
372
	 | MT.MStep(vdl,id,vtl) ->
369 373
	    Format.eprintf "step@.";
370 374

  
371 375
	    if !debug then Format.eprintf "Call to a node %a@ " MC.pp_instr hd_instr;
......
417 421
									 variables *)
418 422
	      let written_vars = Vars.union required_vars (Vars.of_list vdl) in
419 423
	      let instrs', ranges' = assign_vars (Vars.union written_vars printed_vars) ranges formalEnv required_vars in
420
	      instrs' @ [Corelang.update_instr_desc hd_instr (LT.MStep(vdl,id,vtl'))], (* New instrs *)
424
	      instrs' @ [Corelang.update_instr_desc hd_instr (MT.MStep(vdl,id,vtl'))], (* New instrs *)
421 425
	      RangesInt.add_call ranges' vdl id vtl_ranges,   (* add information bounding each vdl var *) 
422 426
	      formalEnv,
423 427
	      Vars.union written_vars printed_vars,        (* adding vdl to new printed vars *)
424 428
	      Vars.diff vars_to_print written_vars
425 429
			
426
	 | LT.MBranch(vt, branches) ->
430
	 | MT.MBranch(vt, branches) ->
427 431
	    
428 432
	    (* Required variables to compute vt are introduced. 
429 433
	     Then each branch is refactored specifically 
......
466 470
									     
467 471
							   ) branches ([], required_vars, ranges) in
468 472
	    if !debug then Format.eprintf "dealing with branches done@ @]@ ";	  
469
	    prefix_instr@[Corelang.update_instr_desc hd_instr (LT.MBranch(vt', branches'))],
473
	    prefix_instr@[Corelang.update_instr_desc hd_instr (MT.MBranch(vt', branches'))],
470 474
	    merged_ranges, (* Only step functions call within branches
471 475
			    may have produced new ranges. We merge this data by
472 476
			    computing the join per variable *)
......
478 482
						  produced within branches *)
479 483

  
480 484

  
481
	 | LT.MReset(_) | LT.MNoReset _ | LT.MComment _ ->
485
	 | MT.MReset(_) | MT.MNoReset _ | MT.MComment _ ->
482 486
			   if !debug then Format.eprintf "Untouched %a (non real)@ " MC.pp_instr hd_instr;
483 487

  
484 488
			   (* Untouched instruction *)

Also available in: Unified diff