Project

General

Profile

« Previous | Next » 

Revision f6acf47b

Added by Pierre-Loïc Garoche over 8 years ago

Plugin based framework

View differences:

configure.ac
7 7

  
8 8
AC_CONFIG_SRCDIR([src/main_lustre_compiler.ml])
9 9

  
10
AC_PATH_PROG([OCAMLC],[ocamlc],[:])
11
AC_MSG_CHECKING(OCaml version)
12
ocamlc_version=`$OCAMLC -v | grep version | rev| cut -d \  -f 1 | rev`
13
major=`echo $ocamlc_version | cut -d . -f 1`
14
minor=`echo $ocamlc_version | cut -d . -f 2`
15
if (test "$major" -lt 3 -a "$minor" -lt 12 ); then
16
  AC_MSG_ERROR([Ocaml version must be at least 3.12. You have version $ocamlc_version])
17
fi
18
AC_MSG_RESULT(valid ocaml version detected: $ocamlc_version)
19

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

  
22

  
10 23
# default prefix is /usr/local
11 24
AC_PREFIX_DEFAULT(/usr/local)
12 25

  
26
# Checking libs
27

  
13 28
AC_ARG_WITH([ocamlgraph-path],
14 29
        [AS_HELP_STRING([--ocamlgraph-path],
15 30
              [specify the path of ocamlgraph library. graph.cmxa should be in ocamlgraph-path @<:@default=$(ocamlfind query ocamlgraph)@:>@])],
......
23 38
)
24 39
AC_SUBST(OCAMLGRAPH_PATH)
25 40

  
26

  
27
AC_PATH_PROG([OCAMLC],[ocamlc],[:])
28
AC_MSG_CHECKING(OCaml version)
29
ocamlc_version=`$OCAMLC -v | grep version | rev| cut -d \  -f 1 | rev`
30
major=`echo $ocamlc_version | cut -d . -f 1`
31
minor=`echo $ocamlc_version | cut -d . -f 2`
32
if (test "$major" -lt 3 -a "$minor" -lt 11 ); then
33
  AC_MSG_ERROR([Ocaml version must be at least 3.11. You have version $ocamlc_version])
34
fi
35
AC_MSG_RESULT(valid ocaml version detected: $ocamlc_version)
36

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

  
39

  
40
# Checking libs
41

  
42
# Checks for libraries. OCamlgraph
43 41
AC_MSG_CHECKING(ocamlgraph library)
44
   ocamlgraph_lib=`find $OCAMLGRAPH_PATH -iname graph.cmxa | grep -m 1 -o "graph.cmxa"`
42
   ocamlgraph_lib=`find $OCAMLGRAPH_PATH -iname graph.cmxa -nowarn | grep -m 1 -o "graph.cmxa"`
45 43
   if (test "x$ocamlgraph_lib" = xgraph.cmxa ); then
46
	ocamlgraph_lib_full=`find $OCAMLGRAPH_PATH -iname graph.cmxa  | grep -m 1 "graph.cmxa"`
47
      AC_MSG_RESULT(library detected: $ocamlgraph_lib_full )
48
   else
44
	ocamlgraph_lib_full=`find $OCAMLGRAPH_PATH -iname graph.cmxa -nowarn | grep -m 1 "graph.cmxa"`
45
      AC_MSG_RESULT($ocamlgraph_lib_full )
46
   else 
49 47
      AC_MSG_ERROR([ocamlgraph library not installed in $OCAMLGRAPH_PATH])
50 48
   fi
51 49

  
50
AC_CHECK_LIB(gmp, __gmpz_init, 
51
      [gmp=yes],
52
      [AC_MSG_RESULT([GNU MP not found])
53
      gmp=no])
54

  
55
AC_CHECK_LIB(mpfr, mpfr_add, [mpfr=yes], 
56
		   [AC_MSG_RESULT(
57
[MPFR not found])
58
mpfr=no])
59

  
52 60

  
53 61
# Workaround to solve an issue with ocamlbuild and C libraries.
54 62
# oCFLAGS="$CFLAGS"
......
86 94
# Instanciation
87 95
AC_CONFIG_FILES([Makefile
88 96
		 src/Makefile
89
 		 src/myocamlbuild.ml
97
                 src/myocamlbuild.ml
90 98
		 src/version.ml])
91 99

  
92 100
AC_OUTPUT
93 101

  
94 102

  
95 103
# summary
96
dnl AC_MSG_NOTICE(******** Configuration ********)
104
AC_MSG_NOTICE(******** Configuration ********)
105
AC_MSG_NOTICE(bin path:     $prefix/bin)
106
AC_MSG_NOTICE(include path: $prefix/include)
107
AC_MSG_NOTICE(********    Plugins    ********)
108

  
109
  if (test "x$gmp" = xyes -a "x$mpfr" = xyes ); then
