CristalCaveGem » LustreC

AC_PATH_PROG([OCAMLC],[ocamlc],[:])

AC_MSG_CHECKING(OCaml version)

ocamlc_version=`$OCAMLC -v | grep version | rev| cut -d \  -f 1 | rev`

major=`echo $ocamlc_version | cut -d . -f 1`

minor=`echo $ocamlc_version | cut -d . -f 2`

if (test "$major" -lt 3 -a "$minor" -lt 12 ); then

  AC_MSG_ERROR([Ocaml version must be at least 3.12. You have version $ocamlc_version])

fi

AC_MSG_RESULT(valid ocaml version detected: $ocamlc_version)

AC_PATH_PROG([OCAMLBUILD],[ocamlbuild],[:])

# Checking libs

   ocamlgraph_lib=`find $OCAMLGRAPH_PATH -iname graph.cmxa -nowarn | grep -m 1 -o "graph.cmxa"`

	ocamlgraph_lib_full=`find $OCAMLGRAPH_PATH -iname graph.cmxa -nowarn | grep -m 1 "graph.cmxa"`

      AC_MSG_RESULT($ocamlgraph_lib_full )

   else 

AC_CHECK_LIB(gmp, __gmpz_init, 

      [gmp=yes],

      [AC_MSG_RESULT([GNU MP not found])

      gmp=no])

AC_CHECK_LIB(mpfr, mpfr_add, [mpfr=yes], 

		   [AC_MSG_RESULT(

[MPFR not found])

mpfr=no])

                 src/myocamlbuild.ml

AC_MSG_NOTICE(******** Configuration ********)

AC_MSG_NOTICE(bin path:     $prefix/bin)

AC_MSG_NOTICE(include path: $prefix/include)

AC_MSG_NOTICE(********    Plugins    ********)

  if (test "x$gmp" = xyes -a "x$mpfr" = xyes ); then

       AC_MSG_NOTICE([-mpfr option enable])

   else 

       AC_MSG_WARN([MPFR option cannot be activated. Requires GMP and MPFR libs])

   fi

AC_MSG_NOTICE

AC_MSG_NOTICE(******** Configuration ********)

AC_MSG_NOTICE(******** Configuration ********)

"plugins/mpfr": include

  Plugins.c_backend_main_loop_body_suffix fmt ();

  if Plugins.check_force_stateful () then

  let machine_code = Plugins.refine_machine_code prog machine_code in

    let options = Options.options @ (Plugins.options ()) in

    (* salsa_enabled := false; (* We deactivate salsa *) TODO *)

module type PluginType =

sig

  val name: string

  val activate: unit -> unit

  val options: (string * Arg.spec * string) list

  val check_force_stateful : unit -> bool

  val refine_machine_code: LustreSpec.top_decl list ->

    Machine_code.machine_t list -> Machine_code.machine_t list

  val c_backend_main_loop_body_suffix : Format.formatter ->  unit -> unit

end

module Default =

struct

  let check_force_stateful () = false

  let refine_machine_code prog machines = machines

  let c_backend_main_loop_body_suffix fmt () = ()

end

let plugins =

  [

    (module Scopes.Plugin : PluginType.PluginType);

    (module Salsa_plugin.Plugin : PluginType.PluginType)

  ]

let options () = 

  List.flatten (

    List.map Options.plugin_opt (

      List.map (fun m ->

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

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

      ) plugins

    ))

let check_force_stateful () =

  List.exists (fun m ->

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

	M.check_force_stateful ()

  ) plugins

let refine_machine_code prog machine_code =

  List.fold_left (fun accu m ->

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

    M.refine_machine_code prog accu

  ) machine_code plugins

let c_backend_main_loop_body_suffix fmt () = 

  List.iter (fun (m: (module PluginType.PluginType)) -> 

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

    M.c_backend_main_loop_body_suffix fmt ()) plugins

(* Specific treatment of annotations when inlining, specific of declared plugins *)

