CristalCaveGem » LustreC

(* Takes as input a salsa expression and return an optimized one *)

let opt_num_expr_sliced ranges e_salsa =

  try 

    let fresh_id = "toto"  in (* TODO more meaningful name *)

    let abstractEnv = RangesInt.to_abstract_env ranges in

    let new_e_salsa, e_val = 

      Salsa.MainEPEG.transformExpression fresh_id e_salsa abstractEnv

    in

    (* (\* Debug *\) *)

    (* Format.eprintf "Salsa:@.input expr: %s@.outputexpr: %s@." *)

    (*   (Salsa.Print.printExpression e_salsa) *)

    (*   (Salsa.Print.printExpression new_e_salsa); *)

    (* (\* Debug *\) *)

    let old_val = Salsa.Analyzer.evalExpr e_salsa abstractEnv [] in

    let expr, expr_range  =

      match RangesInt.Value.leq old_val e_val, RangesInt.Value.leq e_val old_val with

      | true, true -> (

	if !debug then Log.report ~level:2 (fun fmt ->

	  Format.fprintf fmt "No improvement on abstract value %a@ " RangesInt.pp_val e_val;

	);

	e_salsa, Some old_val

      )

      | true, false -> (

	if !debug then Log.report ~level:2 (fun fmt ->

	  Format.fprintf fmt "Improved!@ ";

	);

	new_e_salsa, Some e_val

      )

      | false, true -> Format.eprintf "CAREFUL --- new range is worse!. Restoring provided expression@ "; 	e_salsa, Some old_val

      | false, false ->

	 Format.eprintf

	   "Error; new range is not comparabe with old end. This should not happen!@.@?";

	assert false

    in

    if !debug then Log.report ~level:2 (fun fmt ->

      Format.fprintf fmt

	"  @[<v>old_expr: @[<v 0>%s@ range: %a@]@ new_expr: @[<v 0>%s@ range: %a@]@ @]@ "

	(Salsa.Print.printExpression e_salsa)

	(* MC.pp_val e *)

	RangesInt.pp_val old_val

	(Salsa.Print.printExpression new_e_salsa)

	(* MC.pp_val new_e *)

	RangesInt.pp_val e_val;

    );

    expr, expr_range

  with (* Not_found ->  *)

  | Salsa.Epeg_types.EPEGError _ -> (

    Log.report ~level:2 (fun fmt ->

      Format.fprintf fmt

	"BECAUSE OF AN ERROR, Expression %s was not optimized@ " 	(Salsa.Print.printExpression e_salsa)

(* MC.pp_val e *));

    e_salsa, None

  )

(* Optimize a given expression. It returns the modified expression, a computed range and freshly defined variables. *)