110
       AC_MSG_NOTICE([-mpfr option enable])
111

  
112
   else 
113
       AC_MSG_WARN([MPFR option cannot be activated. Requires GMP and MPFR libs])
114
      
115
   fi
116
 
117
AC_MSG_NOTICE
118
AC_MSG_NOTICE(******** Configuration ********)
119
AC_MSG_NOTICE(******** Configuration ********)
120

  
src/_tags
2 2
"backends/Horn": include
3 3
"plugins/salsa": include
4 4
"plugins/scopes": include
5
"plugins/mpfr": include
5 6
<**/.svn>: -traverse
6 7
<**/.svn>: not_hygienic
7 8
"main_lustre_compiler.native": use_graph
src/backends/C/c_backend_main.ml
139 139
  print_main_memory_allocation mname main_mem fmt m;
140 140
  print_main_initialize mname main_mem fmt m;
141 141
  print_main_loop mname main_mem fmt m;
142
  if Scopes.Plugin.is_active () then
143
    begin
144
      fprintf fmt "@ %t" Scopes.Plugin.pp 
145
    end;    
142

  
143
  Plugins.c_backend_main_loop_body_suffix fmt ();
146 144
  fprintf fmt "@]@ }@ @ ";
147 145
  print_main_clear mname main_mem fmt m;
148 146
  fprintf fmt "@ return 1;";
src/global.ml
3 3
let basename = ref ""
4 4
let main_node = ref ""
5 5

  
6

  
6 7
module TypeEnv =
7 8
struct
8 9
let lookup_value ident = Env.lookup_value !type_env ident
src/main_lustre_compiler.ml
112 112
  in
113 113

  
114 114
  (* Checking stateless/stateful status *)
115
  if Scopes.Plugin.is_active () then
115
  if Plugins.check_force_stateful () then
116 116
    force_stateful_decls prog
117 117
  else
118 118
    check_stateless_decls prog;
......
275 275
  in
276 276
  
277 277
  (* Salsa optimize machine code *)
278
  let machine_code = 
279
    if !Options.salsa_enabled then
280
      begin
281
	check_main ();
282
	Log.report ~level:1 (fun fmt -> fprintf fmt ".. salsa machines optimization (phase 3)@ ");
283
	(* Selecting float constants for Salsa *)
284
	let constEnv = List.fold_left (
285
	  fun accu c_topdecl ->
286
	    match c_topdecl.top_decl_desc with
287
	    | Const c when Types.is_real_type c.const_type  ->
288
	      (c.const_id, c.const_value) :: accu
289
	    | _ -> accu
290
	) [] (Corelang.get_consts prog) 
291
	in
292
	List.map 
293
	  (Machine_salsa_opt.machine_t2machine_t_optimized_by_salsa constEnv) 
294
	  machine_code 
295
      end
296
    else
297
      machine_code
298
  in
299 278
  Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@ "
300 279
    (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
301 280
    machine_code);
......
391 370
  let machine_code = 
392 371
    stage2 prog 
393 372
  in
394
  if Scopes.Plugin.show_scopes () then
395
    begin
396
      let all_scopes = Scopes.compute_scopes prog !Options.main_node in
397
      (* Printing scopes *)
398
      if !Options.verbose_level >= 1 then
399
	Format.printf "Possible scopes are:@   ";
400
      Format.printf "@[<v>%a@ @]@.@?" Scopes.print_scopes all_scopes;
401
      exit 0
402
	
403
    end;
404 373

  
405
  let machine_code = 
406
    if Scopes.Plugin.is_active () then
407
      Scopes.Plugin.process_scopes !Options.main_node prog machine_code
408
    else
409
      machine_code
410
  in
374
  let machine_code = Plugins.refine_machine_code prog machine_code in
411 375
  
412 376
  stage3 prog machine_code dependencies basename;
413 377
  begin
......
443 407
  try
444 408
    Printexc.record_backtrace true;
445 409

  
446
    let options = Options.options @ 
447
      List.flatten (
448
	List.map Options.plugin_opt [
449
	  Scopes.Plugin.name, Scopes.Plugin.activate, Scopes.Plugin.options
450
	]
451
      )
452
    in
410
    let options = Options.options @ (Plugins.options ()) in
453 411
    
454 412
    Arg.parse options anonymous usage
455 413
  with