(********************************************************************)

(*                                                                  *)

(*  The LustreC compiler toolset   /  The LustreC Development Team  *)

(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)

(*                                                                  *)

(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)

(*  under the terms of the GNU Lesser General Public License        *)

(*  version 2.1.                                                    *)

(*                                                                  *)

(********************************************************************)

open Utils

open LustreSpec

open Corelang

open Normalization

open Machine_code

let mpfr_module = mktop (Open(false, "mpfr_lustre"))

let mpfr_rnd () = "MPFR_RNDN"

let mpfr_prec () = !Options.mpfr_prec

let inject_id = "MPFRId"

let inject_copy_id = "mpfr_set"

let inject_real_id = "mpfr_set_flt"

let inject_init_id = "mpfr_init2"

let inject_clear_id = "mpfr_clear"

let mpfr_t = "mpfr_t"

let unfoldable_value value =

  not (Types.is_real_type value.value_type && is_const_value value)

let inject_id_id expr =

  let e = mkpredef_call expr.expr_loc inject_id [expr] in

  { e with

    expr_type = Type_predef.type_real;

    expr_clock = expr.expr_clock;

  }

let pp_inject_real pp_var fmt var value =

  Format.fprintf fmt "%s(%a, %a, %s);"

    inject_real_id

    pp_var var

    pp_var value

    (mpfr_rnd ())

let inject_assign expr =

  let e = mkpredef_call expr.expr_loc inject_copy_id [expr] in

  { e with

    expr_type = Type_predef.type_real;

    expr_clock = expr.expr_clock;

  }

let pp_inject_copy pp_var fmt var value =

  Format.fprintf fmt "%s(%a, %a, %s);"

    inject_copy_id

    pp_var var

    pp_var value

    (mpfr_rnd ())

let rec pp_inject_assign pp_var fmt var value =

  if is_const_value value

  then

    pp_inject_real pp_var fmt var value

  else

    pp_inject_copy pp_var fmt var value

let pp_inject_init pp_var fmt var =

  Format.fprintf fmt "%s(%a, %i);"

    inject_init_id

    pp_var var

    (mpfr_prec ())

let pp_inject_clear pp_var fmt var =

  Format.fprintf fmt "%s(%a);"

    inject_clear_id

    pp_var var

let base_inject_op id =

  match id with

  | "+"      -> "MPFRPlus"

  | "-"      -> "MPFRMinus"

  | "*"      -> "MPFRTimes"

  | "/"      -> "MPFRDiv"

  | "uminus" -> "MPFRUminus"

  | "<="     -> "MPFRLe"

  | "<"      -> "MPFRLt"

  | ">="     -> "MPFRGe"

  | ">"      -> "MPFRGt"

  | "="      -> "MPFREq"

  | "!="     -> "MPFRNeq"

  | _        -> raise Not_found

let inject_op id =

  try

    base_inject_op id

  with Not_found -> id

let homomorphic_funs =

  List.fold_right (fun id res -> try base_inject_op id :: res with Not_found -> res) Basic_library.internal_funs []

let is_homomorphic_fun id =

  List.mem id homomorphic_funs

let inject_call expr =

  match expr.expr_desc with

  | Expr_appl (id, args, None) when not (Basic_library.is_expr_internal_fun expr) ->

    { expr with expr_desc = Expr_appl (inject_op id, args, None) }

  | _ -> expr

let expr_of_const_array expr =

  match expr.expr_desc with

  | Expr_const (Const_array cl) ->

    let typ = Types.array_element_type expr.expr_type in

    let expr_of_const c =

      { expr_desc = Expr_const c;

	expr_type = typ;

	expr_clock = expr.expr_clock;

	expr_loc = expr.expr_loc;

	expr_delay = Delay.new_var ();

	expr_annot = None;

	expr_tag = new_tag ();

      }

    in { expr with expr_desc = Expr_array (List.map expr_of_const cl) }

  | _                           -> assert false