let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e : MT.value_t * RangesInt.t option * MT.instr_t list * Vars.VarSet.t = 

       else e, None, [], Vars.empty

	 e, None, [],  Vars.empty  (* Nothing to optimize for expressions containing a single non real variable *)

  	let args', il, new_locals =

	  List.fold_right (

	    fun arg (al, il, nl) ->

	      let arg', _, arg_il, arg_nl =

		opt_expr vars_env ranges formalEnv arg in

	      arg'::al, arg_il@il, Vars.union arg_nl nl)

	    args

	    ([], [], Vars.empty)

	in

  	{ e with value_desc = Fun(fun_id, args')}, None, il, new_locals	  

      Log.report ~level:2 (fun fmt -> Format.fprintf fmt "Optimizing expression @[<hov>%a@]@ "

      Log.report ~level:2 (fun fmt -> Format.fprintf fmt

	"Warning: unbounded free vars (%a) in expression %a. We do not optimize it.@ " 

	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)

      new_e, None, [] , Vars.empty

      if !debug then

	Log.report ~level:3 (fun fmt -> Format.fprintf fmt "@[<v 2>Analyzing expression %a@  with ranges: @[<v>%a@ @]@ @]@ "

	  (C_backend_common.pp_c_val "" (C_backend_common.pp_c_var_read m)) (salsa_expr2value_t vars_env constEnv e_salsa)

	  (Utils.fprintf_list ~sep:",@ "(fun fmt (l,r) -> Format.fprintf fmt "%s -> %a" l FloatIntSalsa.pp r)) abstractEnv)

      ;

      (* Slicing expression *)

      let e_salsa, seq =

	Salsa.Rewrite.sliceExpr e_salsa 0 (Salsa.Types.Nop(Salsa.Types.Lab 0))

      in

      let def_tmps = Salsa.Utils.flatten_seq seq [] in

      (* Registering tmp ids in vars_env *)

      let vars_env', new_local_vars = List.fold_left

	(fun (vs,vars) (id, _) ->

	  let vdecl = Corelang.mk_fresh_var

	    nodename

	    Location.dummy_loc

	    e.MT.value_type

	    (Clocks.new_var true)

	  in

	  let vs' =

		vdecl = vdecl ;

	  in

	  let vars' = Vars.add vdecl vars in

	  vs', vars'

	)

	(vars_env,Vars.empty)

	def_tmps

      in 

      (* Debug *)

      if !debug then (

	Log.report ~level:3 (fun fmt ->

	  Format.fprintf  fmt "List of slices: @[<v 0>%a@]@ "

	    (Utils.fprintf_list

	       ~sep:"@ "

	       (fun fmt (id, e_id) ->

		 Format.fprintf fmt "(%s,%a) -> %a"

		   id

		   Printers.pp_var (get_var vars_env' id).vdecl

		   (C_backend_common.pp_c_val "" (C_backend_common.pp_c_var_read m)) (salsa_expr2value_t vars_env' constEnv e_id)

	       )

	    )

	    def_tmps;

	  Format.eprintf "Sliced expression: %a@ "

	    (C_backend_common.pp_c_val "" (C_backend_common.pp_c_var_read m)) (salsa_expr2value_t vars_env' constEnv e_salsa)

	  ;

	));

      (* Debug *)

      (* Optimize def tmp, and build the associated instructions.  Update the

	 abstract Env with computed ranges *)

      if !debug && List.length def_tmps >= 1 then (

	Log.report ~level:3 (fun fmt -> Format.fprintf fmt "@[<v 3>Optimizing sliced sub-expressions@ ")

      );

      let rev_def_tmp_instrs, ranges =

	List.fold_left (fun (accu_instrs, ranges) (id, e_id) ->

	  (* Format.eprintf "Cleaning/Optimizing %s@." id; *)

	  let e_id', e_range = (*Salsa.MainEPEG.transformExpression id e_id abstractEnv*)

	    opt_num_expr_sliced ranges e_id

	  in

	  let new_e_id' = try salsa_expr2value_t vars_env' constEnv e_id'  with Not_found -> assert false in

	  let vdecl = (get_var vars_env' id).vdecl in

	  let new_local_assign =

	    (* let expr = salsa_expr2value_t vars_env' constEnv e_id' in *)

	    MT.MLocalAssign(vdecl, new_e_id')

	  in

	  let new_local_assign = {

	    MT.instr_desc = new_local_assign;

	    MT.lustre_eq = None (* could be Corelang.mkeq Location.dummy_loc

				   ([vdecl.LT.var_id], e_id) provided it is

				   converted as Lustre expression rather than

				   a Machine code value *);

	  }

	  in

	  let new_ranges =

	    match e_range with

	      None -> ranges

	    | Some e_range -> RangesInt.add_def ranges id e_range in

	  new_local_assign::accu_instrs, new_ranges

	) ([], ranges) def_tmps

      in

      if !debug && List.length def_tmps >= 1 then (

	Log.report ~level:3 (fun fmt -> Format.fprintf fmt "@]@ ")

      );

      (* Format.eprintf "Optimizing main expression %s@.AbstractEnv is %a" (Salsa.Print.printExpression e_salsa) RangesInt.pp ranges; *)

      let expr_salsa, expr_range = opt_num_expr_sliced ranges e_salsa in

      let expr = try salsa_expr2value_t vars_env' constEnv expr_salsa   with Not_found -> assert false in

      expr, expr_range, List.rev rev_def_tmp_instrs, new_local_vars

    fun v (accu_instr, accu_ranges, accu_new_locals) -> 

	let e, r, il, new_v_locals =

	  optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv v_def

	in

	  (il@((Corelang.mkinstr instr_desc)::accu_instr)), 

	    (

	      match r with 

	      | None -> ranges 

	      | Some v_r -> RangesInt.add_def ranges v.LT.var_id v_r),

	    (Vars.union accu_new_locals new_v_locals)

	if !Options.output = "lustre" then accu_instr, ranges, Vars.empty else (Format.eprintf "@?"; assert false)

  ) ordered_vars ([], ranges, Vars.empty)

    let instrs, ranges', new_expr_locals = assign_vars printed_vars ranges formalEnv vars_to_print in

    [], (* No more vars to be printed *)

    Vars.empty

       let hd_instrs, ranges, formalEnv, printed_vars, vars_to_print, hd_new_locals =

	   vars_to_print,              (* no more or less variables to print *)

	   Vars.empty              (* no new locals *)

	   let instrs', ranges', expr_new_locals = (* printing vd = optimized vt *)

	   Vars.add vd printed_vars,         (* adding vd to new printed vars *)

	   Vars.remove vd vars_to_print,     (* removed vd from variables to print *)

	   expr_new_locals                   (* adding sliced vardecl to the list *)

	   let instrs', ranges', expr_new_locals = (* printing vd = optimized vt *)

	   formalEnv,                        (* formelEnv already updated *)

	   Vars.add vd printed_vars,         (* adding vd to new printed vars *)

	   Vars.remove vd vars_to_print,     (* removed vd from variables to print *)

	   expr_new_locals                   (* adding sliced vardecl to the list *)

	   let prefix_instr, ranges, new_expr_dep_locals  = 

	   let vt', _, il, expr_new_locals = optimize_expr nodename m constEnv (Vars.union required_vars printed_vars) vars_env ranges formalEnv vt in

	   Vars.diff vars_to_print written_vars, (* removed vd + dependencies from

	   (Vars.union new_expr_dep_locals expr_new_locals)

	   let vtl', vtl_ranges, il, args_new_locals = List.fold_right2 (

	     fun e typ_e (exprl, range_l, il_l, new_locals)-> 

		 let e', r', il, new_expr_locals =

		   optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e

		 in

		 e'::exprl, r'::range_l, il@il_l, Vars.union new_locals new_expr_locals

		 e::exprl, None::range_l, il_l, new_locals

	   ) vtl tin ([], [], [], Vars.empty) 

	   Vars.diff vars_to_print written_vars,

	   args_new_locals

	    let required_vars = get_expr_real_vars vt in

	    let required_vars = Vars.diff required_vars printed_vars in (* remove

									   already

									   produced

									   variables *)

	    let vt', _, prefix_instr, prefix_new_locals = optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv vt in

	    let new_locals = prefix_new_locals in

	   let branches', written_vars, merged_ranges, new_locals = List.fold_right (

	     fun (b_l, b_instrs) (new_branches, written_vars, merged_ranges, new_locals) -> 

	       let b_instrs', b_ranges, b_formalEnv, b_printed, b_vars, b_new_locals = 

	       RangesInt.merge merged_ranges b_ranges,

	       Vars.union new_locals b_new_locals

	   ) branches ([], required_vars, ranges, new_locals)

	   in

	   merged_ranges, (* Only step functions call within branches may have

			     produced new ranges. We merge this data by

			     computing the join per variable *)

	   formalEnv,    (* Thanks to the computation of var_to_print in each

			    branch, no new definition should have been computed

			    without being already printed *)

	   Vars.union written_vars printed_vars,

	   Vars.diff vars_to_print written_vars (* We remove vars that have been

						   produced within branches *),

	   new_locals

	   ranges,                          (* no new range computed *)

	   formalEnv,                       (* no formelEnv update *)

	   printed_vars,

	   vars_to_print,                   (* no more or less variables to print *)

	   Vars.empty                       (* no new slides vars *)

       let tl_instrs, ranges, formalEnv, printed_vars, vars_to_print, tl_new_locals = 

       vars_to_print,

       (Vars.union hd_new_locals tl_new_locals)

  let new_instrs, _, _, printed_vars, _, new_locals = 

      vars_to_print

  let locals = locals @ Vars.elements  new_locals in