src/mpfr.ml
1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11

  
12
open Utils
13
open LustreSpec
14
open Corelang
15
open Normalization
16
open Machine_code
17

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

  
20
let mpfr_rnd () = "MPFR_RNDN"
21

  
22
let mpfr_prec () = !Options.mpfr_prec
23

  
24
let inject_id = "MPFRId"
25

  
26
let inject_copy_id = "mpfr_set"
27

  
28
let inject_real_id = "mpfr_set_flt"
29

  
30
let inject_init_id = "mpfr_init2"
31

  
32
let inject_clear_id = "mpfr_clear"
33

  
34
let mpfr_t = "mpfr_t"
35

  
36
let unfoldable_value value =
37
  not (Types.is_real_type value.value_type && is_const_value value)
38

  
39
let inject_id_id expr =
40
  let e = mkpredef_call expr.expr_loc inject_id [expr] in
41
  { e with
42
    expr_type = Type_predef.type_real;
43
    expr_clock = expr.expr_clock;
44
  }
45

  
46
let pp_inject_real pp_var fmt var value =
47
  Format.fprintf fmt "%s(%a, %a, %s);"
48
    inject_real_id
49
    pp_var var
50
    pp_var value
51
    (mpfr_rnd ())
52

  
53
let inject_assign expr =
54
  let e = mkpredef_call expr.expr_loc inject_copy_id [expr] in
55
  { e with
56
    expr_type = Type_predef.type_real;
57
    expr_clock = expr.expr_clock;
58
  }
59

  
60
let pp_inject_copy pp_var fmt var value =
61
  Format.fprintf fmt "%s(%a, %a, %s);"
62
    inject_copy_id
63
    pp_var var
64
    pp_var value
65
    (mpfr_rnd ())
66

  
67
let rec pp_inject_assign pp_var fmt var value =
68
  if is_const_value value
69
  then
70
    pp_inject_real pp_var fmt var value
71
  else
72
    pp_inject_copy pp_var fmt var value
73

  
74
let pp_inject_init pp_var fmt var =
75
  Format.fprintf fmt "%s(%a, %i);"
76
    inject_init_id
77
    pp_var var
78
    (mpfr_prec ())
79

  
80
let pp_inject_clear pp_var fmt var =
81
  Format.fprintf fmt "%s(%a);"
82
    inject_clear_id
83
    pp_var var
84

  
85
let base_inject_op id =
86
  match id with
87
  | "+"      -> "MPFRPlus"
88
  | "-"      -> "MPFRMinus"
89
  | "*"      -> "MPFRTimes"
90
  | "/"      -> "MPFRDiv"
91
  | "uminus" -> "MPFRUminus"
92
  | "<="     -> "MPFRLe"
93
  | "<"      -> "MPFRLt"
94
  | ">="     -> "MPFRGe"
95
  | ">"      -> "MPFRGt"
96
  | "="      -> "MPFREq"
97
  | "!="     -> "MPFRNeq"
98
  | _        -> raise Not_found
99

  
100
let inject_op id =
101
  try
102
    base_inject_op id
103
  with Not_found -> id
104

  
105
let homomorphic_funs =
106
  List.fold_right (fun id res -> try base_inject_op id :: res with Not_found -> res) Basic_library.internal_funs []
107

  
108
let is_homomorphic_fun id =
109
  List.mem id homomorphic_funs
110

  
111
let inject_call expr =
112
  match expr.expr_desc with
113
  | Expr_appl (id, args, None) when not (Basic_library.is_expr_internal_fun expr) ->
114
    { expr with expr_desc = Expr_appl (inject_op id, args, None) }
115
  | _ -> expr
116

  
117
let expr_of_const_array expr =
118
  match expr.expr_desc with
119
  | Expr_const (Const_array cl) ->
120
    let typ = Types.array_element_type expr.expr_type in
121
    let expr_of_const c =
122
      { expr_desc = Expr_const c;
123
	expr_type = typ;
124
	expr_clock = expr.expr_clock;
125
	expr_loc = expr.expr_loc;
126
	expr_delay = Delay.new_var ();
127
	expr_annot = None;
128
	expr_tag = new_tag ();
129
      }
130
    in { expr with expr_desc = Expr_array (List.map expr_of_const cl) }
131
  | _                           -> assert false
132

  
133
(* inject_<foo> : defs * used vars -> <foo> -> (updated defs * updated vars) * normalized <foo> *)
134
let rec inject_list alias node inject_element defvars elist =
135
  List.fold_right
136
    (fun t (defvars, qlist) ->
137
      let defvars, norm_t = inject_element alias node defvars t in
138
      (defvars, norm_t :: qlist)
139
    ) elist (defvars, [])
140

  
141
let rec inject_expr ?(alias=true) node defvars expr =
142
let res=
143
  match expr.expr_desc with
144
  | Expr_const (Const_real _)  -> mk_expr_alias_opt alias node defvars expr
145
  | Expr_const (Const_array _) -> inject_expr ~alias:alias node defvars (expr_of_const_array expr)
146
  | Expr_const (Const_struct _) -> assert false
