Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / plugins / salsa / machine_salsa_opt.ml @ 151117f7

History | View | Annotate | Download (28 KB)

1
(* We try to avoid opening modules here *)
2
module ST = Salsa.Types
3
module SDT = SalsaDatatypes
4
module LT = Lustre_types
5
module MC = Machine_code
6

    
7
(* Datatype for Salsa: FormalEnv, Ranges, Var set ... *)
8
open SalsaDatatypes
9
(******************************************************************)
10
(* TODO Xavier: should those functions be declared more globally? *)
11

    
12
let fun_types node = 
13
  try
14
    match node.LT.top_decl_desc with 
15
    | LT.Node nd -> 
16
      let tin, tout = Types.split_arrow nd.LT.node_type in
17
      Types.type_list_of_type tin, Types.type_list_of_type tout
18
    | _ -> Format.eprintf "%a is not a node@.@?" Printers.pp_decl node; assert false
19
  with Not_found -> Format.eprintf "Unable to find type def for function %s@.@?" (Corelang.node_name node); assert false
20

    
21
let called_node_id m id = 
22
  let td, _ =
23
    try
24
      List.assoc id m.MT.mcalls (* TODO Xavier: mcalls or minstances ? *)
25
    with Not_found -> assert false
26
  in
27
  td
28
(******************************************************************)    
29

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

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

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

    
83
(* let rec iterTransformExpr fresh_id e_salsa abstractEnv old_range = *)
84
(*   let new_expr, new_range =  *)
85
(*     Salsa.MainEPEG.transformExpression fresh_id e_salsa abstractEnv  *)
86
(*   in *)
87
(*   Format.eprintf "New range: %a@." 	  RangesInt.pp_val new_range; *)
88
(*   if Salsa.Float.errLt new_range old_range < 0 then  *)
89
    
90
(*     iterTransformExpr fresh_id new_expr abstractEnv new_range *)
91
(*   else *)
92
(*     new_expr, new_range *)
93

    
94

    
95
(* Optimize a given expression. It returns another expression and a computed range. *)
96
let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e : MT.value_t * RangesInt.t option * (MT.instr_t list) = 
97
  let rec opt_expr vars_env ranges formalEnv e =
98
    let open MT in
99
    match e.value_desc with
100
    | Cst cst ->
101
       (* Format.eprintf "optmizing constant expr @ "; *)
102
       (* the expression is a constant, we optimize it directly if it is a real
103
  	  constant *)
104
       let typ = Typing.type_const Location.dummy_loc cst in
105
       if Types.is_real_type typ then 
106
	 opt_num_expr vars_env ranges formalEnv e 
107
       else e, None, []
108
    | LocalVar v
109
    | StateVar v -> 
110
       if not (Vars.mem v printed_vars) && 
111
	 (* TODO xavier: comment recuperer le type de l'expression? Parfois e.value_type vaut 'd *)
112
	 (Types.is_real_type e.value_type ||  Types.is_real_type v.LT.var_type) 
113
       then
114
	 opt_num_expr vars_env ranges formalEnv e 
115
       else 
116
	 e, None, []  (* Nothing to optimize for expressions containing a single non real variable *)
117
    (* (\* optimize only numerical vars *\) *)
118
    (* if Type_predef.is_real_type v.LT.var_type then opt_num_expr ranges formalEnv e *)
119
    (* else e, None *)
