Project

General

Profile

Download (25.4 KB) Statistics
| Branch: | Tag: | Revision:
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 = 
97
  let rec opt_expr 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 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 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 ranges formalEnv e 
125
      else (
126
	(* We do not care for computed local ranges. *)
127
  	let args' = List.map (fun arg -> let arg', _ = opt_expr ranges formalEnv arg in arg') args in
128
  	{ e with value_desc = Fun(fun_id, args')}, None	  
129
      )
130
    )
131
    | Array _
132
    | Access _
133
    | Power _ -> assert false  
134
  and opt_num_expr 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 = Hashtbl.fold 
160
      (fun id value accu -> (id,value)::accu) 
161
      ranges
162
      [] 
163
    in
164
    (* List.iter (fun (id, _) -> Format.eprintf "absenv: %s@." id) abstractEnv; *)
165
    (* The expression is partially evaluated by the available ranges
166
       valEnv2ExprEnv remplce les paires id, abstractVal par id, Cst itv - on
167
       garde evalPartExpr remplace les variables e qui sont dans env par la cst
168
       - on garde *)
169
    (* if !debug then Format.eprintf "avant avant eval part@ "; *)
170
     Format.eprintf "avant evalpart: %a@." MC.pp_val (salsa_expr2value_t vars_env constEnv e_salsa);
171
    let e_salsa =  
172
      Salsa.Analyzer.evalPartExpr 
173
	e_salsa
174
	(Salsa.Analyzer.valEnv2ExprEnv abstractEnv) 
175
	([] (* no blacklisted variables *))
176
	([] (* no arrays *))
177
    in
178
     Format.eprintf "apres evalpart: %a@." MC.pp_val (salsa_expr2value_t vars_env constEnv e_salsa);
179
    (* Checking if we have all necessary information *)
180

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

    
200
	(* Slicing it *)
201
	let e_salsa, seq = Salsa.Rewrite.sliceExpr e_salsa 0 (Salsa.Types.Nop(Salsa.Types.Lab 0)) in
202

    
203
	Format.eprintf "Sliced expression %a@.@?"
204
	  (C_backend_common.pp_c_val "" (C_backend_common.pp_c_var_read m)) (salsa_expr2value_t vars_env constEnv e_salsa)
205
	;
206
	
207
	let new_e_salsa, e_val = 
208
	  Salsa.MainEPEG.transformExpression fresh_id e_salsa abstractEnv
209
	in
210

    
211
	  (* let range_after = Float.evalExpr new_e_salsa abstractEnv in *)
212

    
213
    	let new_e = try salsa_expr2value_t vars_env constEnv new_e_salsa   with Not_found -> assert false in
214
	if !debug then Format.eprintf "@  @[<v>old: %a@ new: %a@ range: %a@]" MC.pp_val e MC.pp_val new_e RangesInt.pp_val e_val;
215
	new_e, Some e_val
216
      with (* Not_found ->  *)
217
      | Salsa.Epeg_types.EPEGError _ -> (
218
	Format.eprintf "BECAUSE OF AN ERROR, Expression %a was not optimized@ " MC.pp_val e;
219
	e, None
220
      )
221
    )
222

    
223

    
224

    
225
  in
226
  if !debug then 
227
    Format.eprintf "@[<v 2>Optimizing expression %a in environment %a and ranges %a@ "
228
      MC.pp_val e
229
      FormalEnv.pp formalEnv
230
      RangesInt.pp ranges;
231
  let res = opt_expr ranges formalEnv e in
232
  Format.eprintf "@]@ ";
233
  res
234

    
235
    
236
    
237
(* Returns a list of assign, for each var in vars_to_print, that produce the
238
   definition of it according to formalEnv, and driven by the ranges. *)
239
let assign_vars nodename m constEnv vars_env printed_vars ranges formalEnv vars_to_print =
240
  (* We print thhe expression in the order of definition *)