147
  | Expr_ident _
148
  | Expr_const _  -> defvars, expr
149
  | Expr_array elist ->
150
    let defvars, norm_elist = inject_list alias node (fun _ -> inject_expr ~alias:true) defvars elist in
151
    let norm_expr = { expr with expr_desc = Expr_array norm_elist } in
152
    defvars, norm_expr
153
  | Expr_power (e1, d) ->
154
    let defvars, norm_e1 = inject_expr node defvars e1 in
155
    let norm_expr = { expr with expr_desc = Expr_power (norm_e1, d) } in
156
    defvars, norm_expr
157
  | Expr_access (e1, d) ->
158
    let defvars, norm_e1 = inject_expr node defvars e1 in
159
    let norm_expr = { expr with expr_desc = Expr_access (norm_e1, d) } in
160
    defvars, norm_expr
161
  | Expr_tuple elist -> 
162
    let defvars, norm_elist =
163
      inject_list alias node (fun alias -> inject_expr ~alias:alias) defvars elist in
164
    let norm_expr = { expr with expr_desc = Expr_tuple norm_elist } in
165
    defvars, norm_expr
166
  | Expr_appl (id, args, r) ->
167
    let defvars, norm_args = inject_expr node defvars args in
168
    let norm_expr = { expr with expr_desc = Expr_appl (id, norm_args, r) } in
169
    mk_expr_alias_opt alias node defvars (inject_call norm_expr)
170
  | Expr_arrow _ -> defvars, expr
171
  | Expr_pre e ->
172
    let defvars, norm_e = inject_expr node defvars e in
173
    let norm_expr = { expr with expr_desc = Expr_pre norm_e } in
174
    defvars, norm_expr
175
  | Expr_fby (e1, e2) ->
176
    let defvars, norm_e1 = inject_expr node defvars e1 in
177
    let defvars, norm_e2 = inject_expr node defvars e2 in
178
    let norm_expr = { expr with expr_desc = Expr_fby (norm_e1, norm_e2) } in
179
    defvars, norm_expr
180
  | Expr_when (e, c, l) ->
181
    let defvars, norm_e = inject_expr node defvars e in
182
    let norm_expr = { expr with expr_desc = Expr_when (norm_e, c, l) } in
183
    defvars, norm_expr
184
  | Expr_ite (c, t, e) ->
185
    let defvars, norm_c = inject_expr node defvars c in
186
    let defvars, norm_t = inject_expr node defvars t in
187
    let defvars, norm_e = inject_expr node defvars e in
188
    let norm_expr = { expr with expr_desc = Expr_ite (norm_c, norm_t, norm_e) } in
189
    defvars, norm_expr
190
  | Expr_merge (c, hl) ->
191
    let defvars, norm_hl = inject_branches node defvars hl in
192
    let norm_expr = { expr with expr_desc = Expr_merge (c, norm_hl) } in
193
    defvars, norm_expr
194
in
195
(*Format.eprintf "inject_expr %B %a = %a@." alias Printers.pp_expr expr Printers.pp_expr (snd res);*)
196
res
197

  
198
and inject_branches node defvars hl =
199
 List.fold_right
200
   (fun (t, h) (defvars, norm_q) ->
201
     let (defvars, norm_h) = inject_expr node defvars h in
202
     defvars, (t, norm_h) :: norm_q
203
   )
204
   hl (defvars, [])
205

  
206

  
207
let rec inject_eq node defvars eq =
208
  let (defs', vars'), norm_rhs = inject_expr ~alias:false node defvars eq.eq_rhs in
209
  let norm_eq = { eq with eq_rhs = norm_rhs } in
210
  norm_eq::defs', vars'
211

  
212
(** normalize_node node returns a normalized node, 
213
    ie. 
214
    - updated locals
215
    - new equations
216
    - 
217
*)
218
let inject_node node = 
219
  cpt_fresh := 0;
220
  let inputs_outputs = node.node_inputs@node.node_outputs in
221
  let is_local v =
222
    List.for_all ((!=) v) inputs_outputs in
223
  let orig_vars = inputs_outputs@node.node_locals in
224
  let defs, vars = 
225
    List.fold_left (inject_eq node) ([], orig_vars) (get_node_eqs node) in
226
  (* Normalize the asserts *)
227
  let vars, assert_defs, asserts = 