120
    | Fun (fun_id, args) -> (
121
      (* necessarily, this is a basic function (ie. + - * / && || mod ... ) *)
122
      (* if the return type is real then optimize it, otherwise call recusrsively on arguments *)
123
      if Types.is_real_type e.value_type then
124
	opt_num_expr vars_env ranges formalEnv e 
125
      else (
126
	(* We do not care for computed local ranges. *)
127
  	let args', il = List.fold_right (fun arg (al, il) -> let arg', _, arg_il = opt_expr vars_env ranges formalEnv arg in arg'::al, arg_il@il) args ([], [])  in
128
  	{ e with value_desc = Fun(fun_id, args')}, None, il	  
129
      )
130
    )
131
    | Array _
132
    | Access _
133
    | Power _ -> assert false  
134
  and opt_num_expr vars_env ranges formalEnv e = 
135
    (* if !debug then Format.eprintf "Optimizing expression %a with Salsa@ " MC.pp_val e;  *)
136
    let fresh_id = "toto"  in (* TODO more meaningful name *)
137
    (* Convert expression *)
138
    (* List.iter (fun (l,c) -> Format.eprintf "%s -> %a@ " l Printers.pp_const c) constEnv; *)
139
    let e_salsa : Salsa.Types.expression = value_t2salsa_expr constEnv e in
140
    (* Format.eprintf "apres deplaige constantes ok%a @." MC.pp_val (salsa_expr2value_t vars_env [](\* constEnv *\) e_salsa) ;  *)
141

    
142
    (* Convert formalEnv *)
143
    (* if !debug then Format.eprintf "Formal env is [%a]@ " FormalEnv.pp formalEnv; *)
144
    (* if !debug then Format.eprintf "Formal env converted to salsa@ "; *)
145

    
146
    Format.eprintf "Expression avant et apres substVars.@.Avant %a@." MC.pp_val (salsa_expr2value_t vars_env [] e_salsa) ;  
147

    
148
    (* Substitute all occurences of variables by their definition in env *)
149
    let (e_salsa: Salsa.Types.expression), _ = 
150
      Salsa.Rewrite.substVars 
151
	e_salsa
152
	(FormalEnv.to_salsa constEnv formalEnv)
153
	0 (* TODO: Nasrine, what is this integer value for ? *)
154
    in
155

    
156
    Format.eprintf "Apres %a@." MC.pp_val (salsa_expr2value_t vars_env [] e_salsa) ;  
157

    
158
    (* if !debug then Format.eprintf "Substituted def in expr@ "; *)
159
    let abstractEnv = RangesInt.to_abstract_env ranges in
160
    (* List.iter (fun (id, _) -> Format.eprintf "absenv: %s@." id) abstractEnv; *)
161
    (* The expression is partially evaluated by the available ranges
162
       valEnv2ExprEnv remplce les paires id, abstractVal par id, Cst itv - on
163
       garde evalPartExpr remplace les variables e qui sont dans env par la cst
164
       - on garde *)
165
    (* if !debug then Format.eprintf "avant avant eval part@ "; *)
166
    Format.eprintf "avant evalpart: %a@." MC.pp_val (salsa_expr2value_t vars_env constEnv e_salsa);
167
    let e_salsa =  
168
      Salsa.Analyzer.evalPartExpr 
169
	e_salsa
170
	(Salsa.Analyzer.valEnv2ExprEnv abstractEnv) 
171
	([] (* no blacklisted variables *))
172
	([] (* no arrays *))
173
    in
174
    Format.eprintf "apres evalpart: %a@." MC.pp_val (salsa_expr2value_t vars_env constEnv e_salsa);
175
    (* Checking if we have all necessary information *)
176

    
177
    let free_vars = get_salsa_free_vars vars_env constEnv abstractEnv e_salsa in
178
    if Vars.cardinal free_vars > 0 then (
179
      Log.report ~level:2 (fun fmt -> Format.fprintf fmt "Warning: unbounded free vars (%a) in expression %a. We do not optimize it.@ " 
180
	Vars.pp (Vars.fold (fun v accu -> let v' = {v with LT.var_id = nodename.LT.node_id ^ "." ^ v.LT.var_id } in Vars.add v' accu) free_vars Vars.empty)
181
	MC.pp_val (salsa_expr2value_t vars_env constEnv e_salsa));
182
      if !debug then Format.eprintf "Some free vars, not optimizing@.";
183
      
184
      let new_e = try salsa_expr2value_t vars_env constEnv e_salsa   with Not_found -> assert false in
185
      new_e, None, []
186
    )
187
    else (
188
      
189
      try 
190
	if !debug then
191
	  Format.eprintf "Analyzing expression %a with env: @[<v>%a@ @]@ @?"
192
	    (C_backend_common.pp_c_val "" (C_backend_common.pp_c_var_read m)) (salsa_expr2value_t vars_env constEnv e_salsa)
193
	    (Utils.fprintf_list ~sep:",@ "(fun fmt (l,r) -> Format.fprintf fmt "%s -> %a" l FloatIntSalsa.pp r)) abstractEnv
194
	;
195

    
196
	Format.eprintf "going to slice@.";
197
	(* Slicing it XXX C'est là !!! ploc *)
198
	let e_salsa, seq = Salsa.Rewrite.sliceExpr e_salsa 0 (Salsa.Types.Nop(Salsa.Types.Lab 0)) in
199
	Format.eprintf "sliced@.";
200
	let def_tmps = Salsa.Utils.flatten_seq seq [] in
201
	(* Registering tmp ids in vars_env *)
202
	let vars_env' = List.fold_left
203
	  (fun vs (id, _) ->
204
	    VarEnv.add
205
	      id
206
	      {
207
		vdecl = Corelang.mk_fresh_var
208
		  nodename
209
		  Location.dummy_loc
210
		  e.MT.value_type
211
		  (Clocks.new_var true) ;
212
		is_local = true;
213
	      }
214
	      vs
215
	  )
216
	  vars_env
217
	  def_tmps
218
	in 
219
	Format.eprintf "List of tmp: @[<v 0>%a@]"
220
	  (
221
	    Utils.fprintf_list
222
	      ~sep:"@ "
223
	      (fun fmt (id, e_id) ->
224
		Format.fprintf fmt "(%s,%a) -> %a"
225
		  id
226
		  Printers.pp_var (get_var vars_env' id).vdecl
227
		  (C_backend_common.pp_c_val "" (C_backend_common.pp_c_var_read m)) (salsa_expr2value_t vars_env' constEnv e_id)
228
	      )
229
	  )
230
	  def_tmps;
231
	Format.eprintf "Sliced expression %a@.@?"
232
	  (C_backend_common.pp_c_val "" (C_backend_common.pp_c_var_read m)) (salsa_expr2value_t vars_env' constEnv e_salsa)
233
	;
234

    
235
	(* Optimize def tmp, and build the associated instructions. Update the abstract Env with computed ranges *)
236
	let rev_def_tmp_instrs, ranges =
237
	  List.fold_left (fun (accu_instrs, ranges) (id, e_id) ->
238
	    Format.eprintf "Cleaning/Optimizing %s@." id;
239
	    let abstractEnv = RangesInt.to_abstract_env ranges in
240
	    let e_id', e_range = Salsa.MainEPEG.transformExpression id e_id abstractEnv in
241

    
242
	    let vdecl = (get_var vars_env' id).vdecl in
243
	    let new_e_id' = try salsa_expr2value_t vars_env' constEnv e_id'  with Not_found -> assert false in
244
	
245
	    let new_local_assign =
246
	      (* let expr = salsa_expr2value_t vars_env' constEnv e_id' in *)
247
	      MT.MLocalAssign(vdecl, new_e_id')
248
	    in
249
	    let new_local_assign = {
250
	      MT.instr_desc = new_local_assign;
251
	      MT.lustre_eq = None (* could be Corelang.mkeq Location.dummy_loc
252
				     ([vdecl.LT.var_id], e_id) provided it is
253
				     converted as Lustre expression rather than
254
				     a Machine code value *);
255
	    }
256
	    in
257
	    let new_ranges = RangesInt.add_def ranges id e_range in
258
	    new_local_assign::accu_instrs, new_ranges
259
	  ) ([], ranges) def_tmps
260
	in
261

    
262
	Format.eprintf "Optimizing main expression %s@.AbstractEnv is %a" (Salsa.Print.printExpression e_salsa) RangesInt.pp ranges;
263
	
264
	let abstractEnv = RangesInt.to_abstract_env ranges in
265
	let new_e_salsa, e_val = 
266
	  Salsa.MainEPEG.transformExpression fresh_id e_salsa abstractEnv
267
	in
268

    
269
	(* let range_after = Float.evalExpr new_e_salsa abstractEnv in *)
270

    
271
    	let new_e = try salsa_expr2value_t vars_env' constEnv new_e_salsa   with Not_found -> assert false in
272
	if !debug then Format.eprintf "@  @[<v>old_expr: @[<v 0>%a@ range: %a@]@ new_expr: @[<v 0>%a@ range: %a@]@ @]"
273
	  MC.pp_val e
274
	  RangesInt.pp_val (Salsa.Analyzer.evalExpr e_salsa abstractEnv [])
275
	  MC.pp_val new_e
276
	  RangesInt.pp_val e_val;
277
	new_e, Some e_val, List.rev rev_def_tmp_instrs
278
      with (* Not_found ->  *)
279
      | Salsa.Epeg_types.EPEGError _ -> (
280
	Format.eprintf "BECAUSE OF AN ERROR, Expression %a was not optimized@ " MC.pp_val e;
281
	e, None, []
282
      )
283
    )
284

    
285

    
286

    
287
  in
288
  if !debug then 
289
    Format.eprintf "@[<v 2>Optimizing expression %a in environment %a and ranges %a@ "
290
      MC.pp_val e
291
      FormalEnv.pp formalEnv
292
      RangesInt.pp ranges;
293
  let res = opt_expr vars_env ranges formalEnv e in
294
  Format.eprintf "@]@ ";
295
  res
296

    
297
    
298
    
299
(* Returns a list of assign, for each var in vars_to_print, that produce the
300
   definition of it according to formalEnv, and driven by the ranges. *)
301
let assign_vars nodename m constEnv vars_env printed_vars ranges formalEnv vars_to_print =
302
  (* We print thhe expression in the order of definition *)
303

    
304
  let ordered_vars = 
305
    List.stable_sort
306
      (FormalEnv.get_sort_fun formalEnv) 
307
      (Vars.elements vars_to_print) 
308
  in
309
  if !debug then Format.eprintf "Printing vars in the following order: [%a]@ " (Utils.fprintf_list ~sep:", " Printers.pp_var) ordered_vars ;
310
  List.fold_right (
311
    fun v (accu_instr, accu_ranges) -> 
312
      if !debug then Format.eprintf "Printing assign for variable %s@ " v.LT.var_id;
313
      try
314
	(* Obtaining unfold expression of v in formalEnv *)
315
	let v_def = FormalEnv.get_def formalEnv v  in
316
	let e, r, il = optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv v_def in
317
	let instr_desc = 
318
	  if try (get_var vars_env v.LT.var_id).is_local with Not_found -> assert false then
319
	    MT.MLocalAssign(v, e)
320
	  else
321
	    MT.MStateAssign(v, e)
322
	in
323
	il@((Corelang.mkinstr instr_desc)::accu_instr), 
324
	(match r with 
325
	| None -> ranges 
326
	| Some v_r -> RangesInt.add_def ranges v.LT.var_id v_r)
327
      with FormalEnv.NoDefinition _ -> (
328
	(* It should not happen with C backend, but may happen with Lustre backend *)
329
	if !Options.output = "lustre" then accu_instr, ranges else (Format.eprintf "@?"; assert false)
330
      )
331
  ) ordered_vars ([], ranges)
332

    
333
(* Main recursive function: modify the instructions list while preserving the
334
   order of assigns for state variables. Returns a quintuple: (new_instrs,
335
   ranges, formalEnv, printed_vars, and remaining vars to be printed) *)
336
let rec rewrite_instrs nodename m constEnv  vars_env m instrs ranges formalEnv printed_vars vars_to_print =
337
  let formal_env_def = FormalEnv.def constEnv vars_env in
338
  Format.eprintf "Rewrite intrs : [%a]@." MC.pp_instrs instrs;
339
  let assign_vars = assign_vars nodename m constEnv vars_env in
340
  if !debug then (
341
    Format.eprintf "@.------------@ ";
342
    Format.eprintf "Current printed_vars: [%a]@ " Vars.pp printed_vars;
343
    Format.eprintf "Vars to print: [%a]@ " Vars.pp vars_to_print;
344
    Format.eprintf "Formal env is [%a]@ " FormalEnv.pp formalEnv;
345
  );
346
  match instrs with
347
  | [] -> 
348
     (* End of instruction list: we produce the definition of each variable that
349
	appears in vars_to_print. Each of them should be defined in formalEnv *)
350
     if !debug then Format.eprintf "Producing definitions %a@ " Vars.pp vars_to_print;
351
    let instrs, ranges' = assign_vars printed_vars ranges formalEnv vars_to_print in
352
    instrs,
353
    ranges',     
354
    formalEnv,
355
    Vars.union printed_vars vars_to_print, (* We should have printed all required vars *)
356
    []          (* No more vars to be printed *)
357

    
358
  | hd_instr::tl_instrs -> 
359
     (* We reformulate hd_instr, producing or not a fresh instruction, updating
360
	formalEnv, possibly ranges and vars_to_print *)
361
     begin
362
       Format.eprintf "Hdlist@.";
363
       let hd_instrs, ranges, formalEnv, printed_vars, vars_to_print =
364
	 match Corelang.get_instr_desc hd_instr with 
365
	 | MT.MLocalAssign(vd,vt) when Types.is_real_type vd.LT.var_type  && not (Vars.mem vd vars_to_print) -> 
366
	    Format.eprintf "local assign@.";
367
	   (* LocalAssign are injected into formalEnv *)
368
	   (* if !debug then Format.eprintf "Registering local assign %a@ " MC.pp_instr hd_instr; *)
369
	   if !debug then Format.eprintf "%a@ " MC.pp_instr hd_instr;
370
	   let formalEnv' = formal_env_def formalEnv vd vt in (* formelEnv updated with vd = vt *)
371
	   [],                        (* no instr generated *)
372
	   ranges,                    (* no new range computed *)
373
	   formalEnv',
374
	   printed_vars,              (* no new printed vars *)
375
	   vars_to_print              (* no more or less variables to print *)
376
	     
377
	 | MT.MLocalAssign(vd,vt) when Types.is_real_type vd.LT.var_type && Vars.mem vd vars_to_print ->
378
	    Format.eprintf "local assign 2@.";
379

    
380
           (* if !debug then Format.eprintf "Registering and producing state assign %a@ " MC.pp_instr hd_instr; *)
381
           (* if !debug then Format.eprintf "Registering and producing state assign %a@ " MC.pp_instr hd_instr; *)
382
           if !debug then (
383
	     Format.eprintf "%a@]@ " MC.pp_instr hd_instr;
384
	     Format.eprintf "Selected var %a: producing expression@ " Printers.pp_var vd;
385
	   );
386
	   let formalEnv' = formal_env_def formalEnv vd vt in (* formelEnv updated with vd = vt *)
387
	   let instrs', ranges' = (* printing vd = optimized vt *)
388
	     assign_vars printed_vars ranges formalEnv' (Vars.singleton vd)  
389
	   in
390
	   instrs',
391
	   ranges',                          (* no new range computed *)
392
	   formalEnv',                       (* formelEnv already updated *)
393
	   Vars.add vd printed_vars,        (* adding vd to new printed vars *)
394
	   Vars.remove vd vars_to_print     (* removed vd from variables to print *)
395

    
396
	 | MT.MStateAssign(vd,vt) when Types.is_real_type vd.LT.var_type (* && Vars.mem vd vars_to_print  *)-> 
397
	    Format.eprintf "state assign of real type@.";
398

    
399
	   (* StateAssign are produced since they are required by the function. We still
400
	      keep their definition in the formalEnv in case it can optimize later
401
	      outputs. vd is removed from remaining vars_to_print *)
402
	   (* if !debug then Format.eprintf "Registering and producing state assign %a@ " MC.pp_instr hd_instr; *)
403
           if !debug then (
404
	     Format.eprintf "%a@]@ " MC.pp_instr hd_instr;
405
	     Format.eprintf "State assign %a: producing expression@ " Printers.pp_var vd;
406
	   );
407
	   let formalEnv' = formal_env_def formalEnv vd vt in (* formelEnv updated with vd = vt *) 
408
	   let instrs', ranges' = (* printing vd = optimized vt *)
409
	     assign_vars printed_vars ranges formalEnv' (Vars.singleton vd)  
410
	   in
411
	   instrs',
412
	   ranges',                          (* no new range computed *)
413
	   formalEnv,                       (* formelEnv already updated *)
414
	   Vars.add vd printed_vars,        (* adding vd to new printed vars *)
415
	   Vars.remove vd vars_to_print     (* removed vd from variables to print *)
416

    
417
	 | (MT.MLocalAssign(vd,vt) | MT.MStateAssign(vd,vt))  ->
418
	    Format.eprintf "other assign %a@." MC.pp_instr hd_instr;
419

    
420
	   (* We have to produce the instruction. But we may have to produce as
421
	      well its dependencies *)
422
	   let required_vars = get_expr_real_vars vt in
423
	   let required_vars = Vars.diff required_vars printed_vars in (* remove
424
									  already
425
									  produced
426
									  variables *)
427
	   Format.eprintf "Required vars: %a@." Vars.pp required_vars;
428
	   let required_vars = Vars.diff required_vars (Vars.of_list m.MT.mmemory) in
429
	   let prefix_instr, ranges = 
430
	     assign_vars printed_vars ranges formalEnv required_vars in
431

    
432
	   let vt', _, il = optimize_expr nodename m constEnv (Vars.union required_vars printed_vars) vars_env ranges formalEnv vt in
433
	   let new_instr = 
434
	     match Corelang.get_instr_desc hd_instr with
435
	     | MT.MLocalAssign _ -> Corelang.update_instr_desc hd_instr (MT.MLocalAssign(vd,vt'))
436
	     | _ -> Corelang.update_instr_desc hd_instr (MT.MStateAssign(vd,vt'))
437
	   in
438
	   let written_vars = Vars.add vd required_vars in
439
	   prefix_instr@il@[new_instr],
440
	   ranges,                          (* no new range computed *)
441
	   formalEnv,                       (* formelEnv untouched *)
442
	   Vars.union written_vars printed_vars,  (* adding vd + dependencies to
443
						     new printed vars *)
444
	   Vars.diff vars_to_print written_vars (* removed vd + dependencies from
445
						   variables to print *)
446

    
447
	 | MT.MStep(vdl,id,vtl) ->
448
	    Format.eprintf "step@.";
449

    
450
	   if !debug then Format.eprintf "Call to a node %a@ " MC.pp_instr hd_instr;
451
	   (* Call of an external function. Input expressions have to be
452
	      optimized, their free variables produced. A fresh range has to be
453
	      computed for each output variable in vdl. Output of the function
454
	      call are removed from vars to be printed *)
455
	   let node =  called_node_id m id in
456
	   let node_id = Corelang.node_name node in
457
	   let tin, tout =  (* special care for arrow *)
458
	     if node_id = "_arrow" then
459
	       match vdl with 
460
	       | [v] -> let t = v.LT.var_type in
461
			[t; t], [t]
462
	       | _ -> assert false (* should not happen *)
463
	     else
464
	       fun_types node
465
	   in
466
	   if !debug then Format.eprintf "@[<v 2>... optimizing arguments@ ";
467
	   let vtl', vtl_ranges, il = List.fold_right2 (
468
	     fun e typ_e (exprl, range_l, il_l)-> 
469
	       if Types.is_real_type typ_e then
470
		 let e', r', il = optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e in
471
		 e'::exprl, r'::range_l, il@il_l
472
	       else 
473
		 e::exprl, None::range_l, il_l
474
	   ) vtl tin ([], [], []) 
475
	   in 
476
	   if !debug then Format.eprintf "... done@ @]@ ";
477

    
478

    
479

    
480
	   (* let required_vars =  *)
481
	   (*   List.fold_left2  *)
482
	   (*     (fun accu e typ_e ->  *)
483
	   (* 	 if Types.is_real_type typ_e then *)
484
	   (* 	   Vars.union accu (get_expr_real_vars e)  *)
485
	   (* 	 else (\* we do not consider non real expressions *\) *)
486
	   (* 	   accu *)
487
	   (*     ) *)
488
 	   (*     Vars.empty  *)
489
	   (*     vtl' tin *)
490
	   (* in *)
491
	   (* if !debug then Format.eprintf "Required vars: [%a]@ Printed vars: [%a]@ Remaining required vars: [%a]@ " *)
492
	   (*   Vars.pp required_vars  *)
493
	   (*   Vars.pp printed_vars *)
494
	   (*   Vars.pp (Vars.diff required_vars printed_vars) *)
495
	   (* ; *)
496
	   (* let required_vars = Vars.diff required_vars printed_vars in (\* remove *)
497
	   (* 								  already *)
498
	   (* 								  produced *)
499
	   (* 								  variables *\) *)
500
	   (* let written_vars = Vars.union required_vars (Vars.of_list vdl) in *)
501
	   (* let instrs', ranges' = assign_vars (Vars.union written_vars printed_vars) ranges formalEnv required_vars in *)
502

    
503
	   (* instrs' @ [Corelang.update_instr_desc hd_instr (MT.MStep(vdl,id,vtl'))], (* New instrs *) *)
504

    
505
	   let written_vars = Vars.of_list vdl in
506
	   
507

    
508
	   
509
	   il @ [Corelang.update_instr_desc hd_instr (MT.MStep(vdl,id,vtl'))], (* New instrs *)
510
	   RangesInt.add_call ranges vdl id vtl_ranges,   (* add information bounding each vdl var *) 
511
	   formalEnv,
512
	   Vars.union written_vars printed_vars,        (* adding vdl to new printed vars *)
513
	   Vars.diff vars_to_print written_vars
514
	     
515
	 | MT.MBranch(vt, branches) ->
516
	    
517
	    (* Required variables to compute vt are introduced. 
518
	       Then each branch is refactored specifically 
519
	    *)
520
	    if !debug then Format.eprintf "Branching %a@ " MC.pp_instr hd_instr;
521
	   let required_vars = get_expr_real_vars vt in
522
	   let required_vars = Vars.diff required_vars printed_vars in (* remove
523
									  already
524
									  produced
525
									  variables *)
526
	   let vt', _, prefix_instr = optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv vt in
527

    
528
	   (* let prefix_instr, ranges =  *)
529
	   (*   assign_vars (Vars.union required_vars printed_vars) ranges formalEnv required_vars in *)
530

    
531
	   let printed_vars = Vars.union printed_vars required_vars in
532

    
533

    
534
	   let read_vars_tl = get_read_vars tl_instrs in
535
	   if !debug then Format.eprintf "@[<v 2>Dealing with branches@ ";
536
	   let branches', written_vars, merged_ranges = List.fold_right (
537
	     fun (b_l, b_instrs) (new_branches, written_vars, merged_ranges) -> 
538
	       let b_write_vars = get_written_vars b_instrs in
539
	       let b_vars_to_print = Vars.inter b_write_vars (Vars.union read_vars_tl vars_to_print) in 
540
	       let b_fe = formalEnv in               (* because of side effect
541
							data, we copy it for
542
							each branch *)
543
	       let b_instrs', b_ranges, b_formalEnv, b_printed, b_vars = 
544
		 rewrite_instrs nodename m constEnv  vars_env m b_instrs ranges b_fe printed_vars b_vars_to_print 
545
	       in
546
	       (* b_vars should be empty *)
547
	       let _ = if b_vars != [] then assert false in
548
	       
549
	       (* Producing the refactored branch *)
550
	       (b_l, b_instrs') :: new_branches,
551
	       Vars.union b_printed written_vars, (* They should coincides. We
552
						     use union instead of
553
						     inter to ease the
554
						     bootstrap *)
555
	       RangesInt.merge merged_ranges b_ranges      
556
		 
557
	   ) branches ([], required_vars, ranges) in
558
	   if !debug then Format.eprintf "dealing with branches done@ @]@ ";	  
559
	   prefix_instr@[Corelang.update_instr_desc hd_instr (MT.MBranch(vt', branches'))],
560
	     merged_ranges, (* Only step functions call within branches
561
			       may have produced new ranges. We merge this data by
562
			       computing the join per variable *)
563
	     formalEnv,    (* Thanks to the computation of var_to_print in each
564
			      branch, no new definition should have been computed
565
			      without being already printed *)
566
	     Vars.union written_vars printed_vars,
567
	     Vars.diff vars_to_print written_vars (* We remove vars that have been
568
						     produced within branches *)
569

    
570

    
571
	 | MT.MReset(_) | MT.MNoReset _ | MT.MComment _ ->
572
	    if !debug then Format.eprintf "Untouched %a (non real)@ " MC.pp_instr hd_instr;
573

    
574
	   (* Untouched instruction *)
575
	   [ hd_instr ],                    (* unmodified instr *)
576
	      ranges,                          (* no new range computed *)
577
	      formalEnv,                       (* no formelEnv update *)
578
	      printed_vars,
579
	      vars_to_print                    (* no more or less variables to print *)
580
		
581
       in
582
       Format.eprintf "cic@.";
583
       let tl_instrs, ranges, formalEnv, printed_vars, vars_to_print = 
584
	 rewrite_instrs 
585
	   nodename
586
	   m
587
	   constEnv 	  
588
	   vars_env
589
	   m 
590
	   tl_instrs
591
	   ranges
592
	   formalEnv
593
	   printed_vars
594
	   vars_to_print
595
       in
596
       Format.eprintf "la@.";
597
       hd_instrs @ tl_instrs,
598
       ranges,
599
       formalEnv, 
600
       printed_vars,
601
       vars_to_print 
602
     end
603

    
604

    
605

    
606

    
607

    
608

    
609
(* TODO: deal with new variables, ie. tmp *)
610
let salsaStep constEnv  m s = 
611
  let ranges = RangesInt.empty (* empty for the moment, should be build from
612
				  machine annotations or externally provided information *) in
613
  let annots = List.fold_left (
614
    fun accu annl -> 
615
      List.fold_left (
616
	fun accu (key, range) ->
617
	  match key with 
618
	  | ["salsa"; "ranges"; var] -> (var, range)::accu
619
	  | _ -> accu
620
      ) accu annl.LT.annots
621
  ) [] m.MT.mannot
622
  in
623
  let ranges = 
624
    List.fold_left (fun ranges (v, value) ->
625
      match value.LT.eexpr_qfexpr.LT.expr_desc with 
626
      | LT.Expr_tuple [minv; maxv] -> (
627
	let get_cst e = match e.LT.expr_desc with 
628
	  | LT.Expr_const (LT.Const_real (c,e,s)) -> 
629
	    (* calculer la valeur c * 10^e *) 
630
	    Num.div_num c (Num.power_num (Num.num_of_int 10) (Num.num_of_int e))
631
	  | _ -> 
632
	    Format.eprintf 
633
	      "Invalid scala range: %a. It should be a pair of constant floats.@." 
634
	      Printers.pp_expr value.LT.eexpr_qfexpr; 
635
	    assert false 
636
	in
637
	(* let minv = Salsa.Float.Domain.of_num (get_cst minv) and *)
638
	(*     maxv = Salsa.Float.Domain.of_num (get_cst maxv) in *)
639
	(* if !debug then Format.eprintf "variable %s in [%s, %s]@ " v (Num.string_of_num minv) (Num.string_of_num maxv); *)
640
	RangesInt.enlarge ranges v (Salsa.Float.Domain.inject_nums (get_cst minv) (get_cst maxv))
641
      )
642
      | _ -> 
643
	Format.eprintf 
644
	  "Invalid scala range: %a. It should be a pair of floats.@." 
645
	  Printers.pp_expr value.LT.eexpr_qfexpr; 
646
	assert false
647
    ) ranges annots
648
  in
649
  let formal_env = FormalEnv.empty () in
650
  let vars_to_print =
651
    Vars.real_vars  
652
      (
653
	Vars.union 
654
	  (Vars.of_list m.MT.mmemory) 
655
	  (Vars.of_list s.MT.step_outputs) 
656
      )
657
  in 
658
  (* TODO: should be at least step output + may be memories *)
659
  
660
  let vars_env = compute_vars_env m in  
661
  if !debug then Format.eprintf "@[<v 2>Registering node equations@ "; 
662
  let new_instrs, _, _, printed_vars, _ = 
663
    rewrite_instrs
664
      m.MT.mname
665
      m
666
      constEnv 
667
      vars_env
668
      m
669
      s.MT.step_instrs
670
      ranges
671
      formal_env
672
      (Vars.real_vars (Vars.of_list s.MT.step_inputs (* printed_vars : real
673
							inputs are considered as
674
							already printed *)))
675
      vars_to_print 
676
  in
677
  let all_local_vars = Vars.real_vars (Vars.of_list s.MT.step_locals) in
678
  let unused = (Vars.diff all_local_vars printed_vars) in
679
  let locals =
680
    if not (Vars.is_empty unused) then (
681
      Format.eprintf "Unused local vars: [%a]. Removing them.@.@?"
682
	Vars.pp unused;
683
      List.filter (fun v -> not (Vars.mem v unused)) s.MT.step_locals
684
    )
685
    else
686
      s.MT.step_locals
687
  in
688
  { s with MT.step_instrs = new_instrs; MT.step_locals = locals } (* we have also to modify local variables to declare new vars *)
689

    
690

    
691
let machine_t2machine_t_optimized_by_salsa constEnv  mt =
692
  try
693
    if !debug then Format.eprintf "@[<v 8>[salsa] Optimizing machine %s@ " mt.MT.mname.LT.node_id;
694
    let new_step = salsaStep constEnv  mt mt.MT.mstep in
695
    if !debug then Format.eprintf "@]@ ";
696
    { mt with MT.mstep = new_step } 
697
    
698
      
699
  with FormalEnv.NoDefinition v as exp -> 
700
    Format.eprintf "No definition for variable %a@.@?" Printers.pp_var v; 
701
    raise exp
702

    
703

    
704
(* Local Variables: *)
705
(* compile-command:"make -C ../../.." *)
706
(* End: *)
707