241

    
242
  let ordered_vars = 
243
    List.stable_sort
244
      (FormalEnv.get_sort_fun formalEnv) 
245
      (Vars.elements vars_to_print) 
246
  in
247
  if !debug then Format.eprintf "Printing vars in the following order: [%a]@ " (Utils.fprintf_list ~sep:", " Printers.pp_var) ordered_vars ;
248
  List.fold_right (
249
    fun v (accu_instr, accu_ranges) -> 
250
      if !debug then Format.eprintf "Printing assign for variable %s@ " v.LT.var_id;
251
      try
252
	(* Obtaining unfold expression of v in formalEnv *)
253
	let v_def = FormalEnv.get_def formalEnv v  in
254
	let e, r = optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv v_def in
255
	let instr_desc = 
256
	  if try (get_var vars_env v.LT.var_id).is_local with Not_found -> assert false then
257
	    MT.MLocalAssign(v, e)
258
	  else
259
	    MT.MStateAssign(v, e)
260
	in
261
	(Corelang.mkinstr instr_desc)::accu_instr, 
262
	(match r with 
263
	| None -> ranges 
264
	| Some v_r -> RangesInt.add_def ranges v.LT.var_id v_r)
265
      with FormalEnv.NoDefinition _ -> (
266
	(* It should not happen with C backend, but may happen with Lustre backend *)
267
	if !Options.output = "lustre" then accu_instr, ranges else (Format.eprintf "@?"; assert false)
268
      )
269
  ) ordered_vars ([], ranges)
270

    
271
(* Main recursive function: modify the instructions list while preserving the
272
   order of assigns for state variables. Returns a quintuple: (new_instrs,
273
   ranges, formalEnv, printed_vars, and remaining vars to be printed) *)
274
let rec rewrite_instrs nodename m constEnv  vars_env m instrs ranges formalEnv printed_vars vars_to_print =
275
  let formal_env_def = FormalEnv.def constEnv vars_env in
276
  Format.eprintf "Rewrite intrs :%a@." MC.pp_instrs instrs;
277
  let assign_vars = assign_vars nodename m constEnv vars_env in
278
  if !debug then (
279
    Format.eprintf "@.------------@ ";
280
    Format.eprintf "Current printed_vars: [%a]@ " Vars.pp printed_vars;
281
    Format.eprintf "Vars to print: [%a]@ " Vars.pp vars_to_print;
282
    Format.eprintf "Formal env is [%a]@ " FormalEnv.pp formalEnv;
283
  );
284
  match instrs with
285
  | [] -> 
286
     (* End of instruction list: we produce the definition of each variable that
287
       appears in vars_to_print. Each of them should be defined in formalEnv *)
288
     if !debug then Format.eprintf "Producing definitions %a@ " Vars.pp vars_to_print;
289
     let instrs, ranges' = assign_vars printed_vars ranges formalEnv vars_to_print in
290
     instrs,
291
     ranges',     
292
     formalEnv,
293
     Vars.union printed_vars vars_to_print, (* We should have printed all required vars *)
294
     []          (* No more vars to be printed *)
295

    
296
  | hd_instr::tl_instrs -> 
297
     (* We reformulate hd_instr, producing or not a fresh instruction, updating
298
       formalEnv, possibly ranges and vars_to_print *)
299
     begin
300
       Format.eprintf "Hdlist@.";
301
       let hd_instrs, ranges, formalEnv, printed_vars, vars_to_print =
302
	 match Corelang.get_instr_desc hd_instr with 
303
	 | MT.MLocalAssign(vd,vt) when Types.is_real_type vd.LT.var_type  && not (Vars.mem vd vars_to_print) -> 
304
       Format.eprintf "local assign@.";
305
	    (* LocalAssign are injected into formalEnv *)
306
	    (* if !debug then Format.eprintf "Registering local assign %a@ " MC.pp_instr hd_instr; *)