(* inject_<foo> : defs * used vars -> <foo> -> (updated defs * updated vars) * normalized <foo> *)

let rec inject_list alias node inject_element defvars elist =

  List.fold_right

    (fun t (defvars, qlist) ->

      let defvars, norm_t = inject_element alias node defvars t in

      (defvars, norm_t :: qlist)

    ) elist (defvars, [])

let rec inject_expr ?(alias=true) node defvars expr =

let res=

  match expr.expr_desc with

  | Expr_const (Const_real _)  -> mk_expr_alias_opt alias node defvars expr

  | Expr_const (Const_array _) -> inject_expr ~alias:alias node defvars (expr_of_const_array expr)

  | Expr_const (Const_struct _) -> assert false

  | Expr_ident _

  | Expr_const _  -> defvars, expr

  | Expr_array elist ->

    let defvars, norm_elist = inject_list alias node (fun _ -> inject_expr ~alias:true) defvars elist in

    let norm_expr = { expr with expr_desc = Expr_array norm_elist } in

    defvars, norm_expr

  | Expr_power (e1, d) ->

    let defvars, norm_e1 = inject_expr node defvars e1 in

    let norm_expr = { expr with expr_desc = Expr_power (norm_e1, d) } in

    defvars, norm_expr

  | Expr_access (e1, d) ->

    let defvars, norm_e1 = inject_expr node defvars e1 in

    let norm_expr = { expr with expr_desc = Expr_access (norm_e1, d) } in

    defvars, norm_expr

  | Expr_tuple elist -> 

    let defvars, norm_elist =

      inject_list alias node (fun alias -> inject_expr ~alias:alias) defvars elist in

    let norm_expr = { expr with expr_desc = Expr_tuple norm_elist } in

    defvars, norm_expr

  | Expr_appl (id, args, r) ->

    let defvars, norm_args = inject_expr node defvars args in

    let norm_expr = { expr with expr_desc = Expr_appl (id, norm_args, r) } in

    mk_expr_alias_opt alias node defvars (inject_call norm_expr)

  | Expr_arrow _ -> defvars, expr

  | Expr_pre e ->

    let defvars, norm_e = inject_expr node defvars e in

    let norm_expr = { expr with expr_desc = Expr_pre norm_e } in

    defvars, norm_expr

  | Expr_fby (e1, e2) ->

    let defvars, norm_e1 = inject_expr node defvars e1 in

    let defvars, norm_e2 = inject_expr node defvars e2 in

    let norm_expr = { expr with expr_desc = Expr_fby (norm_e1, norm_e2) } in

    defvars, norm_expr

  | Expr_when (e, c, l) ->

    let defvars, norm_e = inject_expr node defvars e in

    let norm_expr = { expr with expr_desc = Expr_when (norm_e, c, l) } in

    defvars, norm_expr

  | Expr_ite (c, t, e) ->

    let defvars, norm_c = inject_expr node defvars c in

    let defvars, norm_t = inject_expr node defvars t in

    let defvars, norm_e = inject_expr node defvars e in

    let norm_expr = { expr with expr_desc = Expr_ite (norm_c, norm_t, norm_e) } in

    defvars, norm_expr

  | Expr_merge (c, hl) ->

    let defvars, norm_hl = inject_branches node defvars hl in

    let norm_expr = { expr with expr_desc = Expr_merge (c, norm_hl) } in

    defvars, norm_expr

in

(*Format.eprintf "inject_expr %B %a = %a@." alias Printers.pp_expr expr Printers.pp_expr (snd res);*)

res

and inject_branches node defvars hl =

 List.fold_right

   (fun (t, h) (defvars, norm_q) ->

     let (defvars, norm_h) = inject_expr node defvars h in

     defvars, (t, norm_h) :: norm_q

   )

   hl (defvars, [])