228
    List.fold_left (
229
    fun (vars, def_accu, assert_accu) assert_ ->
230
      let assert_expr = assert_.assert_expr in
231
      let (defs, vars'), expr = 
232
	inject_expr 
233
	  ~alias:false 
234
	  node 
235
	  ([], vars) (* defvar only contains vars *)
236
	  assert_expr
237
      in
238
      vars', defs@def_accu, {assert_ with assert_expr = expr}::assert_accu
239
    ) (vars, [], []) node.node_asserts in
240
  let new_locals = List.filter is_local vars in
241
  (* Compute traceability info: 
242
     - gather newly bound variables
243
     - compute the associated expression without aliases     
244
  *)
245
  (* let diff_vars = List.filter (fun v -> not (List.mem v node.node_locals)) new_locals in *)
246
  let node =
247
  { node with 
248
    node_locals = new_locals; 
249
    node_stmts = List.map (fun eq -> Eq eq) (defs @ assert_defs);
250
  }
251
  in ((*Printers.pp_node Format.err_formatter node;*) node)
252

  
253
let inject_decl decl =
254
  match decl.top_decl_desc with
255
  | Node nd ->
256
    {decl with top_decl_desc = Node (inject_node nd)}
257
  | Open _ | ImportedNode _ | Const _ | TypeDef _ -> decl
258
  
259
let inject_prog decls = 
260
  List.map inject_decl decls
261

  
262

  
263
(* Local Variables: *)
264
(* compile-command:"make -C .." *)
265
(* End: *)
src/options.ml
41 41
let horn_cex = ref false
42 42
let horn_queries = ref false
43 43

  
44
let salsa_enabled = ref false
45 44

  
46 45
let set_mpfr prec =
47 46
  if prec > 0 then (
48 47
    mpfr := true;
49 48
    mpfr_prec := prec;
50
    salsa_enabled := false; (* We deactivate salsa *)
49
    (* salsa_enabled := false; (* We deactivate salsa *) TODO *)
51 50
  )
52 51
  else
53 52
    failwith "mpfr requires a positive integer"
......
69 68
    "-horn-traces", Arg.Unit (fun () -> output := "horn"; horntraces:=true), "produce traceability file for Horn backend. Enable the horn backend.";
70 69
    "-horn-cex", Arg.Unit (fun () -> output := "horn"; horn_cex:=true), "generate cex enumeration. Enable the horn backend (work in progress)";
71 70
    "-horn-queries", Arg.Unit (fun () -> output := "horn"; horn_queries:=true), "generate queries in generated Horn file. Enable the horn backend (work in progress)";
72
    "-salsa", Arg.Set salsa_enabled, "activate Salsa optimization <default>";
73
    "-no-salsa", Arg.Clear salsa_enabled, "deactivate Salsa optimization";
74 71
    "-print_reuse", Arg.Set print_reuse, "prints variable reuse policy";
75 72
    "-lustre", Arg.Unit (fun () -> output := "lustre"), "generates Lustre output, performing all active optimizations";
76 73
    "-inline", Arg.Unit (fun () -> global_inline := true; const_unfold := true), "inline all node calls (require a main node). Implies constant unfolding";
src/pluginType.ml
1
module type PluginType =
2
sig
3
  val name: string
4
  val activate: unit -> unit
5
  val options: (string * Arg.spec * string) list
6
  val check_force_stateful : unit -> bool
7
  val refine_machine_code: LustreSpec.top_decl list ->
8
    Machine_code.machine_t list -> Machine_code.machine_t list
9
  val c_backend_main_loop_body_suffix : Format.formatter ->  unit -> unit
10
end
11

  
12
module Default =
13
struct
14
  let check_force_stateful () = false
15
  let refine_machine_code prog machines = machines
16
  let c_backend_main_loop_body_suffix fmt () = ()
17
end
src/plugins.ml
1 1
open LustreSpec
2 2

  
3
module type PluginType =
4
sig
3
let plugins =
4
  [
5
    (module Scopes.Plugin : PluginType.PluginType);
6
    (module Salsa_plugin.Plugin : PluginType.PluginType)
7
  ]
5 8

  
6
end
7 9

  
10
let options () = 
11
  List.flatten (
12
    List.map Options.plugin_opt (
13
      List.map (fun m ->
14
	let module M = (val m : PluginType.PluginType) in
15
	(M.name, M.activate, M.options)
16
      ) plugins
17
    ))
8 18

  
19
let check_force_stateful () =
20
  List.exists (fun m ->
21
	let module M = (val m : PluginType.PluginType) in
22
	M.check_force_stateful ()
23
  ) plugins
24

  
25
let refine_machine_code prog machine_code =
26
  List.fold_left (fun accu m ->
27
    let module M = (val m : PluginType.PluginType) in
28
    M.refine_machine_code prog accu
29
  ) machine_code plugins
30

  
31

  
32
let c_backend_main_loop_body_suffix fmt () = 
33
  List.iter (fun (m: (module PluginType.PluginType)) -> 
34
    let module M = (val m : PluginType.PluginType) in
35
    M.c_backend_main_loop_body_suffix fmt ()) plugins
36

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

  
10 39
let inline_annots rename_var_fun annot_list =
11 40
  List.map (
src/plugins/mpfr/mpfr.ml
1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11

  
12
open Utils
13
open LustreSpec
14
open Corelang
15
open Normalization
16
open Machine_code
17

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

  
20
let mpfr_rnd () = "MPFR_RNDN"
21

  
22
let mpfr_prec () = !Options.mpfr_prec
23

  
24
let inject_id = "MPFRId"
25

  
26
let inject_copy_id = "mpfr_set"
27

  
28
let inject_real_id = "mpfr_set_flt"
29

  
30
let inject_init_id = "mpfr_init2"
31

  
32
let inject_clear_id = "mpfr_clear"
33

  
34
let mpfr_t = "mpfr_t"
35

  
36
let unfoldable_value value =
37
  not (Types.is_real_type value.value_type && is_const_value value)
38

  
39
let inject_id_id expr =
40
  let e = mkpredef_call expr.expr_loc inject_id [expr] in
41
  { e with
42
    expr_type = Type_predef.type_real;
43
    expr_clock = expr.expr_clock;
44
  }
45

  
46
let pp_inject_real pp_var fmt var value =
47
  Format.fprintf fmt "%s(%a, %a, %s);"
48
    inject_real_id
49
    pp_var var
50
    pp_var value
51
    (mpfr_rnd ())
52

  
53
let inject_assign expr =
54
  let e = mkpredef_call expr.expr_loc inject_copy_id [expr] in
55
  { e with
56
    expr_type = Type_predef.type_real;
57
    expr_clock = expr.expr_clock;
58
  }
59

  
60
let pp_inject_copy pp_var fmt var value =
61
  Format.fprintf fmt "%s(%a, %a, %s);"
62
    inject_copy_id
63
    pp_var var
64
    pp_var value
65
    (mpfr_rnd ())
66

  
67
let rec pp_inject_assign pp_var fmt var value =
68
  if is_const_value value
69
  then
70
    pp_inject_real pp_var fmt var value
71
  else
72
    pp_inject_copy pp_var fmt var value
73

  
74
let pp_inject_init pp_var fmt var =
75
  Format.fprintf fmt "%s(%a, %i);"
76
    inject_init_id
77
    pp_var var
78
    (mpfr_prec ())
79

  
80
let pp_inject_clear pp_var fmt var =
81
  Format.fprintf fmt "%s(%a);"
82
    inject_clear_id
83
    pp_var var
84

  
85
let base_inject_op id =
86
  match id with
87
  | "+"      -> "MPFRPlus"
88
  | "-"      -> "MPFRMinus"
89
  | "*"      -> "MPFRTimes"
90
  | "/"      -> "MPFRDiv"
91
  | "uminus" -> "MPFRUminus"
92
  | "<="     -> "MPFRLe"
93
  | "<"      -> "MPFRLt"
94
  | ">="     -> "MPFRGe"
95
  | ">"      -> "MPFRGt"
96
  | "="      -> "MPFREq"
97
  | "!="     -> "MPFRNeq"
98
  | _        -> raise Not_found
99

  
100
let inject_op id =
101
  try
102
    base_inject_op id
103
  with Not_found -> id
104

  
105
let homomorphic_funs =
106
  List.fold_right (fun id res -> try base_inject_op id :: res with Not_found -> res) Basic_library.internal_funs []
107

  
108
let is_homomorphic_fun id =
109
  List.mem id homomorphic_funs
110

  
111
let inject_call expr =
112
  match expr.expr_desc with
113
  | Expr_appl (id, args, None) when not (Basic_library.is_expr_internal_fun expr) ->
114
    { expr with expr_desc = Expr_appl (inject_op id, args, None) }
115
  | _ -> expr
116

  
117
let expr_of_const_array expr =
118
  match expr.expr_desc with
119
  | Expr_const (Const_array cl) ->
120
    let typ = Types.array_element_type expr.expr_type in
121
    let expr_of_const c =
122
      { expr_desc = Expr_const c;
123
	expr_type = typ;
124
	expr_clock = expr.expr_clock;
125
	expr_loc = expr.expr_loc;
126
	expr_delay = Delay.new_var ();
127
	expr_annot = None;
128
	expr_tag = new_tag ();
129
      }
130
    in { expr with expr_desc = Expr_array (List.map expr_of_const cl) }
131
  | _                           -> assert false
132

  
133
(* inject_<foo> : defs * used vars -> <foo> -> (updated defs * updated vars) * normalized <foo> *)
134
let rec inject_list alias node inject_element defvars elist =
135
  List.fold_right
136
    (fun t (defvars, qlist) ->
137
      let defvars, norm_t = inject_element alias node defvars t in
138
      (defvars, norm_t :: qlist)
139
    ) elist (defvars, [])
140

  
141
let rec inject_expr ?(alias=true) node defvars expr =
142
let res=
143
  match expr.expr_desc with
144
  | Expr_const (Const_real _)  -> mk_expr_alias_opt alias node defvars expr
145
  | Expr_const (Const_array _) -> inject_expr ~alias:alias node defvars (expr_of_const_array expr)
146
  | Expr_const (Const_struct _) -> assert false
147
  | Expr_ident _
148
  | Expr_const _  -> defvars, expr
149
  | Expr_array elist ->
150
    let defvars, norm_elist = inject_list alias node (fun _ -> inject_expr ~alias:true) defvars elist in
151
    let norm_expr = { expr with expr_desc = Expr_array norm_elist } in
152
    defvars, norm_expr
153
  | Expr_power (e1, d) ->
154
    let defvars, norm_e1 = inject_expr node defvars e1 in
155
    let norm_expr = { expr with expr_desc = Expr_power (norm_e1, d) } in
156
    defvars, norm_expr
157
  | Expr_access (e1, d) ->
158
    let defvars, norm_e1 = inject_expr node defvars e1 in
159
    let norm_expr = { expr with expr_desc = Expr_access (norm_e1, d) } in
160
    defvars, norm_expr
161
  | Expr_tuple elist -> 
162
    let defvars, norm_elist =
163
      inject_list alias node (fun alias -> inject_expr ~alias:alias) defvars elist in
164
    let norm_expr = { expr with expr_desc = Expr_tuple norm_elist } in
165
    defvars, norm_expr
166
  | Expr_appl (id, args, r) ->
167
    let defvars, norm_args = inject_expr node defvars args in
168
    let norm_expr = { expr with expr_desc = Expr_appl (id, norm_args, r) } in
169
    mk_expr_alias_opt alias node defvars (inject_call norm_expr)
170
  | Expr_arrow _ -> defvars, expr
171
  | Expr_pre e ->
172
    let defvars, norm_e = inject_expr node defvars e in
173
    let norm_expr = { expr with expr_desc = Expr_pre norm_e } in
174
    defvars, norm_expr
175
  | Expr_fby (e1, e2) ->
176
    let defvars, norm_e1 = inject_expr node defvars e1 in
177
    let defvars, norm_e2 = inject_expr node defvars e2 in
178
    let norm_expr = { expr with expr_desc = Expr_fby (norm_e1, norm_e2) } in
179
    defvars, norm_expr
180
  | Expr_when (e, c, l) ->
181
    let defvars, norm_e = inject_expr node defvars e in
182
    let norm_expr = { expr with expr_desc = Expr_when (norm_e, c, l) } in
183
    defvars, norm_expr
184
  | Expr_ite (c, t, e) ->
185
    let defvars, norm_c = inject_expr node defvars c in
186
    let defvars, norm_t = inject_expr node defvars t in
187
    let defvars, norm_e = inject_expr node defvars e in
188
    let norm_expr = { expr with expr_desc = Expr_ite (norm_c, norm_t, norm_e) } in
189
    defvars, norm_expr
190
  | Expr_merge (c, hl) ->
191
    let defvars, norm_hl = inject_branches node defvars hl in
192
    let norm_expr = { expr with expr_desc = Expr_merge (c, norm_hl) } in
193
    defvars, norm_expr
194
in
195
(*Format.eprintf "inject_expr %B %a = %a@." alias Printers.pp_expr expr Printers.pp_expr (snd res);*)
196
res
197

  
198
and inject_branches node defvars hl =
199
 List.fold_right
200
   (fun (t, h) (defvars, norm_q) ->
201
     let (defvars, norm_h) = inject_expr node defvars h in
202
     defvars, (t, norm_h) :: norm_q
203
   )
204
   hl (defvars, [])
205

  
206

  
207
let rec inject_eq node defvars eq =
208
  let (defs', vars'), norm_rhs = inject_expr ~alias:false node defvars eq.eq_rhs in
209
  let norm_eq = { eq with eq_rhs = norm_rhs } in
210
  norm_eq::defs', vars'
211

  
212
(** normalize_node node returns a normalized node, 
213
    ie. 
214
    - updated locals
215
    - new equations
216
    - 
217
*)
218
let inject_node node = 
219
  cpt_fresh := 0;
220
  let inputs_outputs = node.node_inputs@node.node_outputs in
221
  let is_local v =
222
    List.for_all ((!=) v) inputs_outputs in
223
  let orig_vars = inputs_outputs@node.node_locals in
224
  let defs, vars = 
225
    List.fold_left (inject_eq node) ([], orig_vars) (get_node_eqs node) in
226
  (* Normalize the asserts *)
227
  let vars, assert_defs, asserts = 
228
    List.fold_left (
229
    fun (vars, def_accu, assert_accu) assert_ ->
230
      let assert_expr = assert_.assert_expr in
231
      let (defs, vars'), expr = 
232
	inject_expr 
233
	  ~alias:false 
234
	  node 
235
	  ([], vars) (* defvar only contains vars *)
236
	  assert_expr
237
      in
238
      vars', defs@def_accu, {assert_ with assert_expr = expr}::assert_accu
239
    ) (vars, [], []) node.node_asserts in
240
  let new_locals = List.filter is_local vars in
241
  (* Compute traceability info: 
242
     - gather newly bound variables
243
     - compute the associated expression without aliases     
244
  *)
245
  (* let diff_vars = List.filter (fun v -> not (List.mem v node.node_locals)) new_locals in *)
246
  let node =
247
  { node with 
248
    node_locals = new_locals; 
249
    node_stmts = List.map (fun eq -> Eq eq) (defs @ assert_defs);
250
  }
251
  in ((*Printers.pp_node Format.err_formatter node;*) node)
252

  
253
let inject_decl decl =
254
  match decl.top_decl_desc with
255
  | Node nd ->
256
    {decl with top_decl_desc = Node (inject_node nd)}
257
  | Open _ | ImportedNode _ | Const _ | TypeDef _ -> decl
258
  
259
let inject_prog decls = 
260
  List.map inject_decl decls
261

  
262

  
263
(* Local Variables: *)
264
(* compile-command:"make -C .." *)
265
(* End: *)
src/plugins/salsa/salsa_plugin.ml
1
open Format 
2
open LustreSpec
3

  
4
let salsa_enabled = ref false
5
    (* "-salsa", Arg.Set salsa_enabled, "activate Salsa optimization <default>"; *)
6
    (* "-no-salsa", Arg.Clear salsa_enabled, "deactivate Salsa optimization"; *)
7

  
8

  
9
module Plugin =
10
(struct
11
  include PluginType.Default
12
  let name = "salsa"
13
  
14
  let options = [
15

  
16
  ]
17

  
18
  let activate () = salsa_enabled := true
19

  
20
  let refine_machine_code prog machine_code = 
21
    if !salsa_enabled then
22
      begin
23
	Compiler_common.check_main ();
24
	Log.report ~level:1 (fun fmt -> fprintf fmt ".. salsa machines optimization (phase 3)@ ");
25
	(* Selecting float constants for Salsa *)
26
	let constEnv = List.fold_left (
27
	  fun accu c_topdecl ->
28
	    match c_topdecl.top_decl_desc with
29
	    | Const c when Types.is_real_type c.const_type  ->
30
	      (c.const_id, c.const_value) :: accu
31
	    | _ -> accu
32
	) [] (Corelang.get_consts prog) 
33
	in
34
	List.map 
35
	  (Machine_salsa_opt.machine_t2machine_t_optimized_by_salsa constEnv) 
36
	  machine_code 
37
      end
38
    else
39
      machine_code
40
  
41
  
42
 end: PluginType.PluginType)
src/plugins/scopes/scopes.ml
227 227
  }
228 228
    
229 229

  
230
module Plugin =
230
module Plugin : PluginType.PluginType =
231 231
struct
232 232
  let name = "scopes"
233 233
  let is_active () = 
......
250 250
  let activate () = 
251 251
    option_scopes := true;
252 252
    Options.optimization := 0; (* no optimization *)
253
    Options.salsa_enabled := false; (* No salsa *)
253
    
254
    (* Options.salsa_enabled := false; (\* No salsa *\) TODO *)
254 255
    ()
255 256

  
256 257
  let rec is_valid_path path nodename prog machines =
......
312 313

  
313 314
  let pp fmt = pp_scopes fmt !scopes_map
314 315

  
316
  let check_force_stateful () = true
317

  
318
  let refine_machine_code prog machine_code =
319
    if show_scopes () then
320
      begin
321
	let all_scopes = compute_scopes prog !Options.main_node in
322
      (* Printing scopes *)
323
      if !Options.verbose_level >= 1 then
324
	Format.printf "Possible scopes are:@   ";
325
	Format.printf "@[<v>%a@ @]@.@?" print_scopes all_scopes;
326
	exit 0
327
      end;
328
    if is_active () then
329
      process_scopes !Options.main_node prog machine_code
330
    else
331
      machine_code
332
	
333

  
334

  
335
  let c_backend_main_loop_body_suffix fmt () =
336
    if is_active () then
337
      begin
338
	Format.fprintf fmt "@ %t" pp 
339
      end;    
340
 
315 341
end
316 342
    
317 343
(* Local Variables: *)

Also available in: Unified diff