307
	    if !debug then Format.eprintf "%a@ " MC.pp_instr hd_instr;
308
	    let formalEnv' = formal_env_def formalEnv vd vt in (* formelEnv updated with vd = vt *)
309
	    [],                        (* no instr generated *)
310
	    ranges,                    (* no new range computed *)
311
	    formalEnv',
312
	    printed_vars,              (* no new printed vars *)
313
	    vars_to_print              (* no more or less variables to print *)
314
	      
315
	 | MT.MLocalAssign(vd,vt) when Types.is_real_type vd.LT.var_type && Vars.mem vd vars_to_print ->
316
       Format.eprintf "local assign 2@.";
317

    
318
            (* if !debug then Format.eprintf "Registering and producing state assign %a@ " MC.pp_instr hd_instr; *)
319
            (* if !debug then Format.eprintf "Registering and producing state assign %a@ " MC.pp_instr hd_instr; *)
320
           if !debug then (
321
	     Format.eprintf "%a@]@ " MC.pp_instr hd_instr;
322
	     Format.eprintf "Selected var %a: producing expression@ " Printers.pp_var vd;
323
	   );
324
	   let formalEnv' = formal_env_def formalEnv vd vt in (* formelEnv updated with vd = vt *)
325
	    let instrs', ranges' = (* printing vd = optimized vt *)
326
	      assign_vars printed_vars ranges formalEnv' (Vars.singleton vd)  
327
	    in
328
	    instrs',
329
	    ranges',                          (* no new range computed *)
330
	    formalEnv',                       (* formelEnv already updated *)
331
	    Vars.add vd printed_vars,        (* adding vd to new printed vars *)
332
	    Vars.remove vd vars_to_print     (* removed vd from variables to print *)
333

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

    
337
	    (* StateAssign are produced since they are required by the function. We still
338
	     keep their definition in the formalEnv in case it can optimize later
339
	     outputs. vd is removed from remaining vars_to_print *)
340
	    (* if !debug then Format.eprintf "Registering and producing state assign %a@ " MC.pp_instr hd_instr; *)
341
           if !debug then (
342
	     Format.eprintf "%a@]@ " MC.pp_instr hd_instr;
343
	     Format.eprintf "State assign %a: producing expression@ " Printers.pp_var vd;
344
	   );
345
	    let formalEnv' = formal_env_def formalEnv vd vt in (* formelEnv updated with vd = vt *) 
346
	    let instrs', ranges' = (* printing vd = optimized vt *)
347
	      assign_vars printed_vars ranges formalEnv' (Vars.singleton vd)  
348
	    in
349
	    instrs',
350
	    ranges',                          (* no new range computed *)
351
	    formalEnv,                       (* formelEnv already updated *)
352
	    Vars.add vd printed_vars,        (* adding vd to new printed vars *)
353
	    Vars.remove vd vars_to_print     (* removed vd from variables to print *)
354

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

    
358
	    (* We have to produce the instruction. But we may have to produce as
359
	     well its dependencies *)
360
	    let required_vars = get_expr_real_vars vt in
361
	    let required_vars = Vars.diff required_vars printed_vars in (* remove
362
									 already
363
									 produced
364
									   variables *)
365
	    Format.eprintf "Requited vars: %a@." Vars.pp required_vars;
366
	    let required_vars = Vars.diff required_vars (Vars.of_list m.MT.mmemory) in
367
	    let prefix_instr, ranges = 
368
	      assign_vars printed_vars ranges formalEnv required_vars in
369

    
370
	    let vt', _ = optimize_expr nodename m constEnv (Vars.union required_vars printed_vars) vars_env ranges formalEnv vt in
371
	    let new_instr = 
372
	      match Corelang.get_instr_desc hd_instr with