let rec inject_eq node defvars eq =

  let (defs', vars'), norm_rhs = inject_expr ~alias:false node defvars eq.eq_rhs in

  let norm_eq = { eq with eq_rhs = norm_rhs } in

  norm_eq::defs', vars'

(** normalize_node node returns a normalized node, 

    ie. 

    - updated locals

    - new equations

    - 

*)

let inject_node node = 

  cpt_fresh := 0;

  let inputs_outputs = node.node_inputs@node.node_outputs in

  let is_local v =

    List.for_all ((!=) v) inputs_outputs in

  let orig_vars = inputs_outputs@node.node_locals in

  let defs, vars = 

    List.fold_left (inject_eq node) ([], orig_vars) (get_node_eqs node) in

  (* Normalize the asserts *)

  let vars, assert_defs, asserts = 

    List.fold_left (

    fun (vars, def_accu, assert_accu) assert_ ->

      let assert_expr = assert_.assert_expr in

      let (defs, vars'), expr = 

	inject_expr 

	  ~alias:false 

	  node 

	  ([], vars) (* defvar only contains vars *)

	  assert_expr

      in

      vars', defs@def_accu, {assert_ with assert_expr = expr}::assert_accu

    ) (vars, [], []) node.node_asserts in

  let new_locals = List.filter is_local vars in

  (* Compute traceability info: 

     - gather newly bound variables

     - compute the associated expression without aliases     

  *)

  (* let diff_vars = List.filter (fun v -> not (List.mem v node.node_locals)) new_locals in *)

  let node =

  { node with 

    node_locals = new_locals; 

    node_stmts = List.map (fun eq -> Eq eq) (defs @ assert_defs);

  }

  in ((*Printers.pp_node Format.err_formatter node;*) node)

let inject_decl decl =

  match decl.top_decl_desc with

  | Node nd ->

    {decl with top_decl_desc = Node (inject_node nd)}

  | Open _ | ImportedNode _ | Const _ | TypeDef _ -> decl

let inject_prog decls = 

  List.map inject_decl decls

(* Local Variables: *)

(* compile-command:"make -C .." *)

(* End: *)

open Format 

open LustreSpec

let salsa_enabled = ref false

    (* "-salsa", Arg.Set salsa_enabled, "activate Salsa optimization <default>"; *)

    (* "-no-salsa", Arg.Clear salsa_enabled, "deactivate Salsa optimization"; *)

module Plugin =

(struct

  include PluginType.Default

  let name = "salsa"

  let options = [

  ]

  let activate () = salsa_enabled := true

  let refine_machine_code prog machine_code = 

    if !salsa_enabled then

      begin

	Compiler_common.check_main ();

	Log.report ~level:1 (fun fmt -> fprintf fmt ".. salsa machines optimization (phase 3)@ ");

	(* Selecting float constants for Salsa *)

	let constEnv = List.fold_left (

	  fun accu c_topdecl ->

	    match c_topdecl.top_decl_desc with

	    | Const c when Types.is_real_type c.const_type  ->

	      (c.const_id, c.const_value) :: accu

	    | _ -> accu

	) [] (Corelang.get_consts prog) 

	in

	List.map 

	  (Machine_salsa_opt.machine_t2machine_t_optimized_by_salsa constEnv) 

	  machine_code 

      end

    else

      machine_code

 end: PluginType.PluginType)

module Plugin : PluginType.PluginType =

    (* Options.salsa_enabled := false; (\* No salsa *\) TODO *)

  let check_force_stateful () = true

  let refine_machine_code prog machine_code =

    if show_scopes () then

      begin

	let all_scopes = compute_scopes prog !Options.main_node in

      (* Printing scopes *)

      if !Options.verbose_level >= 1 then

	Format.printf "Possible scopes are:@   ";

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

	exit 0

      end;

    if is_active () then

      process_scopes !Options.main_node prog machine_code

    else

      machine_code

  let c_backend_main_loop_body_suffix fmt () =

    if is_active () then

      begin

	Format.fprintf fmt "@ %t" pp 

      end;