CristalCaveGem » LustreC

let report ?(plugins="") ?(verbose_level=Options.verbose_level) ~level:level p =

  let plugins = if plugins = "" then plugins else plugins ^ " " in 

  if !verbose_level >= level then

    Format.eprintf "%s%t" plugins p;

  Plugins.init ();

let plugin_opt (name, activate, usage, options) =

  let usage () =

    Format.printf "@[<v 2>Plugin %s:@ %t@]@." name usage;

    exit 0

  in

  ( "-" ^ name ^ "-help" , Arg.Unit usage, "plugin " ^ name ^ " help") ::

  val usage: Format.formatter -> unit

  val init: unit -> unit

  struct

    let usage fmt = Format.fprintf fmt "No specific help." 

    let init () = ()

    let check_force_stateful () = false

    let refine_machine_code prog machines = machines

    let c_backend_main_loop_body_prefix basename mname fmt () = ()

    let c_backend_main_loop_body_suffix fmt () = ()

  end

	(M.name, M.activate, M.usage, M.options)

let init () =

  List.iter (fun m ->

      let module M = (val m : PluginType.PluginType) in

      M.init ()

    ) plugins

let report = Log.report ~plugins:"[salsa]" ~verbose_level:Salsa.Log.verbose_level 

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

                                  "Launching analysis: %s@ "

                                  (Salsa.Print.printExpression e_salsa));

    report ~level:2 (fun fmt -> Format.fprintf fmt " Analysis done: %s@ "

      (Salsa.Print.printExpression new_e_salsa));

    report ~level:2 (fun fmt -> Format.fprintf fmt " Computing range progress@ ");

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

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

      | true, false ->

         report ~level:2 (fun fmt ->

             Format.fprintf fmt

               "CAREFUL --- new range is worse!. Restoring provided expression@ ");

 	     e_salsa, Some old_val

        report ~level:2 (fun fmt ->

            Format.fprintf fmt

	      "Error; new range is not comparable with old end. It may need some investigation!@. ";

	    Format.fprintf fmt "old: %a@.new: %a@ "

	      RangesInt.pp_val old_val

	      RangesInt.pp_val e_val);

    report ~level:2 (fun fmt -> Format.fprintf fmt " Computing range done@ ");

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

    report ~level:2 (fun fmt ->

	    (* TODO xavier: comment recuperer le type de l'expression? Parfois e.value_type vaut 'd *)

	    (Types.is_real_type e.value_type ||  Types.is_real_type v.LT.var_type) 

	      fun arg (al, il, nl) ->

      | Access _

      | Power _ -> assert false  

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

	                            (MC.pp_val m) e);

      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)

	                                (MC.pp_val m) (salsa_expr2value_t vars_env constEnv e_salsa));

      if !debug then report ~level:2 (fun fmt -> Format.fprintf fmt  "Some free vars, not optimizing@ ");

      if !debug then report ~level:3 (fun fmt -> Format.fprintf fmt "  ranges: %a@ "

	                                               RangesInt.pp ranges);

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

	                                  (C_backend_common.pp_c_val m "" (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 =

	  try

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

	  with _ -> Format.eprintf "Issues rewriting express %s@.@?" (Salsa.Print.printExpression e_salsa); assert false

        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' =

	                                      VarEnv.add

	                                        id

	                                        {

		                                  vdecl = vdecl ;

		                                  is_local = true;

	                                        }

	                                        vs

	                                    in

	                                    let vars' = Vars.add vdecl vars in

	                                    vs', vars'

	                                  )

	                                  (vars_env,Vars.empty)

	                                  def_tmps

        in 

        (* Debug *)

        if !debug then (

	  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 m "" (C_backend_common.pp_c_var_read m)) (salsa_expr2value_t vars_env' constEnv e_id)

	           )

	        )

	        def_tmps;

	      Format.fprintf fmt "Sliced expression: %a@ "

	        (C_backend_common.pp_c_val m "" (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

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

	  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

	        }

	      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 (

	  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

    (* ???? Bout de code dans unstable lors du merge avec salsa ? 

     *)

  if !debug then report ~level:4 (fun fmt -> Format.fprintf fmt

      if !debug then report ~level:4 (fun fmt -> Format.fprintf fmt "Printing assign for variable %s@ " v.LT.var_id);

      if !debug then report ~level:2 (fun fmt -> Format.fprintf fmt  "Unused local vars: [%a]. Removing them.@ "

    if !debug then report ~level:2 (fun fmt -> Format.fprintf fmt "@[<v 3>Optimizing machine %s@ " mt.MT.mname.LT.node_id);

    if !debug then report ~level:2 (fun fmt -> Format.fprintf fmt "@]@ ");

        "-verbose", Arg.Set_int Salsa.Log.verbose_level, "salsa plugin verbose level (default is 0)";

  let activate () =

    salsa_enabled := true

  let init () =

    if !salsa_enabled then

      if  !SalsaDatatypes.debug then

        Salsa.Log.debug := true

  struct

    include PluginType.Default

    let name = "scopes"

    let is_active () = 

      !option_scopes || !option_show_scopes || !option_all_scopes

    (* || !option_mem_scopes || !option_input_scopes *)

    let show_scopes () = 

      !option_show_scopes && (

        Compiler_common.check_main ();

        true)

    let usage fmt =

      let open Format in

      fprintf fmt "@[<hov 0>Scopes@ enrich@ the@ internal@ memories@ to@ record@ all@ or@ a@ selection@ of@ internals.@ In@ conjunction@ with@ the@ trace@ option@ of@ the@ produced@ binary@ it@ can@ also@ record@ these@ flow@ values@ within@ separated@ log@ files.@]@ @ ";

      fprintf fmt "Options are:@ "

    let options = [

        "-select", Arg.String register_scopes, "specifies which variables to log";

        "-input", Arg.String register_inputs, "specifies the simulation input";

        "-show-possible-scopes", Arg.Set option_show_scopes, "list possible variables to log";

        "-select-all", Arg.Unit register_all_scopes, "select all possible variables to log";

(* "-select-mems", Arg.Set option_mems_scopes, "select all memory variables to log";

 * "-select-inputs", Arg.Set option_input_scopes, "select all input variables to log"; *)

      ]

        (* Printing scopes *)

        if !Options.verbose_level >= 1 then 

	  Format.printf "Possible scopes are:@ ";

	Format.printf "@[<v 0>%a@ @]@.@?" print_scopes all_scopes;