373
	      | MT.MLocalAssign _ -> Corelang.update_instr_desc hd_instr (MT.MLocalAssign(vd,vt'))
374
	      | _ -> Corelang.update_instr_desc hd_instr (MT.MStateAssign(vd,vt'))
375
	    in
376
	    let written_vars = Vars.add vd required_vars in
377
	    prefix_instr@[new_instr],
378
	    ranges,                          (* no new range computed *)
379
	    formalEnv,                       (* formelEnv untouched *)
380
	    Vars.union written_vars printed_vars,  (* adding vd + dependencies to
381
						    new printed vars *)
382
	    Vars.diff vars_to_print written_vars (* removed vd + dependencies from
383
						  variables to print *)
384

    
385
	 | MT.MStep(vdl,id,vtl) ->
386
	    Format.eprintf "step@.";
387

    
388
	    if !debug then Format.eprintf "Call to a node %a@ " MC.pp_instr hd_instr;
389
	    (* Call of an external function. Input expressions have to be
390
	     optimized, their free variables produced. A fresh range has to be
391
	     computed for each output variable in vdl. Output of the function
392
	     call are removed from vars to be printed *)
393
	    let node =  called_node_id m id in
394
	    let node_id = Corelang.node_name node in
395
	    let tin, tout =  (* special care for arrow *)
396
	      if node_id = "_arrow" then
397
		match vdl with 
398
		| [v] -> let t = v.LT.var_type in
399
			 [t; t], [t]
400
		| _ -> assert false (* should not happen *)
401
	      else
402
		fun_types node
403
	    in
404
	    if !debug then Format.eprintf "@[<v 2>... optimizing arguments@ ";
405
	    let vtl', vtl_ranges = List.fold_right2 (
406
				       fun e typ_e (exprl, range_l)-> 
407
				       if Types.is_real_type typ_e then
408
					 let e', r' = optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e in
409
					 e'::exprl, r'::range_l
410
				       else 
411
					 e::exprl, None::range_l
412
				     ) vtl tin ([], []) 
413
	    in 
414
	    if !debug then Format.eprintf "... done@ @]@ ";
415
	    let required_vars = 
416
	      List.fold_left2 
417
		(fun accu e typ_e -> 
418
		 if Types.is_real_type typ_e then
419
		   Vars.union accu (get_expr_real_vars e) 
420
		 else (* we do not consider non real expressions *)
421
		   accu
422
		)
423
 		Vars.empty 
424
		vtl' tin
425
	    in
426
	    if !debug then Format.eprintf "Required vars: [%a]@ Printed vars: [%a]@ Remaining required vars: [%a]@ "
427
					 Vars.pp required_vars 
428
					 Vars.pp printed_vars
429
					 Vars.pp (Vars.diff required_vars printed_vars)
430
	    ;
431
	      let required_vars = Vars.diff required_vars printed_vars in (* remove
432
									 already
433
									 produced
434
									 variables *)
435
	      let written_vars = Vars.union required_vars (Vars.of_list vdl) in
436
	      let instrs', ranges' = assign_vars (Vars.union written_vars printed_vars) ranges formalEnv required_vars in
437
	      instrs' @ [Corelang.update_instr_desc hd_instr (MT.MStep(vdl,id,vtl'))], (* New instrs *)
438
	      RangesInt.add_call ranges' vdl id vtl_ranges,   (* add information bounding each vdl var *) 
439
	      formalEnv,
440
	      Vars.union written_vars printed_vars,        (* adding vdl to new printed vars *)
441
	      Vars.diff vars_to_print written_vars
442
			
443
	 | MT.MBranch(vt, branches) ->
444
	    
445
	    (* Required variables to compute vt are introduced. 
446
	     Then each branch is refactored specifically 
447
	     *)
448
	    if !debug then Format.eprintf "Branching %a@ " MC.pp_instr hd_instr;
449
	    let required_vars = get_expr_real_vars vt in
450
	    let required_vars = Vars.diff required_vars printed_vars in (* remove
451
									 already
452
									 produced
453
									 variables *)
454
	    let prefix_instr, ranges = 
