Revision 8446bf03
Added by PierreLoïc Garoche almost 4 years ago
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
 Makefile: solved dependency problem when compiling include lusi
 Renamed type declarations as lustre_types and machine_code_types