455
	      assign_vars (Vars.union required_vars printed_vars) ranges formalEnv required_vars in
456

    
457
	    let printed_vars = Vars.union printed_vars required_vars in
458

    
459
	    let vt', _ = optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv vt in
460

    
461
	    let read_vars_tl = get_read_vars tl_instrs in
462
	    if !debug then Format.eprintf "@[<v 2>Dealing with branches@ ";
463
	    let branches', written_vars, merged_ranges = List.fold_right (
464
							     fun (b_l, b_instrs) (new_branches, written_vars, merged_ranges) -> 
465
							     let b_write_vars = get_written_vars b_instrs in
466
							     let b_vars_to_print = Vars.inter b_write_vars (Vars.union read_vars_tl vars_to_print) in 
467
							     let b_fe = formalEnv in               (* because of side effect
468
						       data, we copy it for
469
						       each branch *)
470
							     let b_instrs', b_ranges, b_formalEnv, b_printed, b_vars = 
471
							       rewrite_instrs nodename m constEnv  vars_env m b_instrs ranges b_fe printed_vars b_vars_to_print 
472
							     in
473
							     (* b_vars should be empty *)
474
							     let _ = if b_vars != [] then assert false in
475
							     
476
							     (* Producing the refactored branch *)
477
							     (b_l, b_instrs') :: new_branches,
478
							     Vars.union b_printed written_vars, (* They should coincides. We
479
						       use union instead of
480
						       inter to ease the
481
						       bootstrap *)
482
							     RangesInt.merge merged_ranges b_ranges      
483
									     
484
							   ) branches ([], required_vars, ranges) in
485
	    if !debug then Format.eprintf "dealing with branches done@ @]@ ";	  
486
	    prefix_instr@[Corelang.update_instr_desc hd_instr (MT.MBranch(vt', branches'))],
487
	    merged_ranges, (* Only step functions call within branches
488
			    may have produced new ranges. We merge this data by
489
			    computing the join per variable *)
490
	    formalEnv,    (* Thanks to the computation of var_to_print in each
491
			   branch, no new definition should have been computed
492
			   without being already printed *)
493
	    Vars.union written_vars printed_vars,
494
	    Vars.diff vars_to_print written_vars (* We remove vars that have been
495
						  produced within branches *)
496

    
497

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

    
501
			   (* Untouched instruction *)
502
			   [ hd_instr ],                    (* unmodified instr *)
503
			   ranges,                          (* no new range computed *)
504
			   formalEnv,                       (* no formelEnv update *)
505
			   printed_vars,
506
			   vars_to_print                    (* no more or less variables to print *)
507
			     
508
       in
509
       Format.eprintf "cic@.";
510
       let tl_instrs, ranges, formalEnv, printed_vars, vars_to_print = 
511
	 rewrite_instrs 
512
	   nodename
513
	   m
514
	   constEnv 	  
515
	   vars_env
516
	   m 
517
	   tl_instrs
518
	   ranges
519
	   formalEnv
520
	   printed_vars
521
	   vars_to_print
522
       in
523
       Format.eprintf "la@.";
524
       hd_instrs @ tl_instrs,
525
       ranges,
526
       formalEnv, 
527
       printed_vars,
528
       vars_to_print 
529
     end
530

    
531

    
532

    
533

    
534

    
535

    
536
(* TODO: deal with new variables, ie. tmp *)
537
let salsaStep constEnv  m s = 
538
  let ranges = RangesInt.empty (* empty for the moment, should be build from
539
				  machine annotations or externally provided information *) in
540
  let annots = List.fold_left (
541
    fun accu annl -> 
542
      List.fold_left (
543
	fun accu (key, range) ->
544
	  match key with 
545
	  | ["salsa"; "ranges"; var] -> (var, range)::accu
546
	  | _ -> accu
547
      ) accu annl.LT.annots
548
  ) [] m.MT.mannot
549
  in
550
  let ranges = 
551
    List.fold_left (fun ranges (v, value) ->
552
      match value.LT.eexpr_qfexpr.LT.expr_desc with 
553
      | LT.Expr_tuple [minv; maxv] -> (
554
	let get_cst e = match e.LT.expr_desc with 
555
	  | LT.Expr_const (LT.Const_real (c,e,s)) -> 
556
	    (* calculer la valeur c * 10^e *) 
557
	    Num.div_num c (Num.power_num (Num.num_of_int 10) (Num.num_of_int e))
558
	  | _ -> 
559
	    Format.eprintf 
560
	      "Invalid scala range: %a. It should be a pair of constant floats.@." 
561
	      Printers.pp_expr value.LT.eexpr_qfexpr; 
562
	    assert false 
563
	in
564
	let minv, maxv = get_cst minv, get_cst maxv in
565
	let minv, maxv = Num.float_of_num minv, Num.float_of_num  maxv in
566
	(* if !debug then Format.eprintf "variable %s in [%s, %s]@ " v (Num.string_of_num minv) (Num.string_of_num maxv); *)
567
	RangesInt.enlarge ranges v (Salsa.Float.Domain.nnew minv maxv)
568
      )
569
      | _ -> 
570
	Format.eprintf 
571
	  "Invalid scala range: %a. It should be a pair of floats.@." 
572
	  Printers.pp_expr value.LT.eexpr_qfexpr; 
573
	assert false
574
    ) ranges annots
575
  in
576
  let formal_env = FormalEnv.empty () in
577
  let vars_to_print =
578
    Vars.real_vars  
579
      (
580
	Vars.union 
581
	  (Vars.of_list m.MT.mmemory) 
582
	  (Vars.of_list s.MT.step_outputs) 
583
      )
584
  in 
585
  (* TODO: should be at least step output + may be memories *)
586
  
587
  let vars_env = compute_vars_env m in  
588
  if !debug then Format.eprintf "@[<v 2>Registering node equations@ "; 
589
  let new_instrs, _, _, printed_vars, _ = 
590
    rewrite_instrs
591
      m.MT.mname.LT.node_id
592
      m
593
      constEnv 
594
      vars_env
595
      m
596
      s.MT.step_instrs
597
      ranges
598
      formal_env
599
      (Vars.real_vars (Vars.of_list s.MT.step_inputs (* printed_vars : real
600
							inputs are considered as
601
							already printed *)))
602
      vars_to_print 
603
  in
604
  let all_local_vars = Vars.real_vars (Vars.of_list s.MT.step_locals) in
605
  let unused = (Vars.diff all_local_vars printed_vars) in
606
  let locals =
607
    if not (Vars.is_empty unused) then (
608
      Format.eprintf "Unused local vars: [%a]. Removing them.@.@?"
609
	Vars.pp unused;
610
      List.filter (fun v -> not (Vars.mem v unused)) s.MT.step_locals
611
    )
612
    else
613
      s.MT.step_locals
614
  in
615
  { s with MT.step_instrs = new_instrs; MT.step_locals = locals } (* we have also to modify local variables to declare new vars *)
616

    
617

    
618
let machine_t2machine_t_optimized_by_salsa constEnv  mt =
619
  try
620
    if !debug then Format.eprintf "@[<v 8>[salsa] Optimizing machine %s@ " mt.MT.mname.LT.node_id;
621
    let new_step = salsaStep constEnv  mt mt.MT.mstep in
622
    if !debug then Format.eprintf "@]@ ";
623
    { mt with MT.mstep = new_step } 
624
    
625
      
626
  with FormalEnv.NoDefinition v as exp -> 
627
    Format.eprintf "No definition for variable %a@.@?" Printers.pp_var v; 
628
    raise exp
629

    
630

    
631
(* Local Variables: *)
632
(* compile-command:"make -C ../../.." *)
633
(* End: *)
634

    
(1-1/3)