diff --git a/.ocamlformat b/.ocamlformat
new file mode 100644
index 0000000000000000000000000000000000000000..b1bc4470bd72ad17da3b022db1369d0f7afa8e80
--- /dev/null
+++ b/.ocamlformat
@@ -0,0 +1,5 @@
+version=0.18.0
+parens-tuple=multi-line-only
+wrap-comments=true
+cases-exp-indent=2
+break-cases=nested
diff --git a/dune b/dune
index 098110dd376c6445b333572e2ce16d85c80f18f4..c8164c4d4c58e612ca34eead2178d482c3a9595f 100644
--- a/dune
+++ b/dune
@@ -1,45 +1,63 @@
; too bad dune does not support glob in install stanza
; (see https://discuss.ocaml.org/t/installing-many-files-with-dune/4143)
; TODO: open an issue?
+
(install
- (section (site (lustrec include_)))
+ (section
+ (site
+ (lustrec include_)))
(files
- include/conv.c
- include/conv.lusi
- include/conv.lusic
- include/mpfr_lustre.c
- include/mpfr_lustre.lusi
- include/mpfr_lustre.lusic
- include/mpfr_lustre.h
- include/simulink_math_fcn.c
- include/simulink_math_fcn.lusi
- include/simulink_math_fcn.lusic
- include/simulink_math_fcn.h
- include/lustrec_math.lusi
- include/lustrec_math.lusic
- include/lustrec_math.h
- include/arrow.c
- include/arrow.h
- include/arrow_spec.h
- include/arrow_spec.c
- include/arrow.cpp
- include/arrow.hpp
- include/io_frontend.c
- include/io_frontend.h
- include/io_frontend.hpp
- include/lustrec_math.smt2
- include/StdIn.java))
+ include/conv.c
+ include/conv.lusi
+ include/conv.lusic
+ include/mpfr_lustre.c
+ include/mpfr_lustre.lusi
+ include/mpfr_lustre.lusic
+ include/mpfr_lustre.h
+ include/simulink_math_fcn.c
+ include/simulink_math_fcn.lusi
+ include/simulink_math_fcn.lusic
+ include/simulink_math_fcn.h
+ include/lustrec_math.lusi
+ include/lustrec_math.lusic
+ include/lustrec_math.h
+ include/arrow.c
+ include/arrow.h
+ include/arrow_spec.h
+ include/arrow_spec.c
+ include/arrow.cpp
+ include/arrow.hpp
+ include/io_frontend.c
+ include/io_frontend.h
+ include/io_frontend.hpp
+ include/lustrec_math.smt2
+ include/StdIn.java))
(install
- (section (site (lustrec testgen)))
- (files
- share/FindLustre.cmake
- share/helpful_functions.cmake))
+ (section
+ (site
+ (lustrec testgen)))
+ (files share/FindLustre.cmake share/helpful_functions.cmake))
(rule
(alias runtest)
- (deps (source_tree tests/regression_tests))
- (action (chdir tests/regression_tests
- (progn
- (run cmake "-DSUBPROJ=\"unstable\"" "-DLUSTRE_INCLUDE_DIR=%{project_root}/include" .)
- (run ctest -D Experimental -R "COMPIL_LUS|MAKE|BIN|DIFF" -E LUSTRET --progress)))))
+ (deps
+ (source_tree tests/regression_tests))
+ (action
+ (chdir
+ tests/regression_tests
+ (progn
+ (run
+ cmake
+ "-DSUBPROJ=\"unstable\""
+ "-DLUSTRE_INCLUDE_DIR=%{project_root}/include"
+ .)
+ (run
+ ctest
+ -D
+ Experimental
+ -R
+ "COMPIL_LUS|MAKE|BIN|DIFF"
+ -E
+ LUSTRET
+ --progress)))))
diff --git a/include/dune b/include/dune
index b42cbe99b4799886c723bbbd7ba2d5d0e64c92b3..0df06092f93695efd2cc88f56660698dc9631eea 100644
--- a/include/dune
+++ b/include/dune
@@ -4,20 +4,24 @@
(rule
(target conv.lusic)
- (action (run lustrec -verbose 0 -I . -d . %{dep:conv.lusi}))
+ (action
+ (run lustrec -verbose 0 -I . -d . %{dep:conv.lusi}))
(alias install))
(rule
(targets simulink_math_fcn.lusic simulink_math_fcn.h)
- (action (run lustrec -verbose 0 -I . -d . %{dep:simulink_math_fcn.lusi}))
+ (action
+ (run lustrec -verbose 0 -I . -d . %{dep:simulink_math_fcn.lusi}))
(alias install))
(rule
(targets lustrec_math.lusic lustrec_math.h)
- (action (run lustrec -verbose 0 -I . -d . %{dep:lustrec_math.lusi}))
+ (action
+ (run lustrec -verbose 0 -I . -d . %{dep:lustrec_math.lusi}))
(alias install))
(rule
(targets mpfr_lustre.lusic mpfr_lustre.h)
- (action (run lustrec -verbose 0 -mpfr 1 -d . %{dep:mpfr_lustre.lusi}))
+ (action
+ (run lustrec -verbose 0 -mpfr 1 -d . %{dep:mpfr_lustre.lusi}))
(alias install))
diff --git a/src/annotations.ml b/src/annotations.ml
index 62b2534cf1379b10fe6e70270d3c514cd550b47d..7da8dfb630ad1b7e813c65444c090c0d42bf4632 100644
--- a/src/annotations.ml
+++ b/src/annotations.ml
@@ -11,12 +11,14 @@
open Lustre_types
-
(* Associate to each annotation key the pair (node, expr tag) *)
-let expr_annotations : (string list, ident * tag) Hashtbl.t= Hashtbl.create 13
-let node_annotations : (string list, ident) Hashtbl.t= Hashtbl.create 13
+let expr_annotations : (string list, ident * tag) Hashtbl.t = Hashtbl.create 13
+
+let node_annotations : (string list, ident) Hashtbl.t = Hashtbl.create 13
+
+let add_expr_ann node_id expr_tag key =
+ Hashtbl.add expr_annotations key (node_id, expr_tag)
-let add_expr_ann node_id expr_tag key = Hashtbl.add expr_annotations key (node_id, expr_tag)
let add_node_ann node_id key = Hashtbl.add node_annotations key node_id
let get_expr_annotations key = Hashtbl.find_all expr_annotations key
diff --git a/src/arrow.ml b/src/arrow.ml
index 23a71b1fda523f2eb1fbb1f66a94b7ee898e4ce1..f2e933df2f424c5aeb12de166d066053e83aac99 100644
--- a/src/arrow.ml
+++ b/src/arrow.ml
@@ -9,27 +9,30 @@ let arrow_desc =
node_id = arrow_id;
node_type = Type_predef.type_bin_poly_op;
node_clock = Clock_predef.ck_bin_univ;
- node_inputs= [Corelang.dummy_var_decl "_in1" arrow_typ; Corelang.dummy_var_decl "_in2" arrow_typ];
- node_outputs= [Corelang.dummy_var_decl "_out" arrow_typ];
- node_locals= [];
+ node_inputs =
+ [
+ Corelang.dummy_var_decl "_in1" arrow_typ;
+ Corelang.dummy_var_decl "_in2" arrow_typ;
+ ];
+ node_outputs = [ Corelang.dummy_var_decl "_out" arrow_typ ];
+ node_locals = [];
node_gencalls = [];
node_checks = [];
node_asserts = [];
- node_stmts= [];
+ node_stmts = [];
node_dec_stateless = false;
node_stateless = Some false;
node_spec = None;
node_annot = [];
node_iscontract = false;
-}
+ }
let arrow_top_decl () =
{
top_decl_desc = Node arrow_desc;
- top_decl_owner = (Options_management.core_dependency "arrow");
+ top_decl_owner = Options_management.core_dependency "arrow";
top_decl_itf = false;
- top_decl_loc = Location.dummy_loc
+ top_decl_loc = Location.dummy_loc;
}
-let td_is_arrow td =
- Corelang.node_name td = arrow_id
+let td_is_arrow td = Corelang.node_name td = arrow_id
diff --git a/src/arrow.mli b/src/arrow.mli
index 31916c589072c38acdfa9b79839e8aa50c23cf90..87062c351136bf47900f6a44e5bb6a9d20944bda 100644
--- a/src/arrow.mli
+++ b/src/arrow.mli
@@ -1,4 +1,7 @@
-val arrow_id: string
-val arrow_top_decl: unit -> Lustre_types.top_decl
-val arrow_desc: Lustre_types.node_desc
-val td_is_arrow: Lustre_types.top_decl -> bool
+val arrow_id : string
+
+val arrow_top_decl : unit -> Lustre_types.top_decl
+
+val arrow_desc : Lustre_types.node_desc
+
+val td_is_arrow : Lustre_types.top_decl -> bool
diff --git a/src/automata.ml b/src/automata.ml
index 37f9b92947a335caa52b01dcd2f5f11f8adf8523..d75a4d58572efa2169d1ffb49daa6da94a4425d2 100644
--- a/src/automata.ml
+++ b/src/automata.ml
@@ -1,298 +1,523 @@
-(********************************************************************)
-(* *)
-(* 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 Lustre_types
-open Corelang
-
-
-type aut_state =
- {
- incoming_r' : var_decl;
- incoming_s' : var_decl;
- incoming_r : var_decl;
- incoming_s : var_decl;
- actual_r : var_decl;
- actual_s : var_decl
- }
-
-let as_clock var_decl =
- let tydec = var_decl.var_dec_type in
- { var_decl with var_dec_type = { ty_dec_desc = Tydec_clock tydec.ty_dec_desc; ty_dec_loc = tydec.ty_dec_loc } }
-
-let mkbool loc b =
- mkexpr loc (Expr_const (const_of_bool b))
-
-let mkident loc id =
- mkexpr loc (Expr_ident id)
-
-let mkconst loc id =
- mkexpr loc (Expr_const (Const_tag id))
-
-let mkfby loc e1 e2 =
- mkexpr loc (Expr_arrow (e1, mkexpr loc (Expr_pre e2)))
-
-let mkpair loc e1 e2 =
- mkexpr loc (Expr_tuple [e1; e2])
-
-let mkidentpair loc restart state =
- mkexpr loc (Expr_tuple [mkident loc restart; mkident loc state])
-
-let add_branch (loc, expr, restart, st) cont =
- mkexpr loc (Expr_ite (expr, mkexpr loc (Expr_tuple [mkbool loc restart; mkident loc st]), cont))
-
-let mkhandler loc st unless until locals (stmts, asserts, annots) =
- {hand_state = st;
- hand_unless = unless;
- hand_until = until;
- hand_locals = locals;
- hand_stmts = stmts;
- hand_asserts = asserts;
- hand_annots = annots;
- hand_loc = loc}
-
-let mkautomata loc id handlers =
- {aut_id = id;
- aut_handlers = handlers;
- aut_loc = loc}
-
-let expr_of_exit loc restart state conds tag =
- mkexpr loc (Expr_when (List.fold_right add_branch conds (mkidentpair loc restart state), state, tag))
-
-let unless_read reads handler =
- let res =
- List.fold_left (fun read (_, c, _, _) -> Utils.ISet.union read (get_expr_vars c)) reads handler.hand_unless
- in
-(
-(*
-Format.eprintf "unless_reads %s = %a@." handler.hand_state (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) (ISet.elements reads);
-Format.eprintf "unless_reads' %s = %a@." handler.hand_state (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) (ISet.elements res);
-*)
-res
-)
-
-let until_read reads handler =
- List.fold_left (fun read (_, c, _, _) -> Utils.ISet.union read (get_expr_vars c)) reads handler.hand_until
-
-let rec handler_read reads handler =
- let locals = List.fold_left (fun locals v -> ISet.add v.var_id locals) ISet.empty handler.hand_locals in
- let allvars =
- List.fold_left (fun read stmt ->
- match stmt with
- | Eq eq -> Utils.ISet.union read (get_expr_vars eq.eq_rhs)
- | Aut aut -> automata_read read aut) reads handler.hand_stmts
- in let res = ISet.diff allvars locals
- in
-(
-(*
-Format.eprintf "handler_allvars %s = %a@." handler.hand_state (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) (ISet.elements allvars);
-Format.eprintf "handler_read %s = %a@." handler.hand_state (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) (ISet.elements res);
-*)
-res
-)
-
-and automata_read reads aut =
- List.fold_left (fun read handler -> until_read (handler_read (unless_read read handler) handler) handler) reads aut.aut_handlers
-
-let rec handler_write writes handler =
- let locals = List.fold_left (fun locals v -> ISet.add v.var_id locals) ISet.empty handler.hand_locals in
- let allvars =
- List.fold_left (fun write stmt ->
- match stmt with
- | Eq eq -> List.fold_left (fun write v -> ISet.add v write) write eq.eq_lhs
- | Aut aut -> List.fold_left handler_write write aut.aut_handlers) writes handler.hand_stmts
- in ISet.diff allvars locals
-
-let node_vars_of_idents node iset =
- List.fold_right (fun v res -> if ISet.mem v.var_id iset then v :: res else res) (get_node_vars node) []
-
-let mkautomata_state nodeid used typedef loc id =
- let tydec_bool = { ty_dec_desc = Tydec_bool; ty_dec_loc = loc } in
- let tydec_state id = { ty_dec_desc = Tydec_const id; ty_dec_loc = loc } in
- let ckdec_any = { ck_dec_desc = Ckdec_any; ck_dec_loc = loc } in
- let incoming_r' = mk_new_name used (id ^ "__next_restart_in") in
- let incoming_s' = mk_new_name used (id ^ "__next_state_in") in
- let incoming_r = mk_new_name used (id ^ "__restart_in") in
- let incoming_s = mk_new_name used (id ^ "__state_in") in
- let actual_r = mk_new_name used (id ^ "__restart_act") in
- let actual_s = mk_new_name used (id ^ "__state_act") in
- {
- incoming_r' = mkvar_decl loc (incoming_r', tydec_bool, ckdec_any, false, None, Some nodeid);
- incoming_s' = mkvar_decl loc (incoming_s', tydec_state typedef.tydef_id, ckdec_any, false, None, Some nodeid);
- incoming_r = mkvar_decl loc (incoming_r, tydec_bool, ckdec_any, false, None, Some nodeid);
- incoming_s = mkvar_decl loc (incoming_s, tydec_state typedef.tydef_id, ckdec_any, false, None, Some nodeid);
- actual_r = mkvar_decl loc (actual_r , tydec_bool, ckdec_any, false, None, Some nodeid);
- actual_s = mkvar_decl loc (actual_s , tydec_state typedef.tydef_id, ckdec_any, false, None, Some nodeid)
- }
-
-let vars_of_aut_state aut_state =
- [aut_state.incoming_r'; aut_state.incoming_r; aut_state.actual_r; aut_state.incoming_s'; as_clock aut_state.incoming_s; as_clock aut_state.actual_s]
-
-let node_of_unless nused node aut_id aut_state handler =
-(*Format.eprintf "node_of_unless %s@." node.node_id;*)
- let inputs = unless_read ISet.empty handler in
- let var_inputs = aut_state.incoming_r (*:: aut_state.incoming_s*) :: (node_vars_of_idents node inputs) in
- let var_outputs = aut_state.actual_r :: aut_state.actual_s :: [] in
- let init_expr = mkpair handler.hand_loc (mkident handler.hand_loc aut_state.incoming_r.var_id) (mkconst handler.hand_loc handler.hand_state) in
-(* let init_expr = mkidentpair handler.hand_loc aut_state.incoming_r.var_id aut_state.incoming_s.var_id in *)
- let expr_outputs = List.fold_right add_branch handler.hand_unless init_expr in
- let eq_outputs = Eq (mkeq handler.hand_loc ([aut_state.actual_r.var_id; aut_state.actual_s.var_id], expr_outputs)) in
- let node_id = mk_new_name nused (Format.sprintf "%s__%s_unless" aut_id handler.hand_state) in
- let args = List.map (fun v -> mkexpr handler.hand_loc (Expr_when (mkident handler.hand_loc v.var_id, aut_state.incoming_s.var_id, handler.hand_state))) var_inputs in
- let reset = Some (mkident handler.hand_loc aut_state.incoming_r.var_id) in
- {
- node_id = node_id;
- node_type = Types.new_var ();
- node_clock = Clocks.new_var true;
- node_inputs = List.map copy_var_decl var_inputs;
- node_outputs = List.map copy_var_decl var_outputs;
- node_locals = [];
- node_gencalls = [];
- node_checks = [];
- node_asserts = [];
- node_stmts = [ eq_outputs ];
- node_dec_stateless = false;
- node_stateless = None;
- node_spec = None;
- node_annot = [];
- node_iscontract = false;
- },
- mkexpr handler.hand_loc (Expr_appl (node_id, mkexpr handler.hand_loc (Expr_tuple args), reset))
-
-
-let rename_output used name = mk_new_name used (Format.sprintf "%s_out" name)
-
-let rec rename_stmts_outputs frename stmts =
- match stmts with
- | [] -> []
- | (Eq eq) :: q -> let eq' = Eq { eq with eq_lhs = List.map frename eq.eq_lhs } in
- eq' :: rename_stmts_outputs frename q
- | (Aut aut) :: q -> let handlers' = List.map (fun h -> { h with hand_stmts = rename_stmts_outputs frename h.hand_stmts}) aut.aut_handlers in
- let aut' = Aut { aut with aut_handlers = handlers' } in
- aut' :: rename_stmts_outputs frename q
-
-let mk_frename used outputs =
- let table = ISet.fold (fun name table -> IMap.add name (rename_output used name) table) outputs IMap.empty in
- (fun name -> try IMap.find name table with Not_found -> name)
-
-let node_of_assign_until nused used node aut_id aut_state handler =
-(*Format.eprintf "node_of_assign_until %s@." node.node_id;*)
- let writes = handler_write ISet.empty handler in
- let inputs = ISet.diff (handler_read (until_read ISet.empty handler) handler) writes in
- let frename = mk_frename used writes in
- let var_inputs = aut_state.actual_r (*:: aut_state.actual_s*) :: node_vars_of_idents node inputs in
- let new_var_locals = node_vars_of_idents node writes in
- let var_outputs = List.sort IdentModule.compare (node_vars_of_idents node writes) in
- let new_var_outputs = List.map (fun vdecl -> { vdecl with var_id = frename vdecl.var_id }) var_outputs in
- let new_output_eqs = List.map2 (fun o o' -> Eq (mkeq handler.hand_loc ([o'.var_id], mkident handler.hand_loc o.var_id))) var_outputs new_var_outputs in
- let init_until = mkpair handler.hand_loc (mkconst handler.hand_loc tag_false) (mkconst handler.hand_loc handler.hand_state) in
- let until_expr = List.fold_right add_branch handler.hand_until init_until in
- let until_eq = Eq (mkeq handler.hand_loc ([aut_state.incoming_r.var_id; aut_state.incoming_s.var_id], until_expr)) in
- let node_id = mk_new_name nused (Format.sprintf "%s__%s_handler_until" aut_id handler.hand_state) in
- let args = List.map (fun v -> mkexpr handler.hand_loc (Expr_when (mkident handler.hand_loc v.var_id, aut_state.actual_s.var_id, handler.hand_state))) var_inputs in
- let reset = Some (mkident handler.hand_loc aut_state.actual_r.var_id) in
- List.fold_left (fun res v -> ISet.add v.var_id res) ISet.empty var_outputs,
- {
- node_id = node_id;
- node_type = Types.new_var ();
- node_clock = Clocks.new_var true;
- node_inputs = List.map copy_var_decl var_inputs;
- node_outputs = List.map copy_var_decl (aut_state.incoming_r :: aut_state.incoming_s :: new_var_outputs);
- node_locals = List.map copy_var_decl (new_var_locals @ handler.hand_locals);
- node_gencalls = [];
- node_checks = [];
- node_asserts = handler.hand_asserts;
- node_stmts = until_eq :: new_output_eqs @ handler.hand_stmts;
- node_dec_stateless = false;
- node_stateless = None;
- node_spec = None;
- node_annot = handler.hand_annots;
- node_iscontract = false;
- },
- mkexpr handler.hand_loc (Expr_appl (node_id, mkexpr handler.hand_loc (Expr_tuple args), reset))
-
-let typedef_of_automata aut =
- let tname = Format.sprintf "%s__type" aut.aut_id in
- { tydef_id = tname;
- tydef_desc = Tydec_enum (List.map (fun h -> h.hand_state) aut.aut_handlers)
- }
-
-let expand_automata nused used owner typedef node aut =
- let initial = (List.hd aut.aut_handlers).hand_state in
- let aut_state = mkautomata_state node.node_id used typedef aut.aut_loc aut.aut_id in
- let unodes = List.map (fun h -> node_of_unless nused node aut.aut_id aut_state h) aut.aut_handlers in
- let aunodes = List.map (fun h -> node_of_assign_until nused used node aut.aut_id aut_state h) aut.aut_handlers in
- let all_outputs = List.fold_left (fun all (outputs, _, _) -> ISet.union outputs all) ISet.empty aunodes in
- let unless_handlers = List.map2 (fun h (_, c) -> (h.hand_state, c)) aut.aut_handlers unodes in
- let unless_expr = mkexpr aut.aut_loc (Expr_merge (aut_state.incoming_s.var_id, unless_handlers)) in
- let unless_eq = mkeq aut.aut_loc ([aut_state.actual_r.var_id; aut_state.actual_s.var_id], unless_expr) in
- let assign_until_handlers = List.map2 (fun h (_, _, c) -> (h.hand_state, c)) aut.aut_handlers aunodes in
- let assign_until_expr = mkexpr aut.aut_loc (Expr_merge (aut_state.actual_s.var_id, assign_until_handlers)) in
- let assign_until_vars = [aut_state.incoming_r'.var_id; aut_state.incoming_s'.var_id] @ (ISet.elements all_outputs) in
- let assign_until_eq = mkeq aut.aut_loc (assign_until_vars, assign_until_expr) in
- let fby_incoming_expr = mkfby aut.aut_loc (mkpair aut.aut_loc (mkconst aut.aut_loc tag_false) (mkconst aut.aut_loc initial)) (mkidentpair aut.aut_loc aut_state.incoming_r'.var_id aut_state.incoming_s'.var_id) in
- let incoming_eq = mkeq aut.aut_loc ([aut_state.incoming_r.var_id; aut_state.incoming_s.var_id], fby_incoming_expr) in
- let locals' = vars_of_aut_state aut_state in
- let eqs' = [Eq unless_eq; Eq assign_until_eq; Eq incoming_eq] in
- ( List.map2 (fun h (n, _) -> mktop_decl h.hand_loc owner false (Node n)) aut.aut_handlers unodes
- @ List.map2 (fun h (_, n, _) -> mktop_decl h.hand_loc owner false (Node n)) aut.aut_handlers aunodes,
- locals',
- eqs')
-
-let expand_node_stmt nused used owner node (top_types, top_nodes, locals, eqs) stmt =
- match stmt with
- | Eq eq -> (top_types, top_nodes, locals, (Eq eq)::eqs)
- | Aut aut ->
- let typedef = typedef_of_automata aut in
- let used' name = used name || List.exists (fun v -> v.var_id = name) locals in
- let nused' name =
- nused name ||
- List.exists (fun t -> match t.top_decl_desc with
- | ImportedNode nd -> nd.nodei_id = name | Node nd -> nd.node_id = name
- | _ -> false) top_nodes in
- let (top_decls', locals', eqs') = expand_automata nused' used' owner typedef node aut in
- let top_typedef = mktop_decl aut.aut_loc owner false (TypeDef typedef) in
- (top_typedef :: top_types, top_decls'@top_nodes, locals'@locals, eqs'@eqs)
-
-let expand_node_stmts nused used loc owner node =
- let top_types', top_nodes', locals', eqs' =
- List.fold_left (expand_node_stmt nused used owner node) ([], [], [], []) node.node_stmts in
- let node' =
- { node with node_locals = locals'@node.node_locals; node_stmts = eqs' } in
- let top_node = mktop_decl loc owner false (Node node') in
- top_types', top_node, top_nodes'
-
-let rec expand_decls_rec nused top_decls =
- match top_decls with
- | [] -> []
- | top_decl::q ->
- match top_decl.top_decl_desc with
- | Node nd ->
- let used name =
- List.exists (fun v -> v.var_id = name) nd.node_inputs
- || List.exists (fun v -> v.var_id = name) nd.node_outputs
- || List.exists (fun v -> v.var_id = name) nd.node_locals in
- let top_types', top_decl', top_nodes' = expand_node_stmts nused used top_decl.top_decl_loc top_decl.top_decl_owner nd in
- top_types' @ (top_decl' :: expand_decls_rec nused (top_nodes'@q))
- | _ -> top_decl :: expand_decls_rec nused q
-
-let expand_decls top_decls =
- let top_names = List.fold_left (fun names t -> match t.top_decl_desc with
- | Node nd -> ISet.add nd.node_id names
- | ImportedNode nd -> ISet.add nd.nodei_id names
- | _ -> names) ISet.empty top_decls in
- let nused name = ISet.mem name top_names in
- expand_decls_rec nused top_decls
-
-(* Local Variables: *)
-(* compile-command:"make -C .." *)
-(* End: *)
-
+(********************************************************************)
+(* *)
+(* 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 Lustre_types
+open Corelang
+
+type aut_state = {
+ incoming_r' : var_decl;
+ incoming_s' : var_decl;
+ incoming_r : var_decl;
+ incoming_s : var_decl;
+ actual_r : var_decl;
+ actual_s : var_decl;
+}
+
+let as_clock var_decl =
+ let tydec = var_decl.var_dec_type in
+ {
+ var_decl with
+ var_dec_type =
+ {
+ ty_dec_desc = Tydec_clock tydec.ty_dec_desc;
+ ty_dec_loc = tydec.ty_dec_loc;
+ };
+ }
+
+let mkbool loc b = mkexpr loc (Expr_const (const_of_bool b))
+
+let mkident loc id = mkexpr loc (Expr_ident id)
+
+let mkconst loc id = mkexpr loc (Expr_const (Const_tag id))
+
+let mkfby loc e1 e2 = mkexpr loc (Expr_arrow (e1, mkexpr loc (Expr_pre e2)))
+
+let mkpair loc e1 e2 = mkexpr loc (Expr_tuple [ e1; e2 ])
+
+let mkidentpair loc restart state =
+ mkexpr loc (Expr_tuple [ mkident loc restart; mkident loc state ])
+
+let add_branch (loc, expr, restart, st) cont =
+ mkexpr loc
+ (Expr_ite
+ ( expr,
+ mkexpr loc (Expr_tuple [ mkbool loc restart; mkident loc st ]),
+ cont ))
+
+let mkhandler loc st unless until locals (stmts, asserts, annots) =
+ {
+ hand_state = st;
+ hand_unless = unless;
+ hand_until = until;
+ hand_locals = locals;
+ hand_stmts = stmts;
+ hand_asserts = asserts;
+ hand_annots = annots;
+ hand_loc = loc;
+ }
+
+let mkautomata loc id handlers =
+ { aut_id = id; aut_handlers = handlers; aut_loc = loc }
+
+let expr_of_exit loc restart state conds tag =
+ mkexpr loc
+ (Expr_when
+ ( List.fold_right add_branch conds (mkidentpair loc restart state),
+ state,
+ tag ))
+
+let unless_read reads handler =
+ let res =
+ List.fold_left
+ (fun read (_, c, _, _) -> Utils.ISet.union read (get_expr_vars c))
+ reads handler.hand_unless
+ in
+ (* Format.eprintf "unless_reads %s = %a@." handler.hand_state (fprintf_list
+ ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) (ISet.elements reads);
+ Format.eprintf "unless_reads' %s = %a@." handler.hand_state (fprintf_list
+ ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) (ISet.elements res); *)
+ res
+
+let until_read reads handler =
+ List.fold_left
+ (fun read (_, c, _, _) -> Utils.ISet.union read (get_expr_vars c))
+ reads handler.hand_until
+
+let rec handler_read reads handler =
+ let locals =
+ List.fold_left
+ (fun locals v -> ISet.add v.var_id locals)
+ ISet.empty handler.hand_locals
+ in
+ let allvars =
+ List.fold_left
+ (fun read stmt ->
+ match stmt with
+ | Eq eq ->
+ Utils.ISet.union read (get_expr_vars eq.eq_rhs)
+ | Aut aut ->
+ automata_read read aut)
+ reads handler.hand_stmts
+ in
+ let res = ISet.diff allvars locals in
+ (* Format.eprintf "handler_allvars %s = %a@." handler.hand_state (fprintf_list
+ ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) (ISet.elements
+ allvars); Format.eprintf "handler_read %s = %a@." handler.hand_state
+ (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v))
+ (ISet.elements res); *)
+ res
+
+and automata_read reads aut =
+ List.fold_left
+ (fun read handler ->
+ until_read (handler_read (unless_read read handler) handler) handler)
+ reads aut.aut_handlers
+
+let rec handler_write writes handler =
+ let locals =
+ List.fold_left
+ (fun locals v -> ISet.add v.var_id locals)
+ ISet.empty handler.hand_locals
+ in
+ let allvars =
+ List.fold_left
+ (fun write stmt ->
+ match stmt with
+ | Eq eq ->
+ List.fold_left (fun write v -> ISet.add v write) write eq.eq_lhs
+ | Aut aut ->
+ List.fold_left handler_write write aut.aut_handlers)
+ writes handler.hand_stmts
+ in
+ ISet.diff allvars locals
+
+let node_vars_of_idents node iset =
+ List.fold_right
+ (fun v res -> if ISet.mem v.var_id iset then v :: res else res)
+ (get_node_vars node) []
+
+let mkautomata_state nodeid used typedef loc id =
+ let tydec_bool = { ty_dec_desc = Tydec_bool; ty_dec_loc = loc } in
+ let tydec_state id = { ty_dec_desc = Tydec_const id; ty_dec_loc = loc } in
+ let ckdec_any = { ck_dec_desc = Ckdec_any; ck_dec_loc = loc } in
+ let incoming_r' = mk_new_name used (id ^ "__next_restart_in") in
+ let incoming_s' = mk_new_name used (id ^ "__next_state_in") in
+ let incoming_r = mk_new_name used (id ^ "__restart_in") in
+ let incoming_s = mk_new_name used (id ^ "__state_in") in
+ let actual_r = mk_new_name used (id ^ "__restart_act") in
+ let actual_s = mk_new_name used (id ^ "__state_act") in
+ {
+ incoming_r' =
+ mkvar_decl loc
+ (incoming_r', tydec_bool, ckdec_any, false, None, Some nodeid);
+ incoming_s' =
+ mkvar_decl loc
+ ( incoming_s',
+ tydec_state typedef.tydef_id,
+ ckdec_any,
+ false,
+ None,
+ Some nodeid );
+ incoming_r =
+ mkvar_decl loc
+ (incoming_r, tydec_bool, ckdec_any, false, None, Some nodeid);
+ incoming_s =
+ mkvar_decl loc
+ ( incoming_s,
+ tydec_state typedef.tydef_id,
+ ckdec_any,
+ false,
+ None,
+ Some nodeid );
+ actual_r =
+ mkvar_decl loc (actual_r, tydec_bool, ckdec_any, false, None, Some nodeid);
+ actual_s =
+ mkvar_decl loc
+ ( actual_s,
+ tydec_state typedef.tydef_id,
+ ckdec_any,
+ false,
+ None,
+ Some nodeid );
+ }
+
+let vars_of_aut_state aut_state =
+ [
+ aut_state.incoming_r';
+ aut_state.incoming_r;
+ aut_state.actual_r;
+ aut_state.incoming_s';
+ as_clock aut_state.incoming_s;
+ as_clock aut_state.actual_s;
+ ]
+
+let node_of_unless nused node aut_id aut_state handler =
+ (*Format.eprintf "node_of_unless %s@." node.node_id;*)
+ let inputs = unless_read ISet.empty handler in
+ let var_inputs =
+ aut_state.incoming_r
+ (*:: aut_state.incoming_s*)
+ :: node_vars_of_idents node inputs
+ in
+ let var_outputs = [ aut_state.actual_r; aut_state.actual_s ] in
+ let init_expr =
+ mkpair handler.hand_loc
+ (mkident handler.hand_loc aut_state.incoming_r.var_id)
+ (mkconst handler.hand_loc handler.hand_state)
+ in
+ (* let init_expr = mkidentpair handler.hand_loc aut_state.incoming_r.var_id
+ aut_state.incoming_s.var_id in *)
+ let expr_outputs = List.fold_right add_branch handler.hand_unless init_expr in
+ let eq_outputs =
+ Eq
+ (mkeq handler.hand_loc
+ ([ aut_state.actual_r.var_id; aut_state.actual_s.var_id ], expr_outputs))
+ in
+ let node_id =
+ mk_new_name nused (Format.sprintf "%s__%s_unless" aut_id handler.hand_state)
+ in
+ let args =
+ List.map
+ (fun v ->
+ mkexpr handler.hand_loc
+ (Expr_when
+ ( mkident handler.hand_loc v.var_id,
+ aut_state.incoming_s.var_id,
+ handler.hand_state )))
+ var_inputs
+ in
+ let reset = Some (mkident handler.hand_loc aut_state.incoming_r.var_id) in
+ ( {
+ node_id;
+ node_type = Types.new_var ();
+ node_clock = Clocks.new_var true;
+ node_inputs = List.map copy_var_decl var_inputs;
+ node_outputs = List.map copy_var_decl var_outputs;
+ node_locals = [];
+ node_gencalls = [];
+ node_checks = [];
+ node_asserts = [];
+ node_stmts = [ eq_outputs ];
+ node_dec_stateless = false;
+ node_stateless = None;
+ node_spec = None;
+ node_annot = [];
+ node_iscontract = false;
+ },
+ mkexpr handler.hand_loc
+ (Expr_appl (node_id, mkexpr handler.hand_loc (Expr_tuple args), reset)) )
+
+let rename_output used name = mk_new_name used (Format.sprintf "%s_out" name)
+
+let rec rename_stmts_outputs frename stmts =
+ match stmts with
+ | [] ->
+ []
+ | Eq eq :: q ->
+ let eq' = Eq { eq with eq_lhs = List.map frename eq.eq_lhs } in
+ eq' :: rename_stmts_outputs frename q
+ | Aut aut :: q ->
+ let handlers' =
+ List.map
+ (fun h ->
+ { h with hand_stmts = rename_stmts_outputs frename h.hand_stmts })
+ aut.aut_handlers
+ in
+ let aut' = Aut { aut with aut_handlers = handlers' } in
+ aut' :: rename_stmts_outputs frename q
+
+let mk_frename used outputs =
+ let table =
+ ISet.fold
+ (fun name table -> IMap.add name (rename_output used name) table)
+ outputs IMap.empty
+ in
+ fun name -> try IMap.find name table with Not_found -> name
+
+let node_of_assign_until nused used node aut_id aut_state handler =
+ (*Format.eprintf "node_of_assign_until %s@." node.node_id;*)
+ let writes = handler_write ISet.empty handler in
+ let inputs =
+ ISet.diff (handler_read (until_read ISet.empty handler) handler) writes
+ in
+ let frename = mk_frename used writes in
+ let var_inputs =
+ aut_state.actual_r
+ (*:: aut_state.actual_s*)
+ :: node_vars_of_idents node inputs
+ in
+ let new_var_locals = node_vars_of_idents node writes in
+ let var_outputs =
+ List.sort IdentModule.compare (node_vars_of_idents node writes)
+ in
+ let new_var_outputs =
+ List.map
+ (fun vdecl -> { vdecl with var_id = frename vdecl.var_id })
+ var_outputs
+ in
+ let new_output_eqs =
+ List.map2
+ (fun o o' ->
+ Eq
+ (mkeq handler.hand_loc
+ ([ o'.var_id ], mkident handler.hand_loc o.var_id)))
+ var_outputs new_var_outputs
+ in
+ let init_until =
+ mkpair handler.hand_loc
+ (mkconst handler.hand_loc tag_false)
+ (mkconst handler.hand_loc handler.hand_state)
+ in
+ let until_expr = List.fold_right add_branch handler.hand_until init_until in
+ let until_eq =
+ Eq
+ (mkeq handler.hand_loc
+ ( [ aut_state.incoming_r.var_id; aut_state.incoming_s.var_id ],
+ until_expr ))
+ in
+ let node_id =
+ mk_new_name nused
+ (Format.sprintf "%s__%s_handler_until" aut_id handler.hand_state)
+ in
+ let args =
+ List.map
+ (fun v ->
+ mkexpr handler.hand_loc
+ (Expr_when
+ ( mkident handler.hand_loc v.var_id,
+ aut_state.actual_s.var_id,
+ handler.hand_state )))
+ var_inputs
+ in
+ let reset = Some (mkident handler.hand_loc aut_state.actual_r.var_id) in
+ ( List.fold_left (fun res v -> ISet.add v.var_id res) ISet.empty var_outputs,
+ {
+ node_id;
+ node_type = Types.new_var ();
+ node_clock = Clocks.new_var true;
+ node_inputs = List.map copy_var_decl var_inputs;
+ node_outputs =
+ List.map copy_var_decl
+ (aut_state.incoming_r :: aut_state.incoming_s :: new_var_outputs);
+ node_locals = List.map copy_var_decl (new_var_locals @ handler.hand_locals);
+ node_gencalls = [];
+ node_checks = [];
+ node_asserts = handler.hand_asserts;
+ node_stmts = until_eq :: new_output_eqs @ handler.hand_stmts;
+ node_dec_stateless = false;
+ node_stateless = None;
+ node_spec = None;
+ node_annot = handler.hand_annots;
+ node_iscontract = false;
+ },
+ mkexpr handler.hand_loc
+ (Expr_appl (node_id, mkexpr handler.hand_loc (Expr_tuple args), reset)) )
+
+let typedef_of_automata aut =
+ let tname = Format.sprintf "%s__type" aut.aut_id in
+ {
+ tydef_id = tname;
+ tydef_desc = Tydec_enum (List.map (fun h -> h.hand_state) aut.aut_handlers);
+ }
+
+let expand_automata nused used owner typedef node aut =
+ let initial = (List.hd aut.aut_handlers).hand_state in
+ let aut_state =
+ mkautomata_state node.node_id used typedef aut.aut_loc aut.aut_id
+ in
+ let unodes =
+ List.map
+ (fun h -> node_of_unless nused node aut.aut_id aut_state h)
+ aut.aut_handlers
+ in
+ let aunodes =
+ List.map
+ (fun h -> node_of_assign_until nused used node aut.aut_id aut_state h)
+ aut.aut_handlers
+ in
+ let all_outputs =
+ List.fold_left
+ (fun all (outputs, _, _) -> ISet.union outputs all)
+ ISet.empty aunodes
+ in
+ let unless_handlers =
+ List.map2 (fun h (_, c) -> h.hand_state, c) aut.aut_handlers unodes
+ in
+ let unless_expr =
+ mkexpr aut.aut_loc
+ (Expr_merge (aut_state.incoming_s.var_id, unless_handlers))
+ in
+ let unless_eq =
+ mkeq aut.aut_loc
+ ([ aut_state.actual_r.var_id; aut_state.actual_s.var_id ], unless_expr)
+ in
+ let assign_until_handlers =
+ List.map2 (fun h (_, _, c) -> h.hand_state, c) aut.aut_handlers aunodes
+ in
+ let assign_until_expr =
+ mkexpr aut.aut_loc
+ (Expr_merge (aut_state.actual_s.var_id, assign_until_handlers))
+ in
+ let assign_until_vars =
+ [ aut_state.incoming_r'.var_id; aut_state.incoming_s'.var_id ]
+ @ ISet.elements all_outputs
+ in
+ let assign_until_eq =
+ mkeq aut.aut_loc (assign_until_vars, assign_until_expr)
+ in
+ let fby_incoming_expr =
+ mkfby aut.aut_loc
+ (mkpair aut.aut_loc
+ (mkconst aut.aut_loc tag_false)
+ (mkconst aut.aut_loc initial))
+ (mkidentpair aut.aut_loc aut_state.incoming_r'.var_id
+ aut_state.incoming_s'.var_id)
+ in
+ let incoming_eq =
+ mkeq aut.aut_loc
+ ( [ aut_state.incoming_r.var_id; aut_state.incoming_s.var_id ],
+ fby_incoming_expr )
+ in
+ let locals' = vars_of_aut_state aut_state in
+ let eqs' = [ Eq unless_eq; Eq assign_until_eq; Eq incoming_eq ] in
+ ( List.map2
+ (fun h (n, _) -> mktop_decl h.hand_loc owner false (Node n))
+ aut.aut_handlers unodes
+ @ List.map2
+ (fun h (_, n, _) -> mktop_decl h.hand_loc owner false (Node n))
+ aut.aut_handlers aunodes,
+ locals',
+ eqs' )
+
+let expand_node_stmt nused used owner node (top_types, top_nodes, locals, eqs)
+ stmt =
+ match stmt with
+ | Eq eq ->
+ top_types, top_nodes, locals, Eq eq :: eqs
+ | Aut aut ->
+ let typedef = typedef_of_automata aut in
+ let used' name =
+ used name || List.exists (fun v -> v.var_id = name) locals
+ in
+ let nused' name =
+ nused name
+ || List.exists
+ (fun t ->
+ match t.top_decl_desc with
+ | ImportedNode nd ->
+ nd.nodei_id = name
+ | Node nd ->
+ nd.node_id = name
+ | _ ->
+ false)
+ top_nodes
+ in
+ let top_decls', locals', eqs' =
+ expand_automata nused' used' owner typedef node aut
+ in
+ let top_typedef = mktop_decl aut.aut_loc owner false (TypeDef typedef) in
+ ( top_typedef :: top_types,
+ top_decls' @ top_nodes,
+ locals' @ locals,
+ eqs' @ eqs )
+
+let expand_node_stmts nused used loc owner node =
+ let top_types', top_nodes', locals', eqs' =
+ List.fold_left
+ (expand_node_stmt nused used owner node)
+ ([], [], [], []) node.node_stmts
+ in
+ let node' =
+ { node with node_locals = locals' @ node.node_locals; node_stmts = eqs' }
+ in
+ let top_node = mktop_decl loc owner false (Node node') in
+ top_types', top_node, top_nodes'
+
+let rec expand_decls_rec nused top_decls =
+ match top_decls with
+ | [] ->
+ []
+ | top_decl :: q -> (
+ match top_decl.top_decl_desc with
+ | Node nd ->
+ let used name =
+ List.exists (fun v -> v.var_id = name) nd.node_inputs
+ || List.exists (fun v -> v.var_id = name) nd.node_outputs
+ || List.exists (fun v -> v.var_id = name) nd.node_locals
+ in
+ let top_types', top_decl', top_nodes' =
+ expand_node_stmts nused used top_decl.top_decl_loc
+ top_decl.top_decl_owner nd
+ in
+ top_types' @ top_decl' :: expand_decls_rec nused (top_nodes' @ q)
+ | _ ->
+ top_decl :: expand_decls_rec nused q)
+
+let expand_decls top_decls =
+ let top_names =
+ List.fold_left
+ (fun names t ->
+ match t.top_decl_desc with
+ | Node nd ->
+ ISet.add nd.node_id names
+ | ImportedNode nd ->
+ ISet.add nd.nodei_id names
+ | _ ->
+ names)
+ ISet.empty top_decls
+ in
+ let nused name = ISet.mem name top_names in
+ expand_decls_rec nused top_decls
+
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
diff --git a/src/backends/Ada/ada_backend.ml b/src/backends/Ada/ada_backend.ml
index e6e7b49f7da69c9901f04ce8c88848ddb2b3863f..62dfbc888c60fc8409b196f88444bcd68636d733 100644
--- a/src/backends/Ada/ada_backend.ml
+++ b/src/backends/Ada/ada_backend.ml
@@ -11,131 +11,122 @@
open Format
open Machine_code_types
-
open Misc_lustre_function
open Ada_backend_common
let indent_size = 2
-(** Log at level 2 a string message with some indentation.
- @param indent the indentation level
- @param info the message
-**)
+(** Log at level 2 a string message with some indentation. @param indent the
+ indentation level @param info the message **)
let log_str_level_two indent info =
- let str_indent = String.make (indent*indent_size) ' ' in
+ let str_indent = String.make (indent * indent_size) ' ' in
let pp_message fmt = fprintf fmt "%s.. %s@." str_indent info in
Log.report ~level:2 pp_message;
Format.pp_print_flush Format.err_formatter ()
-(** Write a new file with formatter
- @param destname folder where the file shoudl be created
- @param pp_filename function printing the filename
- @param pp_file function wich pretty print the file
- @param arg will be given to pp_filename and pp_file
-**)
+(** Write a new file with formatter @param destname folder where the file shoudl
+ be created @param pp_filename function printing the filename @param pp_file
+ function wich pretty print the file @param arg will be given to pp_filename
+ and pp_file **)
let write_file destname pp_filename pp_file arg =
let path = asprintf "%s%a" destname pp_filename arg in
let out = open_out path in
let fmt = formatter_of_out_channel out in
- log_str_level_two 2 ("generating "^path);
+ log_str_level_two 2 ("generating " ^ path);
pp_file fmt arg;
pp_print_flush fmt ();
close_out out
-
-(** Exception raised when a machine contains a feature not supported by the
- Ada backend*)
exception CheckFailed of string
+(** Exception raised when a machine contains a feature not supported by the Ada
+ backend*)
-
-(** Check that a machine match the requirement for an Ada compilation :
- - No constants.
- @param machine the machine to test
-**)
+(** Check that a machine match the requirement for an Ada compilation : - No
+ constants. @param machine the machine to test **)
let check machine =
match machine.mconst with
- | [] -> ()
- | _ -> raise (CheckFailed "machine.mconst should be void")
-
+ | [] ->
+ ()
+ | _ ->
+ raise (CheckFailed "machine.mconst should be void")
let get_typed_submachines machines m =
- let instances = List.filter (fun (id, _) -> not (is_builtin_fun id)) m.mcalls in
+ let instances =
+ List.filter (fun (id, _) -> not (is_builtin_fun id)) m.mcalls
+ in
let submachines = List.map (get_machine machines) instances in
List.map2
(fun instance submachine ->
- let ident = (fst instance) in
+ let ident = fst instance in
ident, (get_substitution m ident submachine, submachine))
instances submachines
let extract_contract machines m =
let rec find_submachine_from_ident ident = function
- | [] -> raise Not_found
- | h::_ when h.mname.node_id = ident -> h
- | _::t -> find_submachine_from_ident ident t
+ | [] ->
+ raise Not_found
+ | h :: _ when h.mname.node_id = ident ->
+ h
+ | _ :: t ->
+ find_submachine_from_ident ident t
in
let extract_ident eexpr =
match eexpr.Lustre_types.eexpr_qfexpr.expr_desc with
- | Expr_ident ident -> ident
- | _ -> assert false
- (*
- | Expr_const cst -> assert false
- | Expr_tuple exprs -> assert false
- | Expr_ite (expr1, expr2, expr3) -> assert false
- | Expr_arrow (expr1, expr2) -> assert false
- | Expr_fby (expr1, expr2) -> assert false
- | Expr_array exprs -> assert false
- | Expr_access (expr1, dim) -> assert false
- | Expr_power (expr1, dim) -> assert false
- | Expr_pre expr -> assert false
- | Expr_when (expr,ident,label) -> assert false
- | Expr_merge (ident, l) -> assert false
- | Expr_appl call -> assert false
- *)
+ | Expr_ident ident ->
+ ident
+ | _ ->
+ assert false
+ (* | Expr_const cst -> assert false | Expr_tuple exprs -> assert false |
+ Expr_ite (expr1, expr2, expr3) -> assert false | Expr_arrow (expr1,
+ expr2) -> assert false | Expr_fby (expr1, expr2) -> assert false |
+ Expr_array exprs -> assert false | Expr_access (expr1, dim) -> assert
+ false | Expr_power (expr1, dim) -> assert false | Expr_pre expr -> assert
+ false | Expr_when (expr,ident,label) -> assert false | Expr_merge (ident,
+ l) -> assert false | Expr_appl call -> assert false *)
in
match m.mspec.mnode_spec with
- | Some (NodeSpec ident) ->
- begin
- let machine_spec = find_submachine_from_ident ident machines in
- let guarantees =
- match machine_spec.mspec.mnode_spec with
- | Some (Contract contract) ->
- assert (contract.consts=[]);
- assert (contract.locals=[]);
- assert (contract.stmts=[]);
- assert (contract.assume=[]);
- List.map extract_ident contract.guarantees
- | _ -> assert false
- in
- let opt_machine_spec =
- match machine_spec.mstep.step_instrs with
- | [] -> None
- | _ -> Some machine_spec
- in
- (opt_machine_spec, guarantees)
- end
- | _ -> None, []
+ | Some (NodeSpec ident) ->
+ let machine_spec = find_submachine_from_ident ident machines in
+ let guarantees =
+ match machine_spec.mspec.mnode_spec with
+ | Some (Contract contract) ->
+ assert (contract.consts = []);
+ assert (contract.locals = []);
+ assert (contract.stmts = []);
+ assert (contract.assume = []);
+ List.map extract_ident contract.guarantees
+ | _ ->
+ assert false
+ in
+ let opt_machine_spec =
+ match machine_spec.mstep.step_instrs with
+ | [] ->
+ None
+ | _ ->
+ Some machine_spec
+ in
+ opt_machine_spec, guarantees
+ | _ ->
+ None, []
(** Main function of the Ada backend. It calls all the subfunction creating all
-the file and fill them with Ada code representing the machines list given.
- @param basename name of the lustre file
- @param prog list of machines to translate
-**)
+ the file and fill them with Ada code representing the machines list given.
+ @param basename name of the lustre file @param prog list of machines to
+ translate **)
let translate_to_ada basename machines =
let module Ads = Ada_backend_ads.Main in
let module Adb = Ada_backend_adb.Main in
let module Wrapper = Ada_backend_wrapper.Main in
-
let is_real_machine m =
- match m.mspec.mnode_spec with
- | Some (Contract _) -> false
- | _ -> true
+ match m.mspec.mnode_spec with Some (Contract _) -> false | _ -> true
in
let filtered_machines = List.filter is_real_machine machines in
let typed_submachines =
- List.map (get_typed_submachines machines) filtered_machines in
-
+ List.map (get_typed_submachines machines) filtered_machines
+ in
+
let contracts = List.map (extract_contract machines) filtered_machines in
let _machines = List.combine contracts filtered_machines in
@@ -143,19 +134,23 @@ let translate_to_ada basename machines =
let _machines = List.combine typed_submachines _machines in
let _pp_filename ext fmt (_, (_, machine)) =
- pp_machine_filename ext fmt machine in
+ pp_machine_filename ext fmt machine
+ in
(* Extract the main machine if there is one *)
- let main_machine = (match !Options.main_node with
- | "" -> None
- | main_node -> (
- match Machine_code_common.get_machine_opt filtered_machines main_node with
- | None -> begin
- Format.eprintf "Ada Code generation error: %a@." Error.pp_error_msg Error.Main_not_found;
- raise (Error.Error (Location.dummy_loc, Error.Main_not_found))
- end
- | Some m -> Some m
- )) in
+ let main_machine =
+ match !Options.main_node with
+ | "" ->
+ None
+ | main_node -> (
+ match Machine_code_common.get_machine_opt filtered_machines main_node with
+ | None ->
+ Format.eprintf "Ada Code generation error: %a@." Error.pp_error_msg
+ Error.Main_not_found;
+ raise (Error.Error (Location.dummy_loc, Error.Main_not_found))
+ | Some m ->
+ Some m)
+ in
let destname = !Options.dest_dir ^ "/" in
@@ -171,25 +166,23 @@ let translate_to_ada basename machines =
(* If a main node is given we generate a main adb file and a project file *)
log_str_level_two 1 "Generating wrapper files";
(match main_machine with
- | None -> ()
- | Some machine ->
- write_file destname
- pp_main_filename
- (Wrapper.pp_main_adb (*get_typed_submachines filtered_machines machine*))
- machine;
- write_file destname
- (fun fmt _ -> Wrapper.pp_project_name (basename^"_exe") fmt)
- (Wrapper.pp_project_file filtered_machines basename)
- main_machine);
- write_file destname
- Wrapper.pp_project_configuration_name
+ | None ->
+ ()
+ | Some machine ->
+ write_file destname pp_main_filename Wrapper.pp_main_adb
+ (*get_typed_submachines filtered_machines machine*)
+ machine;
+ write_file destname
+ (fun fmt _ -> Wrapper.pp_project_name (basename ^ "_exe") fmt)
+ (Wrapper.pp_project_file filtered_machines basename)
+ main_machine);
+ write_file destname Wrapper.pp_project_configuration_name
(fun fmt _ -> Wrapper.pp_project_configuration_file fmt)
basename;
write_file destname
- (fun fmt _ -> Wrapper.pp_project_name (basename^"_lib") fmt)
+ (fun fmt _ -> Wrapper.pp_project_name (basename ^ "_lib") fmt)
(Wrapper.pp_project_file filtered_machines basename)
- None;
-
+ None
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
diff --git a/src/backends/Ada/ada_backend_adb.ml b/src/backends/Ada/ada_backend_adb.ml
index 18a0c7dd2c60134bbea0e9b0c61265cdde35fe8b..2d3c3a3523475bf0010df9f33bf7f04ec866662c 100644
--- a/src/backends/Ada/ada_backend_adb.ml
+++ b/src/backends/Ada/ada_backend_adb.ml
@@ -10,42 +10,30 @@
(********************************************************************)
open Format
-
open Machine_code_types
open Lustre_types
open Corelang
open Machine_code_common
-
open Misc_printer
open Misc_lustre_function
open Ada_printer
open Ada_backend_common
-(** Main module for generating packages bodies
- **)
-module Main =
-struct
-
+(** Main module for generating packages bodies **)
+module Main = struct
(** Printing function for basic assignement [var := value].
- @param fmt the formater to print on
- @param var_name the name of the variable
- @param value the value to be assigned
- **)
+ @param fmt the formater to print on @param var_name the name of the
+ variable @param value the value to be assigned **)
let pp_assign env fmt var value =
- fprintf fmt "%a := %a"
- (pp_var env) var
- (pp_value env) value
+ fprintf fmt "%a := %a" (pp_var env) var (pp_value env) value
- (** Printing function for instruction. See
- {!type:Machine_code_types.instr_t} for more details on
- machine types.
+ (** Printing function for instruction. See {!type:Machine_code_types.instr_t}
+ for more details on machine types.
- @param typed_submachines list of all typed machine instances of this machine
- @param machine the current machine
- @param fmt the formater to print on
- @param instr the instruction to print
- **)
+ @param typed_submachines list of all typed machine instances of this
+ machine @param machine the current machine @param fmt the formater to
+ print on @param instr the instruction to print **)
let rec pp_machine_instr typed_submachines env instr fmt =
let pp_instr = pp_machine_instr typed_submachines env in
(* Print args for a step call *)
@@ -56,158 +44,175 @@ struct
in
(* Print a case *)
let pp_case fmt (g, hl) =
- fprintf fmt "case %a is@,%aend case"
- (pp_value env) g
- pp_block (List.map pp_when hl)
+ fprintf fmt "case %a is@,%aend case" (pp_value env) g pp_block
+ (List.map pp_when hl)
in
(* Print a if *)
(* If neg is true the we must test for the negation of the condition. It
first check that we don't have a negation and a else case, if so it
- inverses the two branch and remove the negation doing a recursive
- call. *)
+ inverses the two branch and remove the negation doing a recursive call. *)
let pp_if fmt (neg, g, instrs1, instrs2) =
let pp_cond =
- if neg then
- fun fmt x -> fprintf fmt "! (%a)" (pp_value env) x
- else
- pp_value env
+ if neg then fun fmt x -> fprintf fmt "! (%a)" (pp_value env) x
+ else pp_value env
in
- let pp_else = match instrs2 with
- | None -> fun fmt -> fprintf fmt ""
- | Some i2 -> fun fmt ->
- fprintf fmt "else@,%a" pp_block (List.map pp_instr i2)
+ let pp_else =
+ match instrs2 with
+ | None ->
+ fun fmt -> fprintf fmt ""
+ | Some i2 ->
+ fun fmt -> fprintf fmt "else@,%a" pp_block (List.map pp_instr i2)
in
- fprintf fmt "if %a then@,%a%tend if"
- pp_cond g
- pp_block (List.map pp_instr instrs1)
+ fprintf fmt "if %a then@,%a%tend if" pp_cond g pp_block
+ (List.map pp_instr instrs1)
pp_else
in
match get_instr_desc instr with
- (* no reset *)
- | MNoReset _ -> ()
- (* TODO: handle clear_reset *)
- | MClearReset -> ()
- (* reset *)
- | MSetReset i when List.mem_assoc i typed_submachines ->
- let (substitution, submachine) = get_instance i typed_submachines in
- let pp_package = pp_package_name_with_polymorphic substitution submachine in
- let args = if is_machine_statefull submachine then [[pp_state i]] else [] in
- pp_call fmt (pp_package_access (pp_package, pp_reset_procedure_name), args)
- | MLocalAssign (ident, value) ->
- pp_assign env fmt ident value
- | MStateAssign (ident, value) ->
- pp_assign env fmt ident value
- | MStep ([i0], i, vl) when is_builtin_fun i ->
- let value = mk_val (Fun (i, vl)) i0.var_type in
- pp_assign env fmt i0 value
- | MStep (il, i, vl) when List.mem_assoc i typed_submachines ->
- let (substitution, submachine) = get_instance i typed_submachines in
- let pp_package = pp_package_name_with_polymorphic substitution submachine in
- let input = List.map (fun x fmt -> pp_value env fmt x) vl in
- let output = List.map pp_var_name il in
- let args =
- (if is_machine_statefull submachine then [[pp_state i]] else [])
- @(if input!=[] then [input] else [])
- @(if output!=[] then [output] else [])
- in
- pp_call fmt (pp_package_access (pp_package, pp_step_procedure_name), args)
- | MBranch (_, []) -> assert false
- | MBranch (g, (c1, i1)::tl) when c1=tag_false || c1=tag_true ->
- pp_if fmt (build_if g c1 i1 tl)
- | MBranch (g, hl) -> pp_case fmt (g, hl)
- | MComment s ->
- let lines = String.split_on_char '\n' s in
- fprintf fmt "%a" (Utils.fprintf_list ~sep:"" pp_oneline_comment) lines
- | _ -> assert false
+ (* no reset *)
+ | MNoReset _ ->
+ ()
+ (* TODO: handle clear_reset *)
+ | MClearReset ->
+ ()
+ (* reset *)
+ | MSetReset i when List.mem_assoc i typed_submachines ->
+ let substitution, submachine = get_instance i typed_submachines in
+ let pp_package =
+ pp_package_name_with_polymorphic substitution submachine
+ in
+ let args =
+ if is_machine_statefull submachine then [ [ pp_state i ] ] else []
+ in
+ pp_call fmt (pp_package_access (pp_package, pp_reset_procedure_name), args)
+ | MLocalAssign (ident, value) ->
+ pp_assign env fmt ident value
+ | MStateAssign (ident, value) ->
+ pp_assign env fmt ident value
+ | MStep ([ i0 ], i, vl) when is_builtin_fun i ->
+ let value = mk_val (Fun (i, vl)) i0.var_type in
+ pp_assign env fmt i0 value
+ | MStep (il, i, vl) when List.mem_assoc i typed_submachines ->
+ let substitution, submachine = get_instance i typed_submachines in
+ let pp_package =
+ pp_package_name_with_polymorphic substitution submachine
+ in
+ let input = List.map (fun x fmt -> pp_value env fmt x) vl in
+ let output = List.map pp_var_name il in
+ let args =
+ (if is_machine_statefull submachine then [ [ pp_state i ] ] else [])
+ @ (if input != [] then [ input ] else [])
+ @ if output != [] then [ output ] else []
+ in
+ pp_call fmt (pp_package_access (pp_package, pp_step_procedure_name), args)
+ | MBranch (_, []) ->
+ assert false
+ | MBranch (g, (c1, i1) :: tl) when c1 = tag_false || c1 = tag_true ->
+ pp_if fmt (build_if g c1 i1 tl)
+ | MBranch (g, hl) ->
+ pp_case fmt (g, hl)
+ | MComment s ->
+ let lines = String.split_on_char '\n' s in
+ fprintf fmt "%a" (Utils.fprintf_list ~sep:"" pp_oneline_comment) lines
+ | _ ->
+ assert false
(** Print the definition of the step procedure from a machine.
- @param typed_submachines list of all typed machine instances of this machine
- @param fmt the formater to print on
- @param machine the machine
- **)
+ @param typed_submachines list of all typed machine instances of this
+ machine @param fmt the formater to print on @param machine the machine **)
let pp_step_definition env typed_submachines fmt (m, m_spec_opt, guarantees) =
- let transform_local_to_state_assign instr = match instr.instr_desc with
- | MLocalAssign (ident, value) ->
+ let transform_local_to_state_assign instr =
+ match instr.instr_desc with
+ | MLocalAssign (ident, value) ->
{ instr with instr_desc = MStateAssign (ident, value) }
- | _ -> instr
+ | _ ->
+ instr
in
- let pp_local_ghost_list, spec_instrs = match m_spec_opt with
- | None -> [], []
+ let pp_local_ghost_list, spec_instrs =
+ match m_spec_opt with
+ | None ->
+ [], []
| Some m_spec ->
- List.map (build_pp_var_decl_local (Some (true, false, [], []))) (List.filter (fun x -> not (List.mem x.var_id guarantees)) m_spec.mstep.step_locals),
- List.map transform_local_to_state_assign m_spec.mstep.step_instrs
+ ( List.map
+ (build_pp_var_decl_local (Some (true, false, [], [])))
+ (List.filter
+ (fun x -> not (List.mem x.var_id guarantees))
+ m_spec.mstep.step_locals),
+ List.map transform_local_to_state_assign m_spec.mstep.step_instrs )
+ in
+ let pp_local_list =
+ List.map (build_pp_var_decl_local None) m.mstep.step_locals
+ in
+ let pp_instr_list =
+ List.map
+ (pp_machine_instr typed_submachines env)
+ (m.mstep.step_instrs @ spec_instrs)
+ in
+ let content =
+ AdaProcedureContent
+ ( ((if pp_local_ghost_list = [] then [] else [ pp_local_ghost_list ])
+ @ if pp_local_list = [] then [] else [ pp_local_list ]),
+ pp_instr_list )
in
- let pp_local_list = List.map (build_pp_var_decl_local None) (m.mstep.step_locals) in
- let pp_instr_list = List.map (pp_machine_instr typed_submachines env) (m.mstep.step_instrs@spec_instrs) in
- let content = AdaProcedureContent ((if pp_local_ghost_list = [] then [] else [pp_local_ghost_list])@(if pp_local_list = [] then [] else [pp_local_list]), pp_instr_list) in
pp_procedure pp_step_procedure_name (build_pp_arg_step m) None fmt content
(** Print the definition of the reset procedure from a machine.
- @param typed_submachines list of all typed machine instances of this machine
- @param fmt the formater to print on
- @param machine the machine
- **)
+ @param typed_submachines list of all typed machine instances of this
+ machine @param fmt the formater to print on @param machine the machine **)
let pp_reset_definition env typed_submachines fmt (m, m_spec_opt) =
- let build_assign = function var ->
- mkinstr (MStateAssign (var, mk_default_value var.var_type))
+ let build_assign = function
+ | var ->
+ mkinstr (MStateAssign (var, mk_default_value var.var_type))
in
- let env, memory = match m_spec_opt with
- | None -> env, m.mmemory
- | Some _ ->
- env,
- (m.mmemory)
+ let env, memory =
+ match m_spec_opt with None -> env, m.mmemory | Some _ -> env, m.mmemory
in
let assigns = List.map build_assign memory in
- let pp_instr_list = List.map (pp_machine_instr typed_submachines env) (assigns@m.minit) in
- pp_procedure pp_reset_procedure_name (build_pp_arg_reset m) None fmt (AdaProcedureContent ([], pp_instr_list))
+ let pp_instr_list =
+ List.map (pp_machine_instr typed_submachines env) (assigns @ m.minit)
+ in
+ pp_procedure pp_reset_procedure_name (build_pp_arg_reset m) None fmt
+ (AdaProcedureContent ([], pp_instr_list))
- (** Print the package definition(ads) of a machine.
- It requires the list of all typed instance.
- A typed submachine instance is (ident, type_machine) with ident
- the instance name and typed_machine is (substitution, machine) with machine
- the machine associated to the instance and substitution the instanciation of
- all its polymorphic types.
- @param fmt the formater to print on
- @param typed_submachines list of all typed machine instances of this machine
- @param m the machine
- **)
- let pp_file fmt (typed_submachines, ((opt_spec_machine, guarantees), machine)) =
+ (** Print the package definition(ads) of a machine. It requires the list of
+ all typed instance. A typed submachine instance is (ident, type_machine)
+ with ident the instance name and typed_machine is (substitution, machine)
+ with machine the machine associated to the instance and substitution the
+ instanciation of all its polymorphic types. @param fmt the formater to
+ print on @param typed_submachines list of all typed machine instances of
+ this machine @param m the machine **)
+ let pp_file fmt (typed_submachines, ((opt_spec_machine, guarantees), machine))
+ =
let env = List.map (fun x -> x.var_id, pp_state_name) machine.mmemory in
let pp_reset fmt =
if is_machine_statefull machine then
- fprintf fmt "%a;@,@," (pp_reset_definition env typed_submachines) (machine, opt_spec_machine)
- else
- fprintf fmt ""
+ fprintf fmt "%a;@,@,"
+ (pp_reset_definition env typed_submachines)
+ (machine, opt_spec_machine)
+ else fprintf fmt ""
in
let aux pkgs (id, _) =
try
- let (pkg, _) = List.assoc id ada_supported_funs in
- if List.mem pkg pkgs then
- pkgs
- else
- pkg::pkgs
+ let pkg, _ = List.assoc id ada_supported_funs in
+ if List.mem pkg pkgs then pkgs else pkg :: pkgs
with Not_found -> pkgs
in
let packages = List.map pp_str (List.fold_left aux [] machine.mcalls) in
let pp_content fmt =
- fprintf fmt "%t%a"
- (*Define the reset procedure*)
- pp_reset
-
+ fprintf fmt "%t%a" (*Define the reset procedure*) pp_reset
(*Define the step procedure*)
- (pp_step_definition env typed_submachines) (machine, opt_spec_machine, guarantees)
+ (pp_step_definition env typed_submachines)
+ (machine, opt_spec_machine, guarantees)
in
fprintf fmt "%a%t%a;@."
-
(* Include all the required packages*)
- (Utils.fprintf_list ~sep:";@," (pp_with AdaPrivate)) packages
+ (Utils.fprintf_list ~sep:";@," (pp_with AdaPrivate))
+ packages
(Utils.pp_final_char_if_non_empty ";@,@," packages)
-
(*Print package*)
- (pp_package (pp_package_name machine) [] true ) pp_content
-
+ (pp_package (pp_package_name machine) [] true)
+ pp_content
end
(* Local Variables: *)
diff --git a/src/backends/Ada/ada_backend_ads.ml b/src/backends/Ada/ada_backend_ads.ml
index 848b199030ff6f6905659fe269f21bcb1dd918e9..4a45191f1350582796dbac38685b1757f55373ea 100644
--- a/src/backends/Ada/ada_backend_ads.ml
+++ b/src/backends/Ada/ada_backend_ads.ml
@@ -10,216 +10,248 @@
(********************************************************************)
open Format
-
open Machine_code_types
open Lustre_types
-
open Misc_lustre_function
open Ada_printer
open Ada_backend_common
-
-
(** Functions printing the .ads file **)
-module Main =
-struct
-
- let rec init f = function i when i < 0 -> [] | i -> (f i)::(init f (i-1)) (*should be replaced by the init of list from ocaml std lib*)
+module Main = struct
+ let rec init f = function i when i < 0 -> [] | i -> f i :: init f (i - 1)
+ (*should be replaced by the init of list from ocaml std lib*)
let suffixOld = "_old"
+
let suffixNew = "_new"
+
let pp_invariant_name fmt = fprintf fmt "inv"
+
let pp_transition_name fmt = fprintf fmt "transition"
+
let pp_init_name fmt = fprintf fmt "init"
- let pp_state_name_predicate suffix fmt = fprintf fmt "%t%s" pp_state_name suffix
- let pp_axiomatize_package_name fmt = fprintf fmt "axiomatize"
+
+ let pp_state_name_predicate suffix fmt =
+ fprintf fmt "%t%s" pp_state_name suffix
+
+ let pp_axiomatize_package_name fmt = fprintf fmt "axiomatize"
(** Print the expression function representing the transition predicate.
- @param fmt the formater to print on
- **)
+ @param fmt the formater to print on **)
let pp_init_predicate fmt () =
- let new_state = (AdaIn, pp_state_name_predicate suffixNew, pp_state_type, None) in
- pp_predicate pp_init_name [[new_state]] true fmt None
+ let new_state =
+ AdaIn, pp_state_name_predicate suffixNew, pp_state_type, None
+ in
+ pp_predicate pp_init_name [ [ new_state ] ] true fmt None
(** Print the expression function representing the transition predicate.
- @param fmt the formater to print on
- @param machine the machine
- **)
+ @param fmt the formater to print on @param machine the machine **)
let pp_transition_predicate fmt (_, m) =
- let old_state = (AdaIn, pp_state_name_predicate suffixOld, pp_state_type, None) in
- let new_state = (AdaIn, pp_state_name_predicate suffixNew, pp_state_type, None) in
+ let old_state =
+ AdaIn, pp_state_name_predicate suffixOld, pp_state_type, None
+ in
+ let new_state =
+ AdaIn, pp_state_name_predicate suffixNew, pp_state_type, None
+ in
let inputs = build_pp_var_decl_step_input AdaIn None m in
let outputs = build_pp_var_decl_step_output AdaIn None m in
- pp_predicate pp_transition_name ([[old_state; new_state]]@inputs@outputs) true fmt None
+ pp_predicate pp_transition_name
+ ([ [ old_state; new_state ] ] @ inputs @ outputs)
+ true fmt None
let pp_invariant_predicate fmt () =
- pp_predicate pp_invariant_name [[build_pp_state_decl AdaIn None]] true fmt None
+ pp_predicate pp_invariant_name
+ [ [ build_pp_state_decl AdaIn None ] ]
+ true fmt None
- (** Print a new statement instantiating a generic package.
- @param fmt the formater to print on
- @param substitutions the instanciation substitution
- @param machine the machine to instanciate
- **)
+ (** Print a new statement instantiating a generic package. @param fmt the
+ formater to print on @param substitutions the instanciation substitution
+ @param machine the machine to instanciate **)
let pp_new_package fmt (substitutions, machine) =
let pp_name = pp_package_name machine in
let pp_new_name = pp_package_name_with_polymorphic substitutions machine in
- let instanciations = List.map (fun (id, typ) -> (pp_polymorphic_type id, fun fmt -> pp_type fmt typ)) substitutions in
+ let instanciations =
+ List.map
+ (fun (id, typ) -> pp_polymorphic_type id, fun fmt -> pp_type fmt typ)
+ substitutions
+ in
pp_package_instanciation pp_new_name pp_name fmt instanciations
- (** Remove duplicates from a list according to a given predicate.
- @param eq the predicate defining equality
- @param l the list to parse
- **)
+ (** Remove duplicates from a list according to a given predicate. @param eq
+ the predicate defining equality @param l the list to parse **)
let remove_duplicates eq l =
- let aux l x = if List.exists (eq x) l then l else x::l in
+ let aux l x = if List.exists (eq x) l then l else x :: l in
List.fold_left aux [] l
-
- (** Compare two typed machines.
- **)
+ (** Compare two typed machines. **)
let eq_typed_machine (subst1, machine1) (subst2, machine2) =
- (String.equal machine1.mname.node_id machine2.mname.node_id) &&
- (List.for_all2 (fun a b -> pp_eq_type (snd a) (snd b)) subst1 subst2)
-
-
- (** Print the package declaration(ads) of a machine.
- It requires the list of all typed instance.
- A typed submachine is a (ident, typed_machine) with
- - ident: the name
- - typed_machine: a (substitution, machine) with
- - machine: the submachine struct
- - substitution the instanciation of all its polymorphic types.
- @param fmt the formater to print on
- @param typed_submachines list of all typed submachines of this machine
- @param m the machine
- **)
+ String.equal machine1.mname.node_id machine2.mname.node_id
+ && List.for_all2 (fun a b -> pp_eq_type (snd a) (snd b)) subst1 subst2
+
+ (** Print the package declaration(ads) of a machine. It requires the list of
+ all typed instance. A typed submachine is a (ident, typed_machine) with -
+ ident: the name - typed_machine: a (substitution, machine) with - machine:
+ the submachine struct - substitution the instanciation of all its
+ polymorphic types. @param fmt the formater to print on @param
+ typed_submachines list of all typed submachines of this machine @param m
+ the machine **)
let pp_file fmt (typed_submachines, ((m_spec_opt, guarantees), m)) =
let typed_machines = snd (List.split typed_submachines) in
- let typed_machines_set = remove_duplicates eq_typed_machine typed_machines in
-
- let machines_to_import = List.map pp_package_name (snd (List.split typed_machines_set)) in
+ let typed_machines_set =
+ remove_duplicates eq_typed_machine typed_machines
+ in
+
+ let machines_to_import =
+ List.map pp_package_name (snd (List.split typed_machines_set))
+ in
let polymorphic_types = find_all_polymorphic_type m in
-
+
let typed_machines_to_instanciate =
- List.filter (fun (l, _) -> l != []) typed_machines_set in
+ List.filter (fun (l, _) -> l != []) typed_machines_set
+ in
- let typed_instances = List.filter is_submachine_statefull typed_submachines in
+ let typed_instances =
+ List.filter is_submachine_statefull typed_submachines
+ in
- let memories = match m_spec_opt with
- | None -> []
- | Some m -> List.map (fun x-> pp_var_decl (build_pp_var_decl AdaNoMode (Some (true, false, [], [])) x)) m.mmemory
+ let memories =
+ match m_spec_opt with
+ | None ->
+ []
+ | Some m ->
+ List.map
+ (fun x ->
+ pp_var_decl
+ (build_pp_var_decl AdaNoMode (Some (true, false, [], [])) x))
+ m.mmemory
in
let ghost_private = memories in
- (* Commented since not used. Could be reinjected in the code
- let vars_spec = match m_spec_opt with
- | None -> []
- | Some m_spec -> List.map (build_pp_var_decl AdaNoMode (Some (true, false, [], []))) (m_spec.mmemory)
- in *)
+ (* Commented since not used. Could be reinjected in the code let vars_spec =
+ match m_spec_opt with | None -> [] | Some m_spec -> List.map
+ (build_pp_var_decl AdaNoMode (Some (true, false, [], [])))
+ (m_spec.mmemory) in *)
let vars = List.map (build_pp_var_decl AdaNoMode None) m.mmemory in
- let states = List.map (build_pp_state_decl_from_subinstance AdaNoMode None) typed_instances in
+ let states =
+ List.map
+ (build_pp_state_decl_from_subinstance AdaNoMode None)
+ typed_instances
+ in
let var_lists =
- (if states = [] then [] else [states]) @
- (if vars = [] then [] else [vars]) in
-
+ (if states = [] then [] else [ states ])
+ @ if vars = [] then [] else [ vars ]
+ in
+
let pp_ifstatefull fmt pp =
- if is_machine_statefull m then
- fprintf fmt "%t" pp
- else
- fprintf fmt ""
+ if is_machine_statefull m then fprintf fmt "%t" pp else fprintf fmt ""
in
let pp_state_decl_and_reset fmt =
- let init fmt = pp_call fmt (pp_access pp_axiomatize_package_name pp_init_name, [[pp_state_name]]) in
- let contract = Some (false, false, [], [init]) in
+ let init fmt =
+ pp_call fmt
+ ( pp_access pp_axiomatize_package_name pp_init_name,
+ [ [ pp_state_name ] ] )
+ in
+ let contract = Some (false, false, [], [ init ]) in
fprintf fmt "%t;@,@,%a;@,@,"
(*Declare the state type*)
(pp_type_decl pp_state_type AdaPrivate)
-
(*Declare the reset procedure*)
- (pp_procedure pp_reset_procedure_name (build_pp_arg_reset m) contract) AdaNoContent
+ (pp_procedure pp_reset_procedure_name (build_pp_arg_reset m) contract)
+ AdaNoContent
in
let pp_private_section fmt =
fprintf fmt "@,private@,@,%a%t%a%t%a"
- (*Instantiate the polymorphic type that need to be instantiated*)
- (Utils.fprintf_list ~sep:";@," pp_new_package) typed_machines_to_instanciate
- (Utils.pp_final_char_if_non_empty ";@,@," typed_machines_to_instanciate)
-
- (*Define the state type*)
- pp_ifstatefull (fun fmt-> pp_record pp_state_type fmt var_lists)
-
- (Utils.pp_final_char_if_non_empty ";@,@," ghost_private)
- (Utils.fprintf_list ~sep:";@," (fun fmt pp -> pp fmt)) ghost_private
+ (*Instantiate the polymorphic type that need to be instantiated*)
+ (Utils.fprintf_list ~sep:";@," pp_new_package)
+ typed_machines_to_instanciate
+ (Utils.pp_final_char_if_non_empty ";@,@," typed_machines_to_instanciate)
+ (*Define the state type*)
+ pp_ifstatefull
+ (fun fmt -> pp_record pp_state_type fmt var_lists)
+ (Utils.pp_final_char_if_non_empty ";@,@," ghost_private)
+ (Utils.fprintf_list ~sep:";@," (fun fmt pp -> pp fmt))
+ ghost_private
in
let pp_content fmt =
let pp_contract_opt =
- let pp_var x fmt =
- pp_clean_ada_identifier fmt x
- in
+ let pp_var x fmt = pp_clean_ada_identifier fmt x in
let guarantee_post_conditions = List.map pp_var guarantees in
let state_pre_conditions, state_post_conditions =
if is_machine_statefull m then
- begin
let input = List.map pp_var_name m.mstep.step_inputs in
let output = List.map pp_var_name m.mstep.step_outputs in
let args =
- [[pp_old pp_state_name;pp_state_name]]
- @(if input!=[] then [input] else [])
- @(if output!=[] then [output] else [])
+ [ [ pp_old pp_state_name; pp_state_name ] ]
+ @ (if input != [] then [ input ] else [])
+ @ if output != [] then [ output ] else []
+ in
+ let transition fmt =
+ pp_call fmt
+ (pp_access pp_axiomatize_package_name pp_transition_name, args)
in
- let transition fmt = pp_call fmt (pp_access pp_axiomatize_package_name pp_transition_name, args) in
- let invariant fmt = pp_call fmt (pp_access pp_axiomatize_package_name pp_invariant_name, [[pp_state_name]]) in
- [invariant], [transition;invariant]
- end
- else
- [], []
+ let invariant fmt =
+ pp_call fmt
+ ( pp_access pp_axiomatize_package_name pp_invariant_name,
+ [ [ pp_state_name ] ] )
+ in
+ [ invariant ], [ transition; invariant ]
+ else [], []
+ in
+ let post_conditions =
+ state_post_conditions @ guarantee_post_conditions
in
- let post_conditions = state_post_conditions@guarantee_post_conditions in
let pre_conditions = state_pre_conditions in
- if post_conditions = [] && pre_conditions = [] then
- None
- else
- Some (false, false, pre_conditions, post_conditions)
+ if post_conditions = [] && pre_conditions = [] then None
+ else Some (false, false, pre_conditions, post_conditions)
+ in
+ let pp_guarantee name =
+ pp_var_decl
+ ( AdaNoMode,
+ (fun fmt -> pp_clean_ada_identifier fmt name),
+ pp_boolean_type,
+ Some (true, false, [], []) )
in
- let pp_guarantee name = pp_var_decl (AdaNoMode, (fun fmt -> pp_clean_ada_identifier fmt name), pp_boolean_type , (Some (true, false, [], []))) in
let ghost_public = List.map pp_guarantee guarantees in
fprintf fmt "@,%a%t%a%a%a@,@,%a;@,@,%t"
-
- (Utils.fprintf_list ~sep:";@," (fun fmt pp -> pp fmt)) ghost_public
+ (Utils.fprintf_list ~sep:";@," (fun fmt pp -> pp fmt))
+ ghost_public
(Utils.pp_final_char_if_non_empty ";@,@," ghost_public)
-
pp_ifstatefull pp_state_decl_and_reset
-
(*Declare the step procedure*)
- (pp_procedure pp_step_procedure_name (build_pp_arg_step m) pp_contract_opt) AdaNoContent
-
- pp_ifstatefull (fun fmt -> fprintf fmt ";@,")
-
- (pp_package (pp_axiomatize_package_name) [] false)
- (fun fmt -> fprintf fmt "pragma Annotate (GNATProve, External_Axiomatization);@,@,%a;@,%a;@,%a"
+ (pp_procedure pp_step_procedure_name (build_pp_arg_step m)
+ pp_contract_opt)
+ AdaNoContent pp_ifstatefull
+ (fun fmt -> fprintf fmt ";@,")
+ (pp_package pp_axiomatize_package_name [] false)
+ (fun fmt ->
+ fprintf fmt
+ "pragma Annotate (GNATProve, External_Axiomatization);@,\
+ @,\
+ %a;@,\
+ %a;@,\
+ %a"
(*Declare the init predicate*)
pp_init_predicate ()
(*Declare the transition predicate*)
pp_transition_predicate (m_spec_opt, m)
(*Declare the invariant predicate*)
pp_invariant_predicate ())
-
(*Print the private section*)
pp_private_section
in
-
+
let pp_poly_type id = pp_type_decl (pp_polymorphic_type id) AdaPrivate in
let pp_generics = List.map pp_poly_type polymorphic_types in
-
+
fprintf fmt "@[<v>%a%t%a;@]@."
-
(* Include all the subinstance package*)
- (Utils.fprintf_list ~sep:";@," (pp_with AdaNoVisibility)) machines_to_import
+ (Utils.fprintf_list ~sep:";@," (pp_with AdaNoVisibility))
+ machines_to_import
(Utils.pp_final_char_if_non_empty ";@,@," machines_to_import)
-
(*Begin the package*)
- (pp_package (pp_package_name m) pp_generics false) pp_content
-
+ (pp_package (pp_package_name m) pp_generics false)
+ pp_content
end
diff --git a/src/backends/Ada/ada_backend_common.ml b/src/backends/Ada/ada_backend_common.ml
index 68a5228d93b04572b289a0e83812fd447e6c51fc..fa2f1b8834239fdd594a5b85cdd5bf2d498b474d 100644
--- a/src/backends/Ada/ada_backend_common.ml
+++ b/src/backends/Ada/ada_backend_common.ml
@@ -1,377 +1,365 @@
open Format
-
open Machine_code_types
open Lustre_types
open Machine_code_common
-
open Ada_printer
open Misc_printer
open Misc_lustre_function
-(** Exception for unsupported features in Ada backend **)
exception Ada_not_supported of string
+(** Exception for unsupported features in Ada backend **)
-(** Print the name of the state variable.
- @param fmt the formater to print on
-**)
+(** Print the name of the state variable. @param fmt the formater to print on **)
let pp_state_name fmt = fprintf fmt "state"
-(** Print the type of the state variable.
- @param fmt the formater to print on
-**)
+(** Print the type of the state variable. @param fmt the formater to print on **)
let pp_state_type fmt = fprintf fmt "TState"
- (** Print the name of the reset procedure
- @param fmt the formater to print on
-**)
+(** Print the name of the reset procedure @param fmt the formater to print on **)
let pp_reset_procedure_name fmt = fprintf fmt "reset"
- (** Print the name of the step procedure
- @param fmt the formater to print on
-**)
+(** Print the name of the step procedure @param fmt the formater to print on **)
let pp_step_procedure_name fmt = fprintf fmt "step"
- (** Print the name of the main procedure.
- @param fmt the formater to print on
-**)
+(** Print the name of the main procedure. @param fmt the formater to print on **)
let pp_main_procedure_name fmt = fprintf fmt "ada_main"
- (** Print the name of the arrow package.
- @param fmt the formater to print on
-**)
+(** Print the name of the arrow package. @param fmt the formater to print on **)
let pp_arrow_package_name fmt = fprintf fmt "Arrow"
- (** Print the type of a polymorphic type.
- @param fmt the formater to print on
- @param id the id of the polymorphic type
-**)
+(** Print the type of a polymorphic type. @param fmt the formater to print on
+ @param id the id of the polymorphic type **)
let pp_polymorphic_type id fmt = fprintf fmt "T_%i" id
let pp_past_name nbr fmt = fprintf fmt "past_state_%i" nbr
-
-
-
-
-
-
-
-
-(*TODO Check all this function with unit test, improve this system and
- add support for : "cbrt", "erf", "log10", "pow", "atan2".
-*)
+(*TODO Check all this function with unit test, improve this system and add
+ support for : "cbrt", "erf", "log10", "pow", "atan2". *)
let ada_supported_funs =
- [("sqrt", ("Ada.Numerics.Elementary_Functions", "Sqrt"));
- ("log", ("Ada.Numerics.Elementary_Functions", "Log"));
- ("exp", ("Ada.Numerics.Elementary_Functions", "Exp"));
- ("pow", ("Ada.Numerics.Elementary_Functions", "**"));
- ("sin", ("Ada.Numerics.Elementary_Functions", "Sin"));
- ("cos", ("Ada.Numerics.Elementary_Functions", "Cos"));
- ("tan", ("Ada.Numerics.Elementary_Functions", "Tan"));
- ("asin", ("Ada.Numerics.Elementary_Functions", "Arcsin"));
- ("acos", ("Ada.Numerics.Elementary_Functions", "Arccos"));
- ("atan", ("Ada.Numerics.Elementary_Functions", "Arctan"));
- ("sinh", ("Ada.Numerics.Elementary_Functions", "Sinh"));
- ("cosh", ("Ada.Numerics.Elementary_Functions", "Cosh"));
- ("tanh", ("Ada.Numerics.Elementary_Functions", "Tanh"));
- ("asinh", ("Ada.Numerics.Elementary_Functions", "Arcsinh"));
- ("acosh", ("Ada.Numerics.Elementary_Functions", "Arccosh"));
- ("atanh", ("Ada.Numerics.Elementary_Functions", "Arctanh"));
-
- ("ceil", ("", "Float'Ceiling"));
- ("floor", ("", "Float'Floor"));
- ("fmod", ("", "Float'Remainder"));
- ("round", ("", "Float'Rounding"));
- ("trunc", ("", "Float'Truncation"));
-
- ("fabs", ("", "abs"));]
+ [
+ "sqrt", ("Ada.Numerics.Elementary_Functions", "Sqrt");
+ "log", ("Ada.Numerics.Elementary_Functions", "Log");
+ "exp", ("Ada.Numerics.Elementary_Functions", "Exp");
+ "pow", ("Ada.Numerics.Elementary_Functions", "**");
+ "sin", ("Ada.Numerics.Elementary_Functions", "Sin");
+ "cos", ("Ada.Numerics.Elementary_Functions", "Cos");
+ "tan", ("Ada.Numerics.Elementary_Functions", "Tan");
+ "asin", ("Ada.Numerics.Elementary_Functions", "Arcsin");
+ "acos", ("Ada.Numerics.Elementary_Functions", "Arccos");
+ "atan", ("Ada.Numerics.Elementary_Functions", "Arctan");
+ "sinh", ("Ada.Numerics.Elementary_Functions", "Sinh");
+ "cosh", ("Ada.Numerics.Elementary_Functions", "Cosh");
+ "tanh", ("Ada.Numerics.Elementary_Functions", "Tanh");
+ "asinh", ("Ada.Numerics.Elementary_Functions", "Arcsinh");
+ "acosh", ("Ada.Numerics.Elementary_Functions", "Arccosh");
+ "atanh", ("Ada.Numerics.Elementary_Functions", "Arctanh");
+ "ceil", ("", "Float'Ceiling");
+ "floor", ("", "Float'Floor");
+ "fmod", ("", "Float'Remainder");
+ "round", ("", "Float'Rounding");
+ "trunc", ("", "Float'Truncation");
+ "fabs", ("", "abs");
+ ]
let is_builtin_fun ident =
- List.mem ident Basic_library.internal_funs ||
- List.mem_assoc ident ada_supported_funs
+ List.mem ident Basic_library.internal_funs
+ || List.mem_assoc ident ada_supported_funs
-(** Print the name of a package associated to a machine.
- @param fmt the formater to print on
- @param machine the machine
-**)
+(** Print the name of a package associated to a machine. @param fmt the formater
+ to print on @param machine the machine **)
let pp_package_name machine fmt =
- if is_arrow machine then
- fprintf fmt "%t" pp_arrow_package_name
- else
- fprintf fmt "%a" pp_clean_ada_identifier machine.mname.node_id
-
-(** Print a type.
- @param fmt the formater to print on
- @param type the type
-**)
-let pp_type fmt typ =
- (match (Types.repr typ).Types.tdesc with
- | Types.Tbasic Types.Basic.Tint -> pp_integer_type fmt
- | Types.Tbasic Types.Basic.Treal -> pp_float_type fmt
- | Types.Tbasic Types.Basic.Tbool -> pp_boolean_type fmt
- | Types.Tunivar -> pp_polymorphic_type typ.Types.tid fmt
- | Types.Tbasic _ -> eprintf "Tbasic@."; assert false (*TODO*)
- | Types.Tconst _ -> eprintf "Tconst@."; assert false (*TODO*)
- | Types.Tclock _ -> eprintf "Tclock@."; assert false (*TODO*)
- | Types.Tarrow _ -> eprintf "Tarrow@."; assert false (*TODO*)
- | Types.Ttuple l -> eprintf "Ttuple %a @." (Utils.fprintf_list ~sep:" " Types.print_ty) l; assert false (*TODO*)
- | Types.Tenum _ -> eprintf "Tenum@."; assert false (*TODO*)
- | Types.Tstruct _ -> eprintf "Tstruct@.";assert false (*TODO*)
- | Types.Tarray _ -> eprintf "Tarray@."; assert false (*TODO*)
- | Types.Tstatic _ -> eprintf "Tstatic@.";assert false (*TODO*)
- | Types.Tlink _ -> eprintf "Tlink@."; assert false (*TODO*)
- | Types.Tvar -> eprintf "Tvar@."; assert false (*TODO*)
- (*| _ -> eprintf "Type error : %a@." Types.print_ty typ; assert false *)
- )
-
-(** Return a default ada constant for a given type.
- @param cst_typ the constant type
-**)
-let default_ada_cst cst_typ = match cst_typ with
- | Types.Basic.Tint -> Const_int 0
- | Types.Basic.Treal -> Const_real Real.zero
- | Types.Basic.Tbool -> Const_tag tag_false
- | _ -> assert false
-
-(** Make a default value from a given type.
- @param typ the type
-**)
+ if is_arrow machine then fprintf fmt "%t" pp_arrow_package_name
+ else fprintf fmt "%a" pp_clean_ada_identifier machine.mname.node_id
+
+(** Print a type. @param fmt the formater to print on @param type the type **)
+let pp_type fmt typ =
+ match (Types.repr typ).Types.tdesc with
+ | Types.Tbasic Types.Basic.Tint ->
+ pp_integer_type fmt
+ | Types.Tbasic Types.Basic.Treal ->
+ pp_float_type fmt
+ | Types.Tbasic Types.Basic.Tbool ->
+ pp_boolean_type fmt
+ | Types.Tunivar ->
+ pp_polymorphic_type typ.Types.tid fmt
+ | Types.Tbasic _ ->
+ eprintf "Tbasic@.";
+ assert false (*TODO*)
+ | Types.Tconst _ ->
+ eprintf "Tconst@.";
+ assert false (*TODO*)
+ | Types.Tclock _ ->
+ eprintf "Tclock@.";
+ assert false (*TODO*)
+ | Types.Tarrow _ ->
+ eprintf "Tarrow@.";
+ assert false (*TODO*)
+ | Types.Ttuple l ->
+ eprintf "Ttuple %a @." (Utils.fprintf_list ~sep:" " Types.print_ty) l;
+ assert false (*TODO*)
+ | Types.Tenum _ ->
+ eprintf "Tenum@.";
+ assert false (*TODO*)
+ | Types.Tstruct _ ->
+ eprintf "Tstruct@.";
+ assert false (*TODO*)
+ | Types.Tarray _ ->
+ eprintf "Tarray@.";
+ assert false (*TODO*)
+ | Types.Tstatic _ ->
+ eprintf "Tstatic@.";
+ assert false (*TODO*)
+ | Types.Tlink _ ->
+ eprintf "Tlink@.";
+ assert false (*TODO*)
+ | Types.Tvar ->
+ eprintf "Tvar@.";
+ assert false
+(*TODO*)
+(*| _ -> eprintf "Type error : %a@." Types.print_ty typ; assert false *)
+
+(** Return a default ada constant for a given type. @param cst_typ the constant
+ type **)
+let default_ada_cst cst_typ =
+ match cst_typ with
+ | Types.Basic.Tint ->
+ Const_int 0
+ | Types.Basic.Treal ->
+ Const_real Real.zero
+ | Types.Basic.Tbool ->
+ Const_tag tag_false
+ | _ ->
+ assert false
+
+(** Make a default value from a given type. @param typ the type **)
let mk_default_value typ =
match (Types.repr typ).Types.tdesc with
- | Types.Tbasic t -> mk_val (Cst (default_ada_cst t)) typ
- | _ -> assert false (*TODO*)
-
-(** Print the type of a variable.
- @param fmt the formater to print on
- @param id the variable
-**)
-let pp_var_type fmt id =
- pp_type fmt id.var_type
-
-(** Print a package name with polymorphic types specified.
- @param substitution correspondance between polymorphic type id and their instantiation
- @param fmt the formater to print on
- @param machine the machine
-**)
+ | Types.Tbasic t ->
+ mk_val (Cst (default_ada_cst t)) typ
+ | _ ->
+ assert false
+(*TODO*)
+
+(** Print the type of a variable. @param fmt the formater to print on @param id
+ the variable **)
+let pp_var_type fmt id = pp_type fmt id.var_type
+
+(** Print a package name with polymorphic types specified. @param substitution
+ correspondance between polymorphic type id and their instantiation @param
+ fmt the formater to print on @param machine the machine **)
let pp_package_name_with_polymorphic substitution machine fmt =
let polymorphic_types = find_all_polymorphic_type machine in
- assert(List.length polymorphic_types = List.length substitution);
+ assert (List.length polymorphic_types = List.length substitution);
let substituion = List.sort_uniq (fun x y -> fst x - fst y) substitution in
- assert(List.for_all2 (fun poly1 (poly2, _) -> poly1 = poly2)
- polymorphic_types substituion);
+ assert (
+ List.for_all2
+ (fun poly1 (poly2, _) -> poly1 = poly2)
+ polymorphic_types substituion);
let instantiated_types = snd (List.split substitution) in
- fprintf fmt "%t%t%a"
- (pp_package_name machine)
+ fprintf fmt "%t%t%a" (pp_package_name machine)
(Utils.pp_final_char_if_non_empty "_" instantiated_types)
- (Utils.fprintf_list ~sep:"_" pp_type) instantiated_types
-
-(** Print the name of a variable.
- @param fmt the formater to print on
- @param id the variable
-**)
-let pp_var_name id fmt =
- fprintf fmt "%a" pp_clean_ada_identifier id.var_id
-
-(** Print the complete name of variable.
- @param m the machine to check if it is memory
- @param fmt the formater to print on
- @param var the variable
-**)
+ (Utils.fprintf_list ~sep:"_" pp_type)
+ instantiated_types
+
+(** Print the name of a variable. @param fmt the formater to print on @param id
+ the variable **)
+let pp_var_name id fmt = fprintf fmt "%a" pp_clean_ada_identifier id.var_id
+
+(** Print the complete name of variable. @param m the machine to check if it is
+ memory @param fmt the formater to print on @param var the variable **)
let pp_var env fmt var =
match List.assoc_opt var.var_id env with
- | None -> pp_var_name var fmt
- | Some pp_state -> pp_access pp_state (pp_var_name var) fmt
+ | None ->
+ pp_var_name var fmt
+ | Some pp_state ->
+ pp_access pp_state (pp_var_name var) fmt
(* Expression print functions *)
(* Printing functions for basic operations and expressions *)
-(* TODO: refactor code -> use let rec and for basic pretty printing
- function *)
+(* TODO: refactor code -> use let rec and for basic pretty printing function *)
+
(** Printing function for Ada tags, mainly booleans.
- @param fmt the formater to use
- @param t the tag to print
- **)
+ @param fmt the formater to use @param t the tag to print **)
let pp_ada_tag fmt t =
pp_print_string fmt
(if t = tag_true then "True" else if t = tag_false then "False" else t)
-(** Printing function for machine type constants. For the moment,
- arrays are not supported.
+(** Printing function for machine type constants. For the moment, arrays are not
+ supported.
- @param fmt the formater to use
- @param c the constant to print
- **)
+ @param fmt the formater to use @param c the constant to print **)
let pp_ada_const fmt c =
match c with
- | Const_int i -> pp_print_int fmt i
- | Const_real r -> Real.pp_ada fmt r
- | Const_tag t -> pp_ada_tag fmt t
+ | Const_int i ->
+ pp_print_int fmt i
+ | Const_real r ->
+ Real.pp_ada fmt r
+ | Const_tag t ->
+ pp_ada_tag fmt t
| Const_string _ | Const_modeid _ ->
- (Format.eprintf
- "internal error: Ada_backend_adb.pp_ada_const cannot print string or modeid.";
- assert false)
- | _ ->
- raise (Ada_not_supported "unsupported: Ada_backend_adb.pp_ada_const does not
- support this constant")
-
-(** Printing function for expressions [v1 modulo v2]. Depends
- on option [integer_div_euclidean] to choose between mathematical
- modulo or remainder ([rem] in Ada).
-
- @param pp_value pretty printer for values
- @param v1 the first value in the expression
- @param v2 the second value in the expression
- @param fmt the formater to print on
- **)
+ Format.eprintf
+ "internal error: Ada_backend_adb.pp_ada_const cannot print string or \
+ modeid.";
+ assert false
+ | _ ->
+ raise
+ (Ada_not_supported
+ "unsupported: Ada_backend_adb.pp_ada_const does not\n\
+ \ support this constant")
+
+(** Printing function for expressions [v1 modulo v2]. Depends on option
+ [integer_div_euclidean] to choose between mathematical modulo or remainder
+ ([rem] in Ada).
+
+ @param pp_value pretty printer for values @param v1 the first value in the
+ expression @param v2 the second value in the expression @param fmt the
+ formater to print on **)
let pp_mod pp_value v1 v2 fmt =
if !Options.integer_div_euclidean then
(* (a rem b) + (a rem b < 0 ? abs(b) : 0) *)
Format.fprintf fmt
- "((%a rem %a) + (if (%a rem %a) < 0 then abs(%a) else 0))"
- pp_value v1 pp_value v2
- pp_value v1 pp_value v2
- pp_value v2
- else (* Ada behavior for rem *)
+ "((%a rem %a) + (if (%a rem %a) < 0 then abs(%a) else 0))" pp_value v1
+ pp_value v2 pp_value v1 pp_value v2 pp_value v2
+ else
+ (* Ada behavior for rem *)
Format.fprintf fmt "(%a rem %a)" pp_value v1 pp_value v2
-(** Printing function for expressions [v1 div v2]. Depends on
- option [integer_div_euclidean] to choose between mathematic
- division or Ada division.
+(** Printing function for expressions [v1 div v2]. Depends on option
+ [integer_div_euclidean] to choose between mathematic division or Ada
+ division.
- @param pp_value pretty printer for values
- @param v1 the first value in the expression
- @param v2 the second value in the expression
- @param fmt the formater to print in
- **)
+ @param pp_value pretty printer for values @param v1 the first value in the
+ expression @param v2 the second value in the expression @param fmt the
+ formater to print in **)
let pp_div pp_value v1 v2 fmt =
if !Options.integer_div_euclidean then
(* (a - ((a rem b) + (if a rem b < 0 then abs (b) else 0))) / b) *)
- Format.fprintf fmt "(%a - %t) / %a"
- pp_value v1
- (pp_mod pp_value v1 v2)
+ Format.fprintf fmt "(%a - %t) / %a" pp_value v1 (pp_mod pp_value v1 v2)
pp_value v2
- else (* Ada behavior for / *)
+ else
+ (* Ada behavior for / *)
Format.fprintf fmt "(%a / %a)" pp_value v1 pp_value v2
(** Printing function for basic lib functions.
- @param pp_value pretty printer for values
- @param i a string representing the function
- @param fmt the formater to print on
- @param vl the list of operands
- **)
+ @param pp_value pretty printer for values @param i a string representing the
+ function @param fmt the formater to print on @param vl the list of operands
+ **)
let pp_basic_lib_fun pp_value ident fmt vl =
match ident, vl with
- | "uminus", [v] ->
+ | "uminus", [ v ] ->
Format.fprintf fmt "(- %a)" pp_value v
- | "not", [v] ->
+ | "not", [ v ] ->
Format.fprintf fmt "(not %a)" pp_value v
- | "impl", [v1; v2] ->
+ | "impl", [ v1; v2 ] ->
Format.fprintf fmt "(not %a or else %a)" pp_value v1 pp_value v2
- | "=", [v1; v2] ->
+ | "=", [ v1; v2 ] ->
Format.fprintf fmt "(%a = %a)" pp_value v1 pp_value v2
- | "mod", [v1; v2] -> pp_mod pp_value v1 v2 fmt
- | "equi", [v1; v2] ->
+ | "mod", [ v1; v2 ] ->
+ pp_mod pp_value v1 v2 fmt
+ | "equi", [ v1; v2 ] ->
Format.fprintf fmt "((not %a) = (not %a))" pp_value v1 pp_value v2
- | "xor", [v1; v2] ->
+ | "xor", [ v1; v2 ] ->
Format.fprintf fmt "((not %a) /= (not %a))" pp_value v1 pp_value v2
- | "/", [v1; v2] -> pp_div pp_value v1 v2 fmt
- | "&&", [v1; v2] ->
+ | "/", [ v1; v2 ] ->
+ pp_div pp_value v1 v2 fmt
+ | "&&", [ v1; v2 ] ->
Format.fprintf fmt "(%a %s %a)" pp_value v1 "and then" pp_value v2
- | "||", [v1; v2] ->
+ | "||", [ v1; v2 ] ->
Format.fprintf fmt "(%a %s %a)" pp_value v1 "or else" pp_value v2
- | "!=", [v1; v2] ->
+ | "!=", [ v1; v2 ] ->
Format.fprintf fmt "(%a %s %a)" pp_value v1 "/=" pp_value v2
- | "ite", [v1; v2; v3] ->
- Format.fprintf fmt "(if %a then %a else %a)" pp_value v1 pp_value v2 pp_value v3
- | op, [v1; v2] ->
+ | "ite", [ v1; v2; v3 ] ->
+ Format.fprintf fmt "(if %a then %a else %a)" pp_value v1 pp_value v2
+ pp_value v3
+ | op, [ v1; v2 ] ->
Format.fprintf fmt "(%a %s %a)" pp_value v1 op pp_value v2
- | _, [v1] when List.mem_assoc ident ada_supported_funs ->
- let pkg, name = try List.assoc ident ada_supported_funs
- with Not_found -> assert false in
- let pkg = pkg^(if String.equal pkg "" then "" else ".") in
- Format.fprintf fmt "%s%s(%a)" pkg name pp_value v1
- | fun_name, _ ->
- (Format.eprintf "internal compilation error: basic function %s@." fun_name; assert false)
+ | _, [ v1 ] when List.mem_assoc ident ada_supported_funs ->
+ let pkg, name =
+ try List.assoc ident ada_supported_funs with Not_found -> assert false
+ in
+ let pkg = pkg ^ if String.equal pkg "" then "" else "." in
+ Format.fprintf fmt "%s%s(%a)" pkg name pp_value v1
+ | fun_name, _ ->
+ Format.eprintf "internal compilation error: basic function %s@." fun_name;
+ assert false
(** Printing function for values.
- @param m the machine to know the state variable
- @param fmt the formater to use
- @param value the value to print. Should be a
- {!type:Machine_code_types.value_t} value
- **)
+ @param m the machine to know the state variable @param fmt the formater to
+ use @param value the value to print. Should be a
+ {!type:Machine_code_types.value_t} value **)
let rec pp_value env fmt value =
match value.value_desc with
- | Cst c -> pp_ada_const fmt c
- | Var var -> pp_var env fmt var (* Find better to test if it is memory or not *)
- | Fun (f_ident, vl) -> pp_basic_lib_fun (pp_value env) f_ident fmt vl
- | _ ->
- raise (Ada_not_supported
- "unsupported: Ada_backend.adb.pp_value does not support this value type")
-
-
-(** Print the filename of a machine package.
- @param extension the extension to append to the package name
- @param fmt the formatter
- @param machine the machine corresponding to the package
-**)
+ | Cst c ->
+ pp_ada_const fmt c
+ | Var var ->
+ pp_var env fmt var (* Find better to test if it is memory or not *)
+ | Fun (f_ident, vl) ->
+ pp_basic_lib_fun (pp_value env) f_ident fmt vl
+ | _ ->
+ raise
+ (Ada_not_supported
+ "unsupported: Ada_backend.adb.pp_value does not support this value \
+ type")
+
+(** Print the filename of a machine package. @param extension the extension to
+ append to the package name @param fmt the formatter @param machine the
+ machine corresponding to the package **)
let pp_machine_filename extension fmt machine =
pp_filename extension fmt (pp_package_name machine)
let pp_main_filename fmt _ = pp_filename "adb" fmt pp_main_procedure_name
-
(** Print the declaration of a state element of a subinstance of a machine.
- @param machine the machine
- @param fmt the formater to print on
- @param substitution correspondance between polymorphic type id and their instantiation
- @param ident the identifier of the subinstance
- @param submachine the submachine of the subinstance
-**)
-let build_pp_state_decl_from_subinstance mode with_statement (name, (substitution, machine)) =
+ @param machine the machine @param fmt the formater to print on @param
+ substitution correspondance between polymorphic type id and their
+ instantiation @param ident the identifier of the subinstance @param
+ submachine the submachine of the subinstance **)
+let build_pp_state_decl_from_subinstance mode with_statement
+ (name, (substitution, machine)) =
let pp_package = pp_package_name_with_polymorphic substitution machine in
let pp_type = pp_package_access (pp_package, pp_state_type) in
let pp_name fmt = pp_clean_ada_identifier fmt name in
- (mode, pp_name, pp_type, with_statement)
+ mode, pp_name, pp_type, with_statement
-(** Print variable declaration for a local state variable
- @param fmt the formater to print on
- @param mode input/output mode of the parameter
-**)
+(** Print variable declaration for a local state variable @param fmt the
+ formater to print on @param mode input/output mode of the parameter **)
let build_pp_state_decl mode with_statement =
- (mode, pp_state_name, pp_state_type, with_statement)
+ mode, pp_state_name, pp_state_type, with_statement
let build_pp_var_decl mode with_statement var =
let pp_name = function fmt -> pp_var_name var fmt in
let pp_type = function fmt -> pp_var_type fmt var in
- (mode, pp_name, pp_type, with_statement)
+ mode, pp_name, pp_type, with_statement
let build_pp_var_decl_local with_statement var =
AdaLocalVar (build_pp_var_decl AdaNoMode with_statement var)
let build_pp_var_decl_step_input mode with_statement m =
- if m.mstep.step_inputs=[] then [] else
- [List.map (build_pp_var_decl mode with_statement) m.mstep.step_inputs]
+ if m.mstep.step_inputs = [] then []
+ else [ List.map (build_pp_var_decl mode with_statement) m.mstep.step_inputs ]
let build_pp_var_decl_step_output mode with_statement m =
- if m.mstep.step_outputs=[] then [] else
- [List.map (build_pp_var_decl mode with_statement) m.mstep.step_outputs]
+ if m.mstep.step_outputs = [] then []
+ else [ List.map (build_pp_var_decl mode with_statement) m.mstep.step_outputs ]
let build_pp_var_decl_static mode with_statement m =
- if m.mstatic=[] then [] else
- [List.map (build_pp_var_decl mode with_statement) m.mstatic]
+ if m.mstatic = [] then []
+ else [ List.map (build_pp_var_decl mode with_statement) m.mstatic ]
let build_pp_arg_step m =
- (if is_machine_statefull m then [[build_pp_state_decl AdaInOut None]] else [])
- @ (build_pp_var_decl_step_input AdaIn None m)
- @ (build_pp_var_decl_step_output AdaOut None m)
+ (if is_machine_statefull m then [ [ build_pp_state_decl AdaInOut None ] ]
+ else [])
+ @ build_pp_var_decl_step_input AdaIn None m
+ @ build_pp_var_decl_step_output AdaOut None m
let build_pp_arg_reset m =
- (if is_machine_statefull m then [[build_pp_state_decl AdaOut None]] else [])
- @ (build_pp_var_decl_static AdaIn None m)
-
+ (if is_machine_statefull m then [ [ build_pp_state_decl AdaOut None ] ]
+ else [])
+ @ build_pp_var_decl_static AdaIn None m
(* let build_pp_arg_transition m =
* (if is_machine_statefull m then [[build_pp_state_decl AdaInOut None]] else [])
diff --git a/src/backends/Ada/ada_backend_common.mli b/src/backends/Ada/ada_backend_common.mli
index fbf0dc70ec83c85df22796062beb21b12d09f598..426b3e485ad849e96fcecda1121285ffced6cf6e 100644
--- a/src/backends/Ada/ada_backend_common.mli
+++ b/src/backends/Ada/ada_backend_common.mli
@@ -1,42 +1,67 @@
open Format
-
open Machine_code_types
open Lustre_types
open Types
-
open Ada_printer
open Misc_printer
val pp_state_name : printer
+
val pp_state_type : printer
+
val pp_reset_procedure_name : printer
+
val pp_step_procedure_name : printer
+
val pp_main_procedure_name : printer
+
val pp_polymorphic_type : int -> printer
+
val pp_past_name : int -> printer
val is_builtin_fun : string -> bool
-val ada_supported_funs : (string*(string*string)) list
+
+val ada_supported_funs : (string * (string * string)) list
val pp_var_name : var_decl -> formatter -> unit
-val pp_var : ((string*printer) list) -> formatter -> var_decl -> unit
-val pp_value : ((string*printer) list) -> formatter -> value_t -> unit
+
+val pp_var : (string * printer) list -> formatter -> var_decl -> unit
+
+val pp_value : (string * printer) list -> formatter -> value_t -> unit
+
val pp_type : formatter -> type_expr -> unit
+
val pp_var_type : formatter -> var_decl -> unit
val pp_package_name : machine_t -> printer
-val pp_package_name_with_polymorphic : (int * Types.type_expr) list -> machine_t -> printer
+
+val pp_package_name_with_polymorphic :
+ (int * Types.type_expr) list -> machine_t -> printer
val mk_default_value : type_expr -> value_t
val build_pp_var_decl : parameter_mode -> ada_with -> var_decl -> ada_var_decl
+
val build_pp_var_decl_local : ada_with -> var_decl -> ada_local_decl
-val build_pp_var_decl_step_input : parameter_mode -> ada_with -> machine_t -> (ada_var_decl list list)
-val build_pp_var_decl_step_output : parameter_mode -> ada_with -> machine_t -> (ada_var_decl list list)
-val build_pp_arg_step : machine_t -> (ada_var_decl list list)
-val build_pp_arg_reset : machine_t -> (ada_var_decl list list)
-val build_pp_state_decl_from_subinstance : parameter_mode -> ada_with -> (string * ((int * Types.type_expr) list * Machine_code_types.machine_t)) -> ada_var_decl
+
+val build_pp_var_decl_step_input :
+ parameter_mode -> ada_with -> machine_t -> ada_var_decl list list
+
+val build_pp_var_decl_step_output :
+ parameter_mode -> ada_with -> machine_t -> ada_var_decl list list
+
+val build_pp_arg_step : machine_t -> ada_var_decl list list
+
+val build_pp_arg_reset : machine_t -> ada_var_decl list list
+
+val build_pp_state_decl_from_subinstance :
+ parameter_mode ->
+ ada_with ->
+ string * ((int * Types.type_expr) list * Machine_code_types.machine_t) ->
+ ada_var_decl
+
val build_pp_state_decl : parameter_mode -> ada_with -> ada_var_decl
val pp_machine_filename : string -> formatter -> machine_t -> unit
+
val pp_main_filename : formatter -> machine_t -> unit
diff --git a/src/backends/Ada/ada_backend_wrapper.ml b/src/backends/Ada/ada_backend_wrapper.ml
index 90b5b7f16bab7fd584c8bb3b1a01b601d94b0ccc..0caa505d454f29edd75d1cc3b70aee7b65cc9366 100644
--- a/src/backends/Ada/ada_backend_wrapper.ml
+++ b/src/backends/Ada/ada_backend_wrapper.ml
@@ -10,111 +10,148 @@
(********************************************************************)
open Format
-
open Machine_code_types
open Lustre_types
-
open Misc_printer
open Misc_lustre_function
open Ada_printer
open Ada_backend_common
-module Main =
-struct
-
+module Main = struct
let build_text_io_package_local typ =
- AdaLocalPackage (
- (fun fmt -> fprintf fmt "%s_IO" typ),
- (fun fmt -> fprintf fmt "Ada.Text_IO.%s_IO" typ),
- [((fun fmt -> fprintf fmt "Num"), (fun fmt -> fprintf fmt "%s" typ))])
-
- (** Print the main file calling in a loop the step function of the main machine.
- @param fmt the formater to print on
- @param machine the main machine
- **)
+ AdaLocalPackage
+ ( (fun fmt -> fprintf fmt "%s_IO" typ),
+ (fun fmt -> fprintf fmt "Ada.Text_IO.%s_IO" typ),
+ [ ((fun fmt -> fprintf fmt "Num"), fun fmt -> fprintf fmt "%s" typ) ] )
+
+ (** Print the main file calling in a loop the step function of the main
+ machine. @param fmt the formater to print on @param machine the main
+ machine **)
let pp_main_adb fmt machine =
let statefull = is_machine_statefull machine in
-
+
let pp_package = pp_package_name_with_polymorphic [] machine in
-
+
(* Dependances *)
let text_io = "Ada.Text_IO" in
-
+
(* Locals *)
let locals =
- [[build_text_io_package_local "Integer";build_text_io_package_local "Float"]]
- @(if statefull then [[AdaLocalVar (build_pp_state_decl_from_subinstance AdaNoMode None (asprintf "%t" pp_state_name, ([], machine)))]] else [])
- @(if machine.mstep.step_inputs != [] then [List.map (build_pp_var_decl_local None) machine.mstep.step_inputs] else [])
- @(if machine.mstep.step_outputs != [] then [List.map (build_pp_var_decl_local None) machine.mstep.step_outputs] else [])
+ [
+ [
+ build_text_io_package_local "Integer";
+ build_text_io_package_local "Float";
+ ];
+ ]
+ @ (if statefull then
+ [
+ [
+ AdaLocalVar
+ (build_pp_state_decl_from_subinstance AdaNoMode None
+ (asprintf "%t" pp_state_name, ([], machine)));
+ ];
+ ]
+ else [])
+ @ (if machine.mstep.step_inputs != [] then
+ [ List.map (build_pp_var_decl_local None) machine.mstep.step_inputs ]
+ else [])
+ @
+ if machine.mstep.step_outputs != [] then
+ [ List.map (build_pp_var_decl_local None) machine.mstep.step_outputs ]
+ else []
in
(* Stream instructions *)
- let get_basic var = match (Types.repr var.var_type ).Types.tdesc with
- Types.Tbasic x -> x | _ -> assert false in
+ let get_basic var =
+ match (Types.repr var.var_type).Types.tdesc with
+ | Types.Tbasic x ->
+ x
+ | _ ->
+ assert false
+ in
let pp_read fmt var =
match get_basic var with
- | Types.Basic.Tbool ->
- fprintf fmt "%t := Integer'Value(Ada.Text_IO.Get_Line) /= 0"
- (pp_var_name var)
- | _ ->
- fprintf fmt "%t := %a'Value(Ada.Text_IO.Get_Line)"
- (pp_var_name var)
- pp_var_type var
+ | Types.Basic.Tbool ->
+ fprintf fmt "%t := Integer'Value(Ada.Text_IO.Get_Line) /= 0"
+ (pp_var_name var)
+ | _ ->
+ fprintf fmt "%t := %a'Value(Ada.Text_IO.Get_Line)" (pp_var_name var)
+ pp_var_type var
in
let pp_write fmt var =
match get_basic var with
- | Types.Basic.Tbool ->
- fprintf fmt "Ada.Text_IO.Put_Line(\"'%t': '\" & (if %t then \"1\" else \"0\") & \"' \")"
- (pp_var_name var)
- (pp_var_name var)
- | Types.Basic.Tint ->
- fprintf fmt "Ada.Text_IO.Put(\"'%t': '\");@,Integer_IO.Put(%t);@,Ada.Text_IO.Put_Line(\"' \")"
- (pp_var_name var)
- (pp_var_name var)
- | Types.Basic.Treal ->
- fprintf fmt "Ada.Text_IO.Put(\"'%t': '\");@,Float_IO.Put(%t, Fore=>0, Aft=> 15, Exp => 0);@,Ada.Text_IO.Put_Line(\"' \")"
- (pp_var_name var)
- (pp_var_name var)
- | Types.Basic.Tstring | Types.Basic.Trat -> assert false (* Could not be the top level inputs *)
+ | Types.Basic.Tbool ->
+ fprintf fmt
+ "Ada.Text_IO.Put_Line(\"'%t': '\" & (if %t then \"1\" else \"0\") & \
+ \"' \")"
+ (pp_var_name var) (pp_var_name var)
+ | Types.Basic.Tint ->
+ fprintf fmt
+ "Ada.Text_IO.Put(\"'%t': '\");@,\
+ Integer_IO.Put(%t);@,\
+ Ada.Text_IO.Put_Line(\"' \")" (pp_var_name var) (pp_var_name var)
+ | Types.Basic.Treal ->
+ fprintf fmt
+ "Ada.Text_IO.Put(\"'%t': '\");@,\
+ Float_IO.Put(%t, Fore=>0, Aft=> 15, Exp => 0);@,\
+ Ada.Text_IO.Put_Line(\"' \")" (pp_var_name var) (pp_var_name var)
+ | Types.Basic.Tstring | Types.Basic.Trat ->
+ assert false
+ (* Could not be the top level inputs *)
in
(* Loop instructions *)
let pp_loop fmt =
- let args = pp_state_name::(List.map pp_var_name (machine.mstep.step_inputs@machine.mstep.step_outputs)) in
- fprintf fmt "while not Ada.Text_IO.End_Of_File loop@, @[<v>%a;@,%a;@,%a;@]@,end loop"
- (Utils.fprintf_list ~sep:";@," pp_read) machine.mstep.step_inputs
- pp_call (pp_package_access (pp_package, pp_step_procedure_name), [args])
- (Utils.fprintf_list ~sep:";@," pp_write) machine.mstep.step_outputs in
-
+ let args =
+ pp_state_name
+ ::
+ List.map pp_var_name
+ (machine.mstep.step_inputs @ machine.mstep.step_outputs)
+ in
+ fprintf fmt
+ "while not Ada.Text_IO.End_Of_File loop@,\
+ \ @[<v>%a;@,\
+ %a;@,\
+ %a;@]@,\
+ end loop"
+ (Utils.fprintf_list ~sep:";@," pp_read)
+ machine.mstep.step_inputs pp_call
+ (pp_package_access (pp_package, pp_step_procedure_name), [ args ])
+ (Utils.fprintf_list ~sep:";@," pp_write)
+ machine.mstep.step_outputs
+ in
+
(* Print the file *)
- let instrs = (if statefull then [fun fmt -> pp_call fmt (pp_package_access (pp_package, pp_reset_procedure_name), [[pp_state_name]])] else [])@[pp_loop] in
- fprintf fmt "@[<v>%a;@,%a;@,@,%a;@]"
- (pp_with AdaPrivate) (pp_str text_io)
+ let instrs =
+ (if statefull then
+ [
+ (fun fmt ->
+ pp_call fmt
+ ( pp_package_access (pp_package, pp_reset_procedure_name),
+ [ [ pp_state_name ] ] ));
+ ]
+ else [])
+ @ [ pp_loop ]
+ in
+ fprintf fmt "@[<v>%a;@,%a;@,@,%a;@]" (pp_with AdaPrivate) (pp_str text_io)
(pp_with AdaPrivate) (pp_package_name machine)
- (pp_procedure pp_main_procedure_name [] None) (AdaProcedureContent (locals, instrs))
-
- (** Print the name of the ada project configuration file.
- @param fmt the formater to print on
- @param main_machine the machine associated to the main node
- **)
- let pp_project_configuration_name fmt basename =
- fprintf fmt "%s.adc" basename
-
- (** Print the project configuration file.
- @param fmt the formater to print on
- **)
- let pp_project_configuration_file fmt =
- fprintf fmt "pragma SPARK_Mode (On);"
-
- (** Print the name of the ada project file.
- @param base_name name of the lustre file
- @param fmt the formater to print on
- **)
- let pp_project_name basename fmt =
- fprintf fmt "%s.gpr" basename
-
- let pp_for_single name arg fmt =
- fprintf fmt "for %s use \"%s\"" name arg
+ (pp_procedure pp_main_procedure_name [] None)
+ (AdaProcedureContent (locals, instrs))
+
+ (** Print the name of the ada project configuration file. @param fmt the
+ formater to print on @param main_machine the machine associated to the
+ main node **)
+ let pp_project_configuration_name fmt basename = fprintf fmt "%s.adc" basename
+
+ (** Print the project configuration file. @param fmt the formater to print on
+ **)
+ let pp_project_configuration_file fmt = fprintf fmt "pragma SPARK_Mode (On);"
+
+ (** Print the name of the ada project file. @param base_name name of the
+ lustre file @param fmt the formater to print on **)
+ let pp_project_name basename fmt = fprintf fmt "%s.gpr" basename
+
+ let pp_for_single name arg fmt = fprintf fmt "for %s use \"%s\"" name arg
let pp_for name args fmt =
fprintf fmt "for %s use (@[%a@])" name
@@ -123,49 +160,62 @@ struct
let pp_content fmt lines =
fprintf fmt " @[<v>%a%t@]"
- (Utils.fprintf_list ~sep:";@," (fun fmt pp -> fprintf fmt "%t" pp)) lines
+ (Utils.fprintf_list ~sep:";@," (fun fmt pp -> fprintf fmt "%t" pp))
+ lines
(Utils.pp_final_char_if_non_empty ";" lines)
let pp_package name lines fmt =
- fprintf fmt "package %s is@,%a@,end %s"
- name
- pp_content lines
- name
-
- (** Print the gpr project file, if there is a machine in machine_opt then
- an executable project is made else it is a library.
- @param fmt the formater to print on
- @param machine_opt the main machine option
- **)
+ fprintf fmt "package %s is@,%a@,end %s" name pp_content lines name
+
+ (** Print the gpr project file, if there is a machine in machine_opt then an
+ executable project is made else it is a library. @param fmt the formater
+ to print on @param machine_opt the main machine option **)
let pp_project_file machines basename fmt machine_opt =
- let adbs = (List.map (asprintf "%a" (pp_machine_filename "adb")) machines)
- @(match machine_opt with
- | None -> []
- | Some m -> [asprintf "%a" pp_main_filename m]) in
- let project_name = basename^(if machine_opt=None then "_lib" else "_exe") in
- fprintf fmt "%sproject %s is@,%a@,end %s;" (if machine_opt=None then "library " else "") project_name
- pp_content
- ((match machine_opt with
- | None -> [
- pp_for_single "Library_Name" basename;
- pp_for_single "Library_Dir" "lib";
- ]
- | Some _ -> [
- pp_for "Main" [asprintf "%t" pp_main_procedure_name];
- pp_for_single "Exec_Dir" "bin";
+ let adbs =
+ List.map (asprintf "%a" (pp_machine_filename "adb")) machines
+ @
+ match machine_opt with
+ | None ->
+ []
+ | Some m ->
+ [ asprintf "%a" pp_main_filename m ]
+ in
+ let project_name =
+ basename ^ if machine_opt = None then "_lib" else "_exe"
+ in
+ fprintf fmt "%sproject %s is@,%a@,end %s;"
+ (if machine_opt = None then "library " else "")
+ project_name pp_content
+ ((match machine_opt with
+ | None ->
+ [
+ pp_for_single "Library_Name" basename;
+ pp_for_single "Library_Dir" "lib";
+ ]
+ | Some _ ->
+ [
+ pp_for "Main" [ asprintf "%t" pp_main_procedure_name ];
+ pp_for_single "Exec_Dir" "bin";
+ ])
+ @ [
+ pp_for_single "Object_Dir" "obj";
+ pp_for "Source_Files" adbs;
+ pp_package "Builder"
+ [
+ pp_for_single "Global_Configuration_Pragmas"
+ (asprintf "%a" pp_project_configuration_name basename);
+ ];
+ pp_package "Prove"
+ [
+ pp_for "Switches"
+ [
+ "--mode=prove";
+ "--report=statistics";
+ "--proof=per_check";
+ "--warnings=continue";
+ ];
+ pp_for_single "Proof_Dir" (asprintf "proof");
+ ];
])
- @[
- pp_for_single "Object_Dir" "obj";
- pp_for "Source_Files" adbs;
- pp_package "Builder" [
- pp_for_single "Global_Configuration_Pragmas" (asprintf "%a" pp_project_configuration_name basename);
- ];
- pp_package "Prove" [
- pp_for "Switches" ["--mode=prove"; "--report=statistics"; "--proof=per_check"; "--warnings=continue"];
- pp_for_single "Proof_Dir" (asprintf "proof");
- ]
- ])
- project_name
-
-
- end
+ project_name
+end
diff --git a/src/backends/Ada/ada_printer.ml b/src/backends/Ada/ada_printer.ml
index c014f9e21dfb60a48801881f3c39feaee286c334..b6f40235e19ec36c6acdcf758032aaa506328eb7 100644
--- a/src/backends/Ada/ada_printer.ml
+++ b/src/backends/Ada/ada_printer.ml
@@ -3,216 +3,242 @@ open Format
(** Represent the possible mode for a type of a procedure parameter **)
type parameter_mode = AdaNoMode | AdaIn | AdaOut | AdaInOut
-type kind_def = AdaType | AdaProcedure | AdaFunction | AdaPackageDecl | AdaPackageBody
+type kind_def =
+ | AdaType
+ | AdaProcedure
+ | AdaFunction
+ | AdaPackageDecl
+ | AdaPackageBody
type visibility = AdaNoVisibility | AdaPrivate | AdaLimitedPrivate
type printer = Format.formatter -> unit
-type ada_with = (bool * bool * (printer list) * (printer list)) option
+type ada_with = (bool * bool * printer list * printer list) option
type ada_var_decl = parameter_mode * printer * printer * ada_with
type ada_local_decl =
| AdaLocalVar of ada_var_decl
- | AdaLocalPackage of (printer * printer * ((printer*printer) list))
+ | AdaLocalPackage of (printer * printer * (printer * printer) list)
type def_content =
| AdaNoContent
| AdaPackageContent of printer
| AdaSimpleContent of printer
| AdaVisibilityDefinition of visibility
- | AdaProcedureContent of ((ada_local_decl list list) * (printer list))
- | AdaRecord of ((ada_var_decl list) list)
+ | AdaProcedureContent of (ada_local_decl list list * printer list)
+ | AdaRecord of ada_var_decl list list
| AdaPackageInstanciation of (printer * (printer * printer) list)
-(** Print a parameter_mode.
- @param fmt the formater to print on
- @param mode the modifier
-**)
+(** Print a parameter_mode. @param fmt the formater to print on @param mode the
+ modifier **)
let pp_parameter_mode fmt mode =
- fprintf fmt "%s" (match mode with
- | AdaNoMode -> ""
- | AdaIn -> "in"
- | AdaOut -> "out"
- | AdaInOut -> "in out")
+ fprintf fmt "%s"
+ (match mode with
+ | AdaNoMode ->
+ ""
+ | AdaIn ->
+ "in"
+ | AdaOut ->
+ "out"
+ | AdaInOut ->
+ "in out")
let pp_kind_def fmt kind_def =
- fprintf fmt "%s" (match kind_def with
- | AdaType -> "type"
- | AdaProcedure -> "procedure"
- | AdaFunction -> "function"
- | AdaPackageDecl -> "package"
- | AdaPackageBody -> "package body")
+ fprintf fmt "%s"
+ (match kind_def with
+ | AdaType ->
+ "type"
+ | AdaProcedure ->
+ "procedure"
+ | AdaFunction ->
+ "function"
+ | AdaPackageDecl ->
+ "package"
+ | AdaPackageBody ->
+ "package body")
let pp_visibility fmt visibility =
- fprintf fmt "%s" (match visibility with
- | AdaNoVisibility -> ""
- | AdaPrivate -> "private"
- | AdaLimitedPrivate -> "limited private")
-
-(** Print the integer type name.
- @param fmt the formater to print on
-**)
+ fprintf fmt "%s"
+ (match visibility with
+ | AdaNoVisibility ->
+ ""
+ | AdaPrivate ->
+ "private"
+ | AdaLimitedPrivate ->
+ "limited private")
+
+(** Print the integer type name. @param fmt the formater to print on **)
let pp_integer_type fmt = fprintf fmt "Integer"
-(** Print the float type name.
- @param fmt the formater to print on
-**)
+(** Print the float type name. @param fmt the formater to print on **)
let pp_float_type fmt = fprintf fmt "Float"
-(** Print the boolean type name.
- @param fmt the formater to print on
-**)
+(** Print the boolean type name. @param fmt the formater to print on **)
let pp_boolean_type fmt = fprintf fmt "Boolean"
-let pp_group ~sep:sep pp_list fmt =
- assert(pp_list != []);
- fprintf fmt "@[%a@]"
- (Utils.fprintf_list ~sep:sep (fun fmt pp->pp fmt)) pp_list
+let pp_group ~sep pp_list fmt =
+ assert (pp_list != []);
+ fprintf fmt "@[%a@]" (Utils.fprintf_list ~sep (fun fmt pp -> pp fmt)) pp_list
-let pp_args ~sep:sep fmt = function
- | [] -> fprintf fmt ""
- | args -> fprintf fmt " (@[<v>%a)@]" (Utils.fprintf_list ~sep:sep (fun fmt pp->pp fmt)) args
+let pp_args ~sep fmt = function
+ | [] ->
+ fprintf fmt ""
+ | args ->
+ fprintf fmt " (@[<v>%a)@]"
+ (Utils.fprintf_list ~sep (fun fmt pp -> pp fmt))
+ args
let pp_block fmt pp_item_list =
fprintf fmt "%t@[<v>%a@]%t"
(Utils.pp_final_char_if_non_empty " " pp_item_list)
- (Utils.fprintf_list ~sep:";@," (fun fmt pp -> pp fmt)) pp_item_list
+ (Utils.fprintf_list ~sep:";@," (fun fmt pp -> pp fmt))
+ pp_item_list
(Utils.pp_final_char_if_non_empty ";@," pp_item_list)
let pp_and l fmt = fprintf fmt "(%t)" (pp_group ~sep:"@ and then " l)
+
let pp_or l fmt = fprintf fmt "(%t)" (pp_group ~sep:"@ or " l)
let pp_ada_with fmt = function
- | None -> fprintf fmt ""
+ | None ->
+ fprintf fmt ""
| Some (ghost, import, pres, posts) ->
- assert(ghost || import || (pres != []) || (posts != []));
- let contract = pres@posts in
- let pp_ghost fmt = if not ghost then fprintf fmt "" else
- fprintf fmt " Ghost%t" (fun fmt -> if (contract != []) || import then fprintf fmt ",@," else fprintf fmt "")
- in
- let pp_import fmt = if not import then fprintf fmt "" else
- fprintf fmt " Import%t" (Utils.pp_final_char_if_non_empty ",@," contract)
- in
- let pp_aspect aspect fmt pps = if pps = [] then fprintf fmt "" else
- fprintf fmt "%s => %t" aspect (pp_and pps)
- in
- let pp_contract fmt = if contract = [] then fprintf fmt "" else
- let sep fmt = if pres != [] && posts != [] then fprintf fmt ",@," else fprintf fmt "" in
- fprintf fmt "@, @[<v>%a%t%a@]"
- (pp_aspect "Pre") pres
- sep
+ assert (ghost || import || pres != [] || posts != []);
+ let contract = pres @ posts in
+ let pp_ghost fmt =
+ if not ghost then fprintf fmt ""
+ else
+ fprintf fmt " Ghost%t" (fun fmt ->
+ if contract != [] || import then fprintf fmt ",@,"
+ else fprintf fmt "")
+ in
+ let pp_import fmt =
+ if not import then fprintf fmt ""
+ else
+ fprintf fmt " Import%t"
+ (Utils.pp_final_char_if_non_empty ",@," contract)
+ in
+ let pp_aspect aspect fmt pps =
+ if pps = [] then fprintf fmt ""
+ else fprintf fmt "%s => %t" aspect (pp_and pps)
+ in
+ let pp_contract fmt =
+ if contract = [] then fprintf fmt ""
+ else
+ let sep fmt =
+ if pres != [] && posts != [] then fprintf fmt ",@,"
+ else fprintf fmt ""
+ in
+ fprintf fmt "@, @[<v>%a%t%a@]" (pp_aspect "Pre") pres sep
(pp_aspect "Post") posts
- in
- fprintf fmt " with%t%t%t"
- pp_ghost
- pp_import
- pp_contract
-
-(** Print instanciation of a generic type in a new statement.
- @param fmt the formater to print on
- @param id id of the polymorphic type
- @param typ the new type
-**)
+ in
+ fprintf fmt " with%t%t%t" pp_ghost pp_import pp_contract
+
+(** Print instanciation of a generic type in a new statement. @param fmt the
+ formater to print on @param id id of the polymorphic type @param typ the new
+ type **)
let pp_generic_instanciation (pp_name, pp_type) fmt =
fprintf fmt "%t => %t" pp_name pp_type
-(** Print a variable declaration with mode
- @param mode input/output mode of the parameter
- @param pp_name a format printer wich print the variable name
- @param pp_type a format printer wich print the variable type
- @param fmt the formater to print on
- @param id the variable
-**)
+(** Print a variable declaration with mode @param mode input/output mode of the
+ parameter @param pp_name a format printer wich print the variable name
+ @param pp_type a format printer wich print the variable type @param fmt the
+ formater to print on @param id the variable **)
let pp_var_decl (mode, pp_name, pp_type, with_statement) fmt =
- fprintf fmt "%t: %a%s%t%a"
- pp_name
- pp_parameter_mode mode
+ fprintf fmt "%t: %a%s%t%a" pp_name pp_parameter_mode mode
(if mode = AdaNoMode then "" else " ")
- pp_type
- pp_ada_with with_statement
+ pp_type pp_ada_with with_statement
let apply_var_decl_lists var_list =
- List.map (fun l-> List.map pp_var_decl l) var_list
+ List.map (fun l -> List.map pp_var_decl l) var_list
let pp_generic fmt = function
- | [] -> fprintf fmt ""
- | l -> fprintf fmt "generic@,%a" pp_block l
+ | [] ->
+ fprintf fmt ""
+ | l ->
+ fprintf fmt "generic@,%a" pp_block l
let pp_opt intro fmt = function
- | None -> fprintf fmt ""
- | Some pp -> fprintf fmt " %s %t" intro pp
+ | None ->
+ fprintf fmt ""
+ | Some pp ->
+ fprintf fmt " %s %t" intro pp
let rec pp_local local fmt =
match local with
- | AdaLocalVar var -> pp_var_decl var fmt
- | AdaLocalPackage (pp_name, pp_base_name, instanciations) ->
- pp_package_instanciation pp_name pp_base_name fmt instanciations
+ | AdaLocalVar var ->
+ pp_var_decl var fmt
+ | AdaLocalPackage (pp_name, pp_base_name, instanciations) ->
+ pp_package_instanciation pp_name pp_base_name fmt instanciations
+
and pp_content pp_name fmt = function
| AdaNoContent ->
- fprintf fmt ""
+ fprintf fmt ""
| AdaVisibilityDefinition visbility ->
- fprintf fmt " is %a" pp_visibility visbility
+ fprintf fmt " is %a" pp_visibility visbility
| AdaPackageContent pp_package ->
- fprintf fmt " is@, @[<v>%t;@]@,end %t" pp_package pp_name
+ fprintf fmt " is@, @[<v>%t;@]@,end %t" pp_package pp_name
| AdaSimpleContent pp_content ->
- fprintf fmt " is@, @[<v 2>(%t)@]" pp_content
+ fprintf fmt " is@, @[<v 2>(%t)@]" pp_content
| AdaProcedureContent (local_list, pp_instr_list) ->
- fprintf fmt " is@,%abegin@,%aend %t"
- pp_block (List.map (fun l -> pp_group ~sep:";@;" (List.map pp_local l)) local_list)
- pp_block pp_instr_list
- pp_name
+ fprintf fmt " is@,%abegin@,%aend %t" pp_block
+ (List.map (fun l -> pp_group ~sep:";@;" (List.map pp_local l)) local_list)
+ pp_block pp_instr_list pp_name
| AdaRecord var_list ->
- assert(var_list != []);
- let pp_lists = apply_var_decl_lists var_list in
- fprintf fmt " is@, @[<v>record@, @[<v>%a@]@,end record@]"
- pp_block (List.map (pp_group ~sep:";@;") pp_lists)
+ assert (var_list != []);
+ let pp_lists = apply_var_decl_lists var_list in
+ fprintf fmt " is@, @[<v>record@, @[<v>%a@]@,end record@]" pp_block
+ (List.map (pp_group ~sep:";@;") pp_lists)
| AdaPackageInstanciation (pp_name, instanciations) ->
- fprintf fmt " is new %t%a"
- pp_name
- (pp_args ~sep:",@,") (List.map pp_generic_instanciation instanciations)
-and pp_def fmt (pp_generics, kind_def, pp_name, args, pp_type_opt, content, pp_with_opt) =
+ fprintf fmt " is new %t%a" pp_name (pp_args ~sep:",@,")
+ (List.map pp_generic_instanciation instanciations)
+
+and pp_def fmt
+ (pp_generics, kind_def, pp_name, args, pp_type_opt, content, pp_with_opt) =
let pp_arg_lists = apply_var_decl_lists args in
- fprintf fmt "%a%a %t%a%a%a%a"
- pp_generic pp_generics
- pp_kind_def kind_def
- pp_name
- (pp_args ~sep:";@,") (List.map (pp_group ~sep:";@,") pp_arg_lists)
- (pp_opt "return") pp_type_opt
- (pp_content pp_name) content
- pp_ada_with pp_with_opt
+ fprintf fmt "%a%a %t%a%a%a%a" pp_generic pp_generics pp_kind_def kind_def
+ pp_name (pp_args ~sep:";@,")
+ (List.map (pp_group ~sep:";@,") pp_arg_lists)
+ (pp_opt "return") pp_type_opt (pp_content pp_name) content pp_ada_with
+ pp_with_opt
+
and pp_package_instanciation pp_name pp_base_name fmt instanciations =
- pp_def fmt ([], AdaPackageDecl, pp_name, [], None, (AdaPackageInstanciation (pp_base_name, instanciations)), None)
+ pp_def fmt
+ ( [],
+ AdaPackageDecl,
+ pp_name,
+ [],
+ None,
+ AdaPackageInstanciation (pp_base_name, instanciations),
+ None )
-let pp_adastring pp_content fmt =
- fprintf fmt "\"%t\"" pp_content
+let pp_adastring pp_content fmt = fprintf fmt "\"%t\"" pp_content
(** Print the ada package introduction sentence it can be used for body and
-declaration. Boolean parameter body should be true if it is a body delcaration.
- @param fmt the formater to print on
- @param fmt the formater to print on
- @param machine the machine
-**)
+ declaration. Boolean parameter body should be true if it is a body
+ delcaration. @param fmt the formater to print on @param fmt the formater to
+ print on @param machine the machine **)
let pp_package pp_name pp_generics body fmt pp_content =
let kind = if body then AdaPackageBody else AdaPackageDecl in
- pp_def fmt (pp_generics, kind, pp_name, [], None, (AdaPackageContent pp_content), None)
-
-(** Print a new statement instantiating a generic package.
- @param fmt the formater to print on
- @param substitutions the instanciation substitution
- @param machine the machine to instanciate
-**)
-
-(** Print a type declaration
- @param fmt the formater to print on
- @param pp_name a format printer which print the type name
- @param pp_value a format printer which print the type definition
-**)
+ pp_def fmt
+ (pp_generics, kind, pp_name, [], None, AdaPackageContent pp_content, None)
+
+(** Print a new statement instantiating a generic package. @param fmt the
+ formater to print on @param substitutions the instanciation substitution
+ @param machine the machine to instanciate **)
+
+(** Print a type declaration @param fmt the formater to print on @param pp_name
+ a format printer which print the type name @param pp_value a format printer
+ which print the type definition **)
let pp_type_decl pp_name visibility fmt =
- let v = match visibility with
- | AdaNoVisibility -> AdaNoContent
- | _ -> AdaVisibilityDefinition visibility
+ let v =
+ match visibility with
+ | AdaNoVisibility ->
+ AdaNoContent
+ | _ ->
+ AdaVisibilityDefinition visibility
in
pp_def fmt ([], AdaType, pp_name, [], None, v, None)
@@ -223,54 +249,130 @@ let pp_procedure pp_name args pp_with_opt fmt content =
pp_def fmt ([], AdaProcedure, pp_name, args, None, content, pp_with_opt)
let pp_predicate pp_name args imported fmt content_opt =
- let content, with_st = match content_opt with
- | Some content -> AdaSimpleContent content, None
- | None -> AdaNoContent, Some (true, imported, [], [])
+ let content, with_st =
+ match content_opt with
+ | Some content ->
+ AdaSimpleContent content, None
+ | None ->
+ AdaNoContent, Some (true, imported, [], [])
in
- pp_def fmt ([], AdaFunction, pp_name, args, Some pp_boolean_type, content, with_st)
+ pp_def fmt
+ ([], AdaFunction, pp_name, args, Some pp_boolean_type, content, with_st)
-(** Print a cleaned an identifier for ada exportation : Ada names must not start by an
- underscore and must not contain a double underscore
- @param var name to be cleaned*)
+(** Print a cleaned an identifier for ada exportation : Ada names must not start
+ by an underscore and must not contain a double underscore @param var name to
+ be cleaned*)
let pp_clean_ada_identifier fmt name =
- let reserved_words = ["abort"; "else"; "new"; "return"; "boolean"; "integer";
- "abs"; "elsif"; "not"; "reverse"; "abstract"; "end";
- "null"; "accept"; "entry"; "select"; "access";
- "exception"; "of"; "separate"; "aliased"; "exit";
- "or"; "some"; "all"; "others"; "subtype"; "and";
- "for"; "out"; "synchronized"; "array"; "function";
- "overriding"; "at"; "tagged"; "generic"; "package";
- "task"; "begin"; "goto"; "pragma"; "terminate";
- "body"; "private"; "then"; "if"; "procedure"; "type";
- "case"; "in"; "protected"; "constant"; "interface";
- "until"; "is"; "raise"; "use"; "declare"; " range";
- "delay"; "limited"; "record"; "when"; "delta"; "loop";
- "rem"; "while"; "digits"; "renames"; "with"; "do";
- "mod"; "requeue"; "xor"; "float"] in
+ let reserved_words =
+ [
+ "abort";
+ "else";
+ "new";
+ "return";
+ "boolean";
+ "integer";
+ "abs";
+ "elsif";
+ "not";
+ "reverse";
+ "abstract";
+ "end";
+ "null";
+ "accept";
+ "entry";
+ "select";
+ "access";
+ "exception";
+ "of";
+ "separate";
+ "aliased";
+ "exit";
+ "or";
+ "some";
+ "all";
+ "others";
+ "subtype";
+ "and";
+ "for";
+ "out";
+ "synchronized";
+ "array";
+ "function";
+ "overriding";
+ "at";
+ "tagged";
+ "generic";
+ "package";
+ "task";
+ "begin";
+ "goto";
+ "pragma";
+ "terminate";
+ "body";
+ "private";
+ "then";
+ "if";
+ "procedure";
+ "type";
+ "case";
+ "in";
+ "protected";
+ "constant";
+ "interface";
+ "until";
+ "is";
+ "raise";
+ "use";
+ "declare";
+ "\trange";
+ "delay";
+ "limited";
+ "record";
+ "when";
+ "delta";
+ "loop";
+ "rem";
+ "while";
+ "digits";
+ "renames";
+ "with";
+ "do";
+ "mod";
+ "requeue";
+ "xor";
+ "float";
+ ]
+ in
let base_size = String.length name in
- assert(base_size > 0);
+ assert (base_size > 0);
let rec remove_double_underscore s = function
- | i when i == String.length s - 1 -> s
- | i when String.get s i == '_' && String.get s (i+1) == '_' ->
- remove_double_underscore (sprintf "%s%s" (String.sub s 0 i) (String.sub s (i+1) (String.length s-i-1))) i
- | i -> remove_double_underscore s (i+1)
+ | i when i == String.length s - 1 ->
+ s
+ | i when String.get s i == '_' && String.get s (i + 1) == '_' ->
+ remove_double_underscore
+ (sprintf "%s%s" (String.sub s 0 i)
+ (String.sub s (i + 1) (String.length s - i - 1)))
+ i
+ | i ->
+ remove_double_underscore s (i + 1)
+ in
+ let name =
+ if String.get name (base_size - 1) == '_' then name ^ "ada" else name
in
- let name = if String.get name (base_size-1) == '_' then name^"ada" else name in
let name = remove_double_underscore name 0 in
- let prefix = if String.length name != base_size
- || String.get name 0 == '_'
- || List.exists (String.equal (String.lowercase_ascii name)) reserved_words then
- "ada"
- else
- ""
+ let prefix =
+ if
+ String.length name != base_size
+ || String.get name 0 == '_'
+ || List.exists (String.equal (String.lowercase_ascii name)) reserved_words
+ then "ada"
+ else ""
in
fprintf fmt "%s%s" prefix name
-(** Print the access of an item from an other package.
- @param fmt the formater to print on
- @param package the package to use
- @param item the item which is accessed
-**)
+(** Print the access of an item from an other package. @param fmt the formater
+ to print on @param package the package to use @param item the item which is
+ accessed **)
let pp_package_access (pp_package, pp_item) fmt =
fprintf fmt "%t.%t" pp_package pp_item
@@ -278,27 +380,18 @@ let pp_with visibility fmt pp_pakage_name =
fprintf fmt "%a with %t" pp_visibility visibility pp_pakage_name
(** Print a one line comment with the final new line character to avoid
- commenting anything else.
- @param fmt the formater to print on
- @param s the comment without newline character
-**)
+ commenting anything else. @param fmt the formater to print on @param s the
+ comment without newline character **)
let pp_oneline_comment fmt s =
assert (not (String.contains s '\n'));
fprintf fmt "-- %s@," s
let pp_call fmt (pp_name, args) =
- fprintf fmt "%t%a"
- pp_name
- (pp_args ~sep:",@ ") (List.map (pp_group ~sep:",@,") args)
+ fprintf fmt "%t%a" pp_name (pp_args ~sep:",@ ")
+ (List.map (pp_group ~sep:",@,") args)
-
-(** Print the complete name of variable.
- @param m the machine to check if it is memory
- @param fmt the formater to print on
- @param var the variable
-**)
-let pp_access pp_state pp_var fmt =
- fprintf fmt "%t.%t" pp_state pp_var
+(** Print the complete name of variable. @param m the machine to check if it is
+ memory @param fmt the formater to print on @param var the variable **)
+let pp_access pp_state pp_var fmt = fprintf fmt "%t.%t" pp_state pp_var
let pp_old pp fmt = fprintf fmt "%t'Old" pp
-
diff --git a/src/backends/Ada/ada_printer.mli b/src/backends/Ada/ada_printer.mli
index 7f570568be113e4506d49073fcc0f0b1656318b7..54edca86a1847e01818d4534360fb2924994cf6e 100644
--- a/src/backends/Ada/ada_printer.mli
+++ b/src/backends/Ada/ada_printer.mli
@@ -3,58 +3,92 @@ open Misc_printer
type parameter_mode = AdaNoMode | AdaIn | AdaOut | AdaInOut
-type kind_def = AdaType | AdaProcedure | AdaFunction | AdaPackageDecl | AdaPackageBody
+type kind_def =
+ | AdaType
+ | AdaProcedure
+ | AdaFunction
+ | AdaPackageDecl
+ | AdaPackageBody
type visibility = AdaNoVisibility | AdaPrivate | AdaLimitedPrivate
-type ada_with = (bool * bool * (printer list) * (printer list)) option
+type ada_with = (bool * bool * printer list * printer list) option
type ada_var_decl = parameter_mode * printer * printer * ada_with
type ada_local_decl =
| AdaLocalVar of ada_var_decl
- | AdaLocalPackage of (printer * printer * ((printer*printer) list))
+ | AdaLocalPackage of (printer * printer * (printer * printer) list)
type def_content =
| AdaNoContent
| AdaPackageContent of printer
| AdaSimpleContent of printer
| AdaVisibilityDefinition of visibility
- | AdaProcedureContent of ((ada_local_decl list list) * (printer list))
- | AdaRecord of (ada_var_decl list list)
- | AdaPackageInstanciation of (printer * ((printer*printer) list))
+ | AdaProcedureContent of (ada_local_decl list list * printer list)
+ | AdaRecord of ada_var_decl list list
+ | AdaPackageInstanciation of (printer * (printer * printer) list)
val pp_integer_type : printer
+
val pp_float_type : printer
+
val pp_boolean_type : printer
val pp_clean_ada_identifier : formatter -> string -> unit
-val pp_package_access : (printer*printer) -> printer
+
+val pp_package_access : printer * printer -> printer
+
val pp_block : formatter -> printer list -> unit
+
val pp_oneline_comment : formatter -> string -> unit
+
val pp_with : visibility -> formatter -> printer -> unit
+
val pp_var_decl : ada_var_decl -> printer
-val pp_access : printer -> printer -> formatter -> unit
-val pp_call : formatter -> (printer*(printer list list)) -> unit
+
+val pp_access : printer -> printer -> formatter -> unit
+
+val pp_call : formatter -> printer * printer list list -> unit
+
val pp_old : printer -> printer
+
val pp_adastring : printer -> printer
-val pp_or : (printer list) -> printer
-val pp_and : (printer list) -> printer
+val pp_or : printer list -> printer
+
+val pp_and : printer list -> printer
(* declaration printer *)
val pp_package : printer -> printer list -> bool -> formatter -> printer -> unit
-val pp_package_instanciation : printer -> printer -> formatter -> (printer*printer) list -> unit
+
+val pp_package_instanciation :
+ printer -> printer -> formatter -> (printer * printer) list -> unit
+
val pp_type_decl : printer -> visibility -> printer
+
val pp_record : printer -> formatter -> ada_var_decl list list -> unit
-val pp_procedure : printer -> (ada_var_decl list list) -> ada_with -> formatter -> def_content -> unit
-val pp_predicate : printer -> (ada_var_decl list list) -> bool -> formatter -> (printer option) -> unit
+
+val pp_procedure :
+ printer ->
+ ada_var_decl list list ->
+ ada_with ->
+ formatter ->
+ def_content ->
+ unit
+
+val pp_predicate :
+ printer ->
+ ada_var_decl list list ->
+ bool ->
+ formatter ->
+ printer option ->
+ unit
(* Local function :
-val pp_parameter_mode : formatter -> parameter_mode -> unit
-val pp_kind_def : formatter -> kind_def -> unit
-val pp_visibility : formatter -> visibility -> unit
-val pp_var_decl_lists : formatter -> ada_var_decl list list -> unit
-val pp_def_args : formatter -> ada_var_decl list list -> unit
-val pp_def : formatter -> (kind_def*printer*(ada_var_decl list list)*(printer option)*def_content*(printer option)) -> unit
-*)
+ val pp_parameter_mode : formatter -> parameter_mode -> unit val pp_kind_def :
+ formatter -> kind_def -> unit val pp_visibility : formatter -> visibility ->
+ unit val pp_var_decl_lists : formatter -> ada_var_decl list list -> unit val
+ pp_def_args : formatter -> ada_var_decl list list -> unit val pp_def :
+ formatter -> (kind_def*printer*(ada_var_decl list list)*(printer
+ option)*def_content*(printer option)) -> unit *)
diff --git a/src/backends/Ada/misc_lustre_function.ml b/src/backends/Ada/misc_lustre_function.ml
index 45ebcd91a4df4b0b37f59ade403d8ec8c56c249e..1647ba775819ed93e1d86aca8d0c7ae29f829f3c 100644
--- a/src/backends/Ada/misc_lustre_function.ml
+++ b/src/backends/Ada/misc_lustre_function.ml
@@ -1,313 +1,300 @@
-
open Machine_code_types
open Lustre_types
open Corelang
-(*
-open Machine_code_common
-*)
+(* open Machine_code_common *)
let is_machine_statefull m = not m.mname.node_dec_stateless
-(** Return true if its the arrow machine
- @param machine the machine to test
-*)
+(** Return true if its the arrow machine @param machine the machine to test *)
let is_arrow machine = String.equal Arrow.arrow_id machine.mname.node_id
-(** Extract a node from an instance.
- @param instance the instance
-**)
+(** Extract a node from an instance. @param instance the instance **)
let extract_node instance =
- let (_, (node, _)) = instance in
- match node.top_decl_desc with
- | Node nd -> nd
- | _ -> assert false (*TODO*)
+ let _, (node, _) = instance in
+ match node.top_decl_desc with Node nd -> nd | _ -> assert false
+(*TODO*)
(** Extract from a machine list the one corresponding to the given instance.
- assume that the machine is in the list.
- @param machines list of all machines
- @param instance instance of a machine
- @return the machine corresponding to hte given instance
-**)
+ assume that the machine is in the list. @param machines list of all machines
+ @param instance instance of a machine @return the machine corresponding to
+ hte given instance **)
let get_machine machines instance =
- let id = (extract_node instance).node_id in
- try
- List.find (function m -> m.mname.node_id=id) machines
- with
- Not_found -> assert false (*TODO*)
+ let id = (extract_node instance).node_id in
+ try List.find (function m -> m.mname.node_id = id) machines
+ with Not_found -> assert false
+(*TODO*)
-(** Extract all the inputs and outputs.
- @param machine the machine
- @return a list of all the var_decl of a macine
-**)
+(** Extract all the inputs and outputs. @param machine the machine @return a
+ list of all the var_decl of a macine **)
let get_all_vars_machine m =
- m.mmemory@m.mstep.step_inputs@m.mstep.step_outputs@m.mstatic
+ m.mmemory @ m.mstep.step_inputs @ m.mstep.step_outputs @ m.mstatic
-(** Check if a type is polymorphic.
- @param typ the type
- @return true if its polymorphic
-**)
+(** Check if a type is polymorphic. @param typ the type @return true if its
+ polymorphic **)
let is_Tunivar typ = (Types.repr typ).tdesc == Types.Tunivar
-(** Find all polymorphic type : Types.Tunivar in a machine.
- @param machine the machine
- @return a list of id corresponding to polymorphic type
-**)
+(** Find all polymorphic type : Types.Tunivar in a machine. @param machine the
+ machine @return a list of id corresponding to polymorphic type **)
let find_all_polymorphic_type m =
let vars = get_all_vars_machine m in
let extract id = id.var_type.tid in
let polymorphic_type_vars =
- List.filter (function x-> is_Tunivar x.var_type) vars in
- List.sort_uniq (-) (List.map extract polymorphic_type_vars)
-
+ List.filter (function x -> is_Tunivar x.var_type) vars
+ in
+ List.sort_uniq ( - ) (List.map extract polymorphic_type_vars)
-(** Check if a submachine is statefull.
- @param submachine a submachine
- @return true if the submachine is statefull
-**)
+(** Check if a submachine is statefull. @param submachine a submachine @return
+ true if the submachine is statefull **)
let is_submachine_statefull submachine =
- not (snd (snd submachine)).mname.node_dec_stateless
+ not (snd (snd submachine)).mname.node_dec_stateless
-(** Find a submachine step call in a list of instructions.
- @param ident submachine instance ident
- @param instr_list List of instruction sto search
- @return a list of pair containing input types and output types for each step call found
-**)
+(** Find a submachine step call in a list of instructions. @param ident
+ submachine instance ident @param instr_list List of instruction sto search
+ @return a list of pair containing input types and output types for each step
+ call found **)
let rec find_submachine_step_call ident instr_list =
- let search_instr instruction =
+ let search_instr instruction =
match instruction.instr_desc with
- | MStep (il, i, vl) when String.equal i ident -> [
- (List.map (function x-> x.value_type) vl,
- List.map (function x-> x.var_type) il)]
- | MBranch (_, l) -> List.flatten
- (List.map (function _, y -> find_submachine_step_call ident y) l)
- | _ -> []
+ | MStep (il, i, vl) when String.equal i ident ->
+ [
+ ( List.map (function x -> x.value_type) vl,
+ List.map (function x -> x.var_type) il );
+ ]
+ | MBranch (_, l) ->
+ List.flatten
+ (List.map (function _, y -> find_submachine_step_call ident y) l)
+ | _ ->
+ []
in
List.flatten (List.map search_instr instr_list)
(* Replace this function by check_type_equal but be careful to the fact that
- this function chck equality and that it is both basic type.
- This might be a required feature when it used *)
-(** Test if two types are the same.
- @param typ1 the first type
- @param typ2 the second type
-**)
-let pp_eq_type typ1 typ2 =
- let get_basic typ = match (Types.repr typ).Types.tdesc with
- | Types.Tbasic Types.Basic.Tint -> Types.Basic.Tint
- | Types.Tbasic Types.Basic.Treal -> Types.Basic.Treal
- | Types.Tbasic Types.Basic.Tbool -> Types.Basic.Tbool
- | _ -> assert false (*TODO*)
+ this function chck equality and that it is both basic type. This might be a
+ required feature when it used *)
+
+(** Test if two types are the same. @param typ1 the first type @param typ2 the
+ second type **)
+let pp_eq_type typ1 typ2 =
+ let get_basic typ =
+ match (Types.repr typ).Types.tdesc with
+ | Types.Tbasic Types.Basic.Tint ->
+ Types.Basic.Tint
+ | Types.Tbasic Types.Basic.Treal ->
+ Types.Basic.Treal
+ | Types.Tbasic Types.Basic.Tbool ->
+ Types.Basic.Tbool
+ | _ ->
+ assert false
+ (*TODO*)
in
get_basic typ1 = get_basic typ2
-(** Check that two types are the same.
- @param t1 a type
- @param t2 an other type
- @param return true if the two types are Tbasic or Tunivar and equal
-**)
-let rec check_type_equal (t1:Types.type_expr) (t2:Types.type_expr) =
+(** Check that two types are the same. @param t1 a type @param t2 an other type
+ @param return true if the two types are Tbasic or Tunivar and equal **)
+let rec check_type_equal (t1 : Types.type_expr) (t2 : Types.type_expr) =
match (Types.repr t1).Types.tdesc, (Types.repr t2).Types.tdesc with
- | Types.Tbasic x, Types.Tbasic y -> x = y
- | Types.Tunivar, Types.Tunivar -> t1.tid = t2.tid
- | Types.Ttuple l, _ -> assert (List.length l = 1); check_type_equal (List.hd l) t2
- | _, Types.Ttuple l -> assert (List.length l = 1); check_type_equal t1 (List.hd l)
- | Types.Tstatic (_, t), _ -> check_type_equal t t2
- | _, Types.Tstatic (_, t) -> check_type_equal t1 t
- | _ -> assert false
+ | Types.Tbasic x, Types.Tbasic y ->
+ x = y
+ | Types.Tunivar, Types.Tunivar ->
+ t1.tid = t2.tid
+ | Types.Ttuple l, _ ->
+ assert (List.length l = 1);
+ check_type_equal (List.hd l) t2
+ | _, Types.Ttuple l ->
+ assert (List.length l = 1);
+ check_type_equal t1 (List.hd l)
+ | Types.Tstatic (_, t), _ ->
+ check_type_equal t t2
+ | _, Types.Tstatic (_, t) ->
+ check_type_equal t1 t
+ | _ ->
+ assert false
-(** Extend a substitution to unify the two given types. Only the
- first type can be polymorphic.
- @param subsitution the base substitution
- @param type_poly the type which can be polymorphic
- @param typ the type to match type_poly with
-**)
-let unification (substituion:(int*Types.type_expr) list) ((type_poly:Types.type_expr), (typ:Types.type_expr)) =
- assert(not (is_Tunivar typ));
+(** Extend a substitution to unify the two given types. Only the first type can
+ be polymorphic. @param subsitution the base substitution @param type_poly
+ the type which can be polymorphic @param typ the type to match type_poly
+ with **)
+let unification (substituion : (int * Types.type_expr) list)
+ ((type_poly : Types.type_expr), (typ : Types.type_expr)) =
+ assert (not (is_Tunivar typ));
(* If type_poly is polymorphic *)
if is_Tunivar type_poly then
(* If a subsitution exists for it *)
- if List.mem_assoc type_poly.tid substituion then
- begin
+ if List.mem_assoc type_poly.tid substituion then (
(* We check that the type corresponding to type_poly in the subsitution
match typ *)
- (try
- assert(check_type_equal (List.assoc type_poly.tid substituion) typ)
- with
- Not_found -> assert false);
+ (try assert (check_type_equal (List.assoc type_poly.tid substituion) typ)
+ with Not_found -> assert false);
(* We return the original substituion, it is already correct *)
substituion
- end
- (* If type_poly is not in the subsitution *)
- else
- (* We add it to the substituion *)
- (type_poly.tid, typ)::substituion
- (* iftype_poly is not polymorphic *)
- else
- begin
+ (* If type_poly is not in the subsitution *))
+ else (* We add it to the substituion *)
+ (type_poly.tid, typ) :: substituion (* iftype_poly is not polymorphic *)
+ else (
(* We check that type_poly and typ are the same *)
- assert(check_type_equal type_poly typ);
+ assert (check_type_equal type_poly typ);
(* We return the original substituion, it is already correct *)
- substituion
- end
+ substituion)
-(** Check that two calls are equal. A call is
- a pair of list of types, the inputs and the outputs.
- @param calls a list of pair of list of types
- @param return true if the two pairs are equal
-**)
+(** Check that two calls are equal. A call is a pair of list of types, the
+ inputs and the outputs. @param calls a list of pair of list of types @param
+ return true if the two pairs are equal **)
let check_call_equal (i1, _) (i2, _) =
- (List.for_all2 check_type_equal i1 i2)
- && (List.for_all2 check_type_equal i1 i2)
+ List.for_all2 check_type_equal i1 i2 && List.for_all2 check_type_equal i1 i2
-(** Check that all the elements of list of calls are equal to one.
- A call is a pair of list of types, the inputs and the outputs.
- @param call a pair of list of types
- @param calls a list of pair of list of types
- @param return true if all the elements are equal
-**)
-let check_calls call calls =
- List.for_all (check_call_equal call) calls
+(** Check that all the elements of list of calls are equal to one. A call is a
+ pair of list of types, the inputs and the outputs. @param call a pair of
+ list of types @param calls a list of pair of list of types @param return
+ true if all the elements are equal **)
+let check_calls call calls = List.for_all (check_call_equal call) calls
(** Extract from a subinstance that can have polymorphic type the instantiation
of all its polymorphic type instanciation for a given machine. It searches
- the step calls and extract a substitution for all polymorphic type from
- it.
- @param machine the machine which instantiate the subinstance
- @param ident the identifier of the instance which permits to find the step call
- @param submachine the machine corresponding to the subinstance
- @return the correspondance between polymorphic type id and their instantiation
-**)
+ the step calls and extract a substitution for all polymorphic type from it.
+ @param machine the machine which instantiate the subinstance @param ident
+ the identifier of the instance which permits to find the step call @param
+ submachine the machine corresponding to the subinstance @return the
+ correspondance between polymorphic type id and their instantiation **)
let get_substitution machine ident submachine =
(* extract the calls to submachines from the machine *)
let calls = find_submachine_step_call ident machine.mstep.step_instrs in
- (* extract the first call *)
- let call = match calls with
- (* assume that there is always one call to a subinstance *)
- | [] -> assert(false)
- | h::_ -> h in
+ (* extract the first call *)
+ let call =
+ match calls with
+ (* assume that there is always one call to a subinstance *)
+ | [] ->
+ assert false
+ | h :: _ ->
+ h
+ in
(* assume that all the calls to a subinstance are using the same type *)
- assert(check_calls call calls);
+ assert (check_calls call calls);
(* make a list of all types from input and output vars *)
- let call_types = (fst call)@(snd call) in
+ let call_types = fst call @ snd call in
(* extract all the input and output vars from the submachine *)
- let machine_vars = submachine.mstep.step_inputs@submachine.mstep.step_outputs in
+ let machine_vars =
+ submachine.mstep.step_inputs @ submachine.mstep.step_outputs
+ in
(* keep only the type of vars *)
- let machine_types = List.map (function x-> x.var_type) machine_vars in
+ let machine_types = List.map (function x -> x.var_type) machine_vars in
(* assume that there is the same numer of input and output in the submachine
- and the call *)
+ and the call *)
assert (List.length machine_types = List.length call_types);
(* Unify the two lists of types *)
- let substitution = List.fold_left unification [] (List.combine machine_types call_types) in
- (* Assume that our substitution match all the possible
- polymorphic type of the node *)
+ let substitution =
+ List.fold_left unification [] (List.combine machine_types call_types)
+ in
+ (* Assume that our substitution match all the possible polymorphic type of the
+ node *)
let polymorphic_types = find_all_polymorphic_type submachine in
assert (List.length polymorphic_types = List.length substitution);
(try
- assert (List.for_all (fun x -> List.mem_assoc x substitution) polymorphic_types)
- with
- Not_found -> assert false);
+ assert (
+ List.for_all (fun x -> List.mem_assoc x substitution) polymorphic_types)
+ with Not_found -> assert false);
substitution
+(** Extract from a machine the instance corresponding to the identifier, assume
+ that the identifier exists in the instances of the machine.
-(** Extract from a machine the instance corresponding to the identifier,
- assume that the identifier exists in the instances of the machine.
-
- @param identifier the instance identifier
- @param machine a machine
- @return the instance of machine.minstances corresponding to identifier
-**)
+ @param identifier the instance identifier @param machine a machine @return
+ the instance of machine.minstances corresponding to identifier **)
let get_instance identifier typed_submachines =
- try
- List.assoc identifier typed_submachines
- with Not_found -> assert false
+ try List.assoc identifier typed_submachines with Not_found -> assert false
(*Usefull for debug*)
-let pp_type_debug fmt typ =
- (match (Types.repr typ).Types.tdesc with
- | Types.Tbasic Types.Basic.Tint -> Format.fprintf fmt "INTEGER"
- | Types.Tbasic Types.Basic.Treal -> Format.fprintf fmt "FLOAT"
- | Types.Tbasic Types.Basic.Tbool -> Format.fprintf fmt "BOOLEAN"
- | Types.Tunivar -> Format.fprintf fmt "POLY(%i)" typ.Types.tid
- | _ -> assert false
- )
+let pp_type_debug fmt typ =
+ match (Types.repr typ).Types.tdesc with
+ | Types.Tbasic Types.Basic.Tint ->
+ Format.fprintf fmt "INTEGER"
+ | Types.Tbasic Types.Basic.Treal ->
+ Format.fprintf fmt "FLOAT"
+ | Types.Tbasic Types.Basic.Tbool ->
+ Format.fprintf fmt "BOOLEAN"
+ | Types.Tunivar ->
+ Format.fprintf fmt "POLY(%i)" typ.Types.tid
+ | _ ->
+ assert false
let build_if g c1 i1 tl =
- let neg = c1=tag_false in
- let other = match tl with
- | [] -> None
- | [(_, i2)] -> Some i2
- | _ -> assert false
+ let neg = c1 = tag_false in
+ let other =
+ match tl with [] -> None | [ (_, i2) ] -> Some i2 | _ -> assert false
in
match neg, other with
- | true, Some x -> (false, g, x, Some i1)
- | _ ->
- (neg, g, i1, other)
+ | true, Some x ->
+ false, g, x, Some i1
+ | _ ->
+ neg, g, i1, other
let rec push_if_in_expr = function
- | [] -> []
- | instr::q ->
- (
- match get_instr_desc instr with
- | MBranch (g, (c1, i1)::tl) when c1=tag_false || c1=tag_true ->
- let (_, g, instrs1, instrs2) = build_if g c1 i1 tl in
- let instrs1_pushed = push_if_in_expr instrs1 in
- let get_assign instr = match get_instr_desc instr with
- | MLocalAssign (id, value) -> (false, id, value)
- | MStateAssign (id, value) -> (true, id, value)
- | _ -> assert false
- in
- let gen_eq ident state value1 value2 =
- assert(check_type_equal ident.var_type value1.value_type);
- assert(check_type_equal ident.var_type value2.value_type);
- let value = {
- value_desc = Fun ("ite", [g;value1;value2]);
- value_type = ident.var_type;
- value_annot = None
- }
- in
- let assign = if state then MStateAssign (ident, value) else MLocalAssign (ident, value) in
- { instr_desc = assign;
- lustre_eq = None;
- instr_spec = []
- }
- in
- let mkval_var id = {
- value_desc = Var id;
- value_type = id.var_type;
- value_annot = None
- }
- in
- let rec find_split s1 id1 accu = function
- | [] -> [], accu, mkval_var id1
- | (s2, id2, v2)::q when s1 = s2
- && id1.var_id = id2.var_id -> accu, q, v2
- | t::q -> find_split s1 id1 (t::accu) q
- in
- let gen_from_else l =
- List.map
- (fun (s2, id2, v2) -> gen_eq id2 s2 (mkval_var id2) v2)
- l
- in
- let rec gen_assigns if_assigns else_assigns =
- let res, accu_else = match if_assigns with
- | (s1, id1, v1)::q ->
- let accu, remain, v2 = find_split s1 id1 [] else_assigns in
- (gen_eq id1 s1 v1 v2)::(gen_assigns q remain), accu
- | [] -> [], else_assigns
- in
- (gen_from_else accu_else)@res
- in
- let if_assigns = List.map get_assign instrs1_pushed in
- let else_assigns = match instrs2 with
- | None -> []
- | Some instrs2 ->
- let instrs2_pushed = push_if_in_expr instrs2 in
- List.map get_assign instrs2_pushed
- in
- gen_assigns if_assigns else_assigns
- | _ -> [instr]
- )@(push_if_in_expr q)
-
-
-
-
+ | [] ->
+ []
+ | instr :: q ->
+ (match get_instr_desc instr with
+ | MBranch (g, (c1, i1) :: tl) when c1 = tag_false || c1 = tag_true ->
+ let _, g, instrs1, instrs2 = build_if g c1 i1 tl in
+ let instrs1_pushed = push_if_in_expr instrs1 in
+ let get_assign instr =
+ match get_instr_desc instr with
+ | MLocalAssign (id, value) ->
+ false, id, value
+ | MStateAssign (id, value) ->
+ true, id, value
+ | _ ->
+ assert false
+ in
+ let gen_eq ident state value1 value2 =
+ assert (check_type_equal ident.var_type value1.value_type);
+ assert (check_type_equal ident.var_type value2.value_type);
+ let value =
+ {
+ value_desc = Fun ("ite", [ g; value1; value2 ]);
+ value_type = ident.var_type;
+ value_annot = None;
+ }
+ in
+ let assign =
+ if state then MStateAssign (ident, value)
+ else MLocalAssign (ident, value)
+ in
+ { instr_desc = assign; lustre_eq = None; instr_spec = [] }
+ in
+ let mkval_var id =
+ { value_desc = Var id; value_type = id.var_type; value_annot = None }
+ in
+ let rec find_split s1 id1 accu = function
+ | [] ->
+ [], accu, mkval_var id1
+ | (s2, id2, v2) :: q when s1 = s2 && id1.var_id = id2.var_id ->
+ accu, q, v2
+ | t :: q ->
+ find_split s1 id1 (t :: accu) q
+ in
+ let gen_from_else l =
+ List.map (fun (s2, id2, v2) -> gen_eq id2 s2 (mkval_var id2) v2) l
+ in
+ let rec gen_assigns if_assigns else_assigns =
+ let res, accu_else =
+ match if_assigns with
+ | (s1, id1, v1) :: q ->
+ let accu, remain, v2 = find_split s1 id1 [] else_assigns in
+ gen_eq id1 s1 v1 v2 :: gen_assigns q remain, accu
+ | [] ->
+ [], else_assigns
+ in
+ gen_from_else accu_else @ res
+ in
+ let if_assigns = List.map get_assign instrs1_pushed in
+ let else_assigns =
+ match instrs2 with
+ | None ->
+ []
+ | Some instrs2 ->
+ let instrs2_pushed = push_if_in_expr instrs2 in
+ List.map get_assign instrs2_pushed
+ in
+ gen_assigns if_assigns else_assigns
+ | _ ->
+ [ instr ])
+ @ push_if_in_expr q
diff --git a/src/backends/Ada/misc_printer.ml b/src/backends/Ada/misc_printer.ml
index a9f0b6417406045f458225c303419afc044453f9..28cf71b363a2913081ee62ccefeaca11f144904b 100644
--- a/src/backends/Ada/misc_printer.ml
+++ b/src/backends/Ada/misc_printer.ml
@@ -3,22 +3,16 @@ open Format
type printer = formatter -> unit
(** Encapsulate a pretty print function to lower case its result when applied
- @param pp the pretty print function
- @param fmt the formatter
- @param arg the argument of the pp function
-**)
+ @param pp the pretty print function @param fmt the formatter @param arg the
+ argument of the pp function **)
let pp_lowercase pp fmt =
let str = asprintf "%t" pp in
- fprintf fmt "%s" (String. lowercase_ascii str)
+ fprintf fmt "%s" (String.lowercase_ascii str)
-(** Print a filename by lowercasing the base and appending an extension.
- @param extension the extension to append to the package name
- @param fmt the formatter
- @param pp_name the file base name printer
-**)
+(** Print a filename by lowercasing the base and appending an extension. @param
+ extension the extension to append to the package name @param fmt the
+ formatter @param pp_name the file base name printer **)
let pp_filename extension fmt pp_name =
- fprintf fmt "%t.%s"
- (pp_lowercase pp_name)
- extension
+ fprintf fmt "%t.%s" (pp_lowercase pp_name) extension
let pp_str str fmt = fprintf fmt "%s" str
diff --git a/src/backends/C/c_backend.ml b/src/backends/C/c_backend.ml
index d3957a83ef8bebdf4b84f49188c463e7c7243962..04f1f6de57ebb616696649036c4b819002f665ca 100644
--- a/src/backends/C/c_backend.ml
+++ b/src/backends/C/c_backend.ml
@@ -11,23 +11,19 @@
open Utils.Format
open C_backend_mauve
+
(******************************************************************************)
(* Translation function *)
(******************************************************************************)
-(* USELESS
-let makefile_opt print basename dependencies makefile_fmt machines =
- (* If a main node is identified, generate a main target for it *)
- match !Options.main_node with
- | "" -> ()
- | main_node -> (
- match Machine_code.get_machine_opt main_node machines with
- | None -> Format.eprintf "Unable to find a main node named %s@.@?" main_node; ()
- | Some _ -> print basename !Options.main_node dependencies makefile_fmt
- )
-*)
-
-let c_or_cpp f =
- if !Options.cpp then f ^ ".cpp" else f ^ ".c" (* Could be changed *)
+(* USELESS let makefile_opt print basename dependencies makefile_fmt machines =
+ (* If a main node is identified, generate a main target for it *) match
+ !Options.main_node with | "" -> () | main_node -> ( match
+ Machine_code.get_machine_opt main_node machines with | None -> Format.eprintf
+ "Unable to find a main node named %s@.@?" main_node; () | Some _ -> print
+ basename !Options.main_node dependencies makefile_fmt ) *)
+
+let c_or_cpp f = if !Options.cpp then f ^ ".cpp" else f ^ ".c"
+(* Could be changed *)
let with_main_node machines node f =
if node <> "" then
@@ -42,14 +38,19 @@ let with_main_node machines node f =
f m
let gen_files
- (print_alloc_header, print_lib_c, print_main_c, print_makefile, preprocess (* , print_cmake *))
- basename prog machines dependencies =
+ ( print_alloc_header,
+ print_lib_c,
+ print_main_c,
+ print_makefile,
+ preprocess
+ (* , print_cmake *) ) basename prog machines dependencies =
let destname = !Options.dest_dir ^ "/" ^ basename in
-
+
let machines, spec = preprocess machines in
(* Generating H alloc file *)
- let alloc_header_file = destname ^ "_alloc.h" in (* Could be changed *)
+ let alloc_header_file = destname ^ "_alloc.h" in
+ (* Could be changed *)
with_out_file alloc_header_file (fun header_fmt ->
print_alloc_header header_fmt basename prog machines dependencies spec);
@@ -79,44 +80,41 @@ let gen_files
print_mauve_fsm source_mauve_fmt m));
(* Generating Makefile *)
- (* Makefiles:
- - for the moment two cases
- 1. Classical Makefile, only when provided with a main node
- May contain additional framac eacsl targets
- 2. Cmake : 2 files
- - lustrec-basename.cmake describing all variables
- - the main CMakeLists.txt activating the first file
- - Later option 1 should be removed
- *)
+ (* Makefiles: - for the moment two cases 1. Classical Makefile, only when
+ provided with a main node May contain additional framac eacsl targets 2.
+ Cmake : 2 files - lustrec-basename.cmake describing all variables - the
+ main CMakeLists.txt activating the first file - Later option 1 should be
+ removed *)
(* Case 1 *)
if main_node <> "" then
- let makefile_file = destname ^ ".makefile" in (* Could be changed *)
+ let makefile_file = destname ^ ".makefile" in
+ (* Could be changed *)
with_out_file makefile_file (fun makefile_fmt ->
print_makefile basename main_node dependencies makefile_fmt)
- (* (\* Case 2 *\) *)
- (* let cmake_file = "lustrec-" ^ basename ^ ".cmake" in *)
- (* let cmake_file_full_path = !Options.dest_dir ^ "/" ^ cmake_file in *)
- (* let cmake_out = open_out cmake_file_full_path in *)
- (* let cmake_fmt = formatter_of_out_channel cmake_out in *)
- (* (\* Generating Makefile *\) *)
- (* print_cmake basename main_node dependencies makefile_fmt; *)
-
- (* close_out makefile_out *)
-
+(* (\* Case 2 *\) *)
+(* let cmake_file = "lustrec-" ^ basename ^ ".cmake" in *)
+(* let cmake_file_full_path = !Options.dest_dir ^ "/" ^ cmake_file in *)
+(* let cmake_out = open_out cmake_file_full_path in *)
+(* let cmake_fmt = formatter_of_out_channel cmake_out in *)
+(* (\* Generating Makefile *\) *)
+(* print_cmake basename main_node dependencies makefile_fmt; *)
+
+(* close_out makefile_out *)
+
let print_c_header basename =
- let header_m = match !Options.spec with
+ let header_m =
+ match !Options.spec with
| "no" ->
- C_backend_header.(module EmptyMod : MODIFIERS_HDR)
-
+ C_backend_header.((module EmptyMod : MODIFIERS_HDR))
| "acsl" ->
- C_backend_header.(module C_backend_spec.HdrMod : MODIFIERS_HDR)
-
- | "c" -> assert false (* not implemented yet *)
-
- | _ -> assert false
+ C_backend_header.((module C_backend_spec.HdrMod : MODIFIERS_HDR))
+ | "c" ->
+ assert false (* not implemented yet *)
+ | _ ->
+ assert false
in
- let module Header = C_backend_header.Main (val header_m) in
+ let module Header = C_backend_header.Main ((val header_m)) in
let destname = !Options.dest_dir ^ "/" ^ basename in
(* Generating H file *)
let lusic = Lusic.read_lusic destname ".lusic" in
@@ -129,41 +127,39 @@ let translate_to_c generate_c_header basename prog machines dependencies =
let header_m, source_m, source_main_m, makefile_m, preprocess =
match !Options.spec with
| "no" ->
- C_backend_header.(module EmptyMod : MODIFIERS_HDR),
- C_backend_src.(module EmptyMod : MODIFIERS_SRC),
- C_backend_main.(module EmptyMod : MODIFIERS_MAINSRC),
- C_backend_makefile.(module EmptyMod : MODIFIERS_MKF),
- fun m -> m, []
-
+ ( C_backend_header.((module EmptyMod : MODIFIERS_HDR)),
+ C_backend_src.((module EmptyMod : MODIFIERS_SRC)),
+ C_backend_main.((module EmptyMod : MODIFIERS_MAINSRC)),
+ C_backend_makefile.((module EmptyMod : MODIFIERS_MKF)),
+ fun m -> m, [] )
| "acsl" ->
let open C_backend_spec in
- C_backend_header.(module HdrMod : MODIFIERS_HDR),
- C_backend_src.(module SrcMod : MODIFIERS_SRC),
- C_backend_main.(module EmptyMod : MODIFIERS_MAINSRC),
- C_backend_makefile.(module MakefileMod : MODIFIERS_MKF),
- preprocess_acsl
-
- | "c" -> assert false (* not implemented yet *)
-
- | _ -> assert false
+ ( C_backend_header.((module HdrMod : MODIFIERS_HDR)),
+ C_backend_src.((module SrcMod : MODIFIERS_SRC)),
+ C_backend_main.((module EmptyMod : MODIFIERS_MAINSRC)),
+ C_backend_makefile.((module MakefileMod : MODIFIERS_MKF)),
+ preprocess_acsl )
+ | "c" ->
+ assert false (* not implemented yet *)
+ | _ ->
+ assert false
in
- let module Header = C_backend_header.Main (val header_m) in
- let module Source = C_backend_src.Main (val source_m) in
- let module SourceMain = C_backend_main.Main (val source_main_m) in
- let module Makefile = C_backend_makefile.Main (val makefile_m) in
+ let module Header = C_backend_header.Main ((val header_m)) in
+ let module Source = C_backend_src.Main ((val source_m)) in
+ let module SourceMain = C_backend_main.Main ((val source_main_m)) in
+ let module Makefile = C_backend_makefile.Main ((val makefile_m)) in
(* let module CMakefile = C_backend_cmake.Main (MakefileMod) in *)
let funs =
- Header.print_alloc_header,
- Source.print_lib_c,
- SourceMain.print_main_c,
- Makefile.print_makefile,
- preprocess
+ ( Header.print_alloc_header,
+ Source.print_lib_c,
+ SourceMain.print_main_c,
+ Makefile.print_makefile,
+ preprocess )
(* CMakefile.print_makefile *)
in
if generate_c_header then print_c_header basename;
gen_files funs basename prog machines dependencies
-
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
(* End: *)
diff --git a/src/backends/C/c_backend_cmake.ml b/src/backends/C/c_backend_cmake.ml
index 205c3311c9ff57ea87e04d4446b798b859f05f9a..c0b726db7fb22079427188d1425a8cb173e64eab 100644
--- a/src/backends/C/c_backend_cmake.ml
+++ b/src/backends/C/c_backend_cmake.ml
@@ -14,93 +14,106 @@ open LustreSpec
open Corelang
let header_has_code header =
- List.exists
- (fun top ->
+ List.exists
+ (fun top ->
match top.top_decl_desc with
- | Const _ -> true
- | ImportedNode nd -> nd.nodei_in_lib = []
- | _ -> false
- )
+ | Const _ ->
+ true
+ | ImportedNode nd ->
+ nd.nodei_in_lib = []
+ | _ ->
+ false)
header
let header_libs header =
- List.fold_left (fun accu top ->
- match top.top_decl_desc with
- | ImportedNode nd -> Utils.list_union nd.nodei_in_lib accu
- | _ -> accu
- ) [] header
-
+ List.fold_left
+ (fun accu top ->
+ match top.top_decl_desc with
+ | ImportedNode nd ->
+ Utils.list_union nd.nodei_in_lib accu
+ | _ ->
+ accu)
+ [] header
-let compiled_dependencies dep =
+let compiled_dependencies dep =
List.filter (fun (Dep (_, _, header, _)) -> header_has_code header) dep
-let lib_dependencies dep =
- List.fold_left
- (fun accu (Dep (_, _, header, _)) -> Utils.list_union (header_libs header) accu) [] dep
-
-let fprintf_dependencies fmt (dep: dep_t list) =
+let lib_dependencies dep =
+ List.fold_left
+ (fun accu (Dep (_, _, header, _)) ->
+ Utils.list_union (header_libs header) accu)
+ [] dep
+
+let fprintf_dependencies fmt (dep : dep_t list) =
let compiled_dep = compiled_dependencies dep in
- List.iter (fun s -> (* Format.eprintf "Adding dependency: %s@." s; *)
- fprintf fmt "\t${GCC} -I${INC} -c %s@." s)
- (("${INC}/io_frontend.c"):: (* IO functions when a main function is computed *)
- (List.map
- (fun (Dep (local, s, _, _)) ->
- (if local then s else Version.include_path ^ "/" ^ s) ^ ".c")
- compiled_dep))
+ List.iter
+ (fun s ->
+ (* Format.eprintf "Adding dependency: %s@." s; *)
+ fprintf fmt "\t${GCC} -I${INC} -c %s@." s)
+ ("${INC}/io_frontend.c"
+ ::
+ (* IO functions when a main function is computed *)
+ List.map
+ (fun (Dep (local, s, _, _)) ->
+ (if local then s else Version.include_path ^ "/" ^ s) ^ ".c")
+ compiled_dep)
-module type MODIFIERS_MKF =
-sig (* dep was (bool * ident * top_decl list) *)
- val other_targets: Format.formatter -> string -> string -> dep_t list -> unit
+module type MODIFIERS_MKF = sig
+ (* dep was (bool * ident * top_decl list) *)
+ val other_targets : Format.formatter -> string -> string -> dep_t list -> unit
end
-module EmptyMod =
-(struct
+module EmptyMod : MODIFIERS_MKF = struct
let other_targets _ _ _ _ = ()
-end: MODIFIERS_MKF)
-
-module Main = functor (Mod: MODIFIERS_MKF) ->
-struct
-
-
- let print_cmake basename nodename (dependencies: dep_t list) fmt =
-
- (* Printing the basic file CMakeLists.txt *)
- let fmt_CMakeLists_txt = formatter_of_out_channel (open_out (!Options.dest_dir ^ "/CMakeLists.txt")) in
- fprintf fmt_CMakeLists_txt "cmake_minimum_required(VERSION 3.0)@.";
- fprintf fmt_CMakeLists_txt "project(%s C)@." basename;
- fprintf mt_CMakeLists_txt "@.";
- fprintf mt_CMakeLists_txt "set(LUSTREC_DEFINE_TARGETS ON)@.";
- fprintf mt_CMakeLists_txt "include(lustrec-%s.cmake)" basename;
+end
-
- fprintf fmt "GCC=gcc@.";
- fprintf fmt "LUSTREC=%s@." Sys.executable_name;
- fprintf fmt "LUSTREC_BASE=%s@." (Filename.dirname (Filename.dirname Sys.executable_name));
- fprintf fmt "INC=${LUSTREC_BASE}/include/lustrec@.";
- fprintf fmt "@.";
+module Main =
+functor
+ (Mod : MODIFIERS_MKF)
+ ->
+ struct
+ let print_cmake basename nodename (dependencies : dep_t list) fmt =
+ (* Printing the basic file CMakeLists.txt *)
+ let fmt_CMakeLists_txt =
+ formatter_of_out_channel
+ (open_out (!Options.dest_dir ^ "/CMakeLists.txt"))
+ in
+ fprintf fmt_CMakeLists_txt "cmake_minimum_required(VERSION 3.0)@.";
+ fprintf fmt_CMakeLists_txt "project(%s C)@." basename;
+ fprintf mt_CMakeLists_txt "@.";
+ fprintf mt_CMakeLists_txt "set(LUSTREC_DEFINE_TARGETS ON)@.";
+ fprintf mt_CMakeLists_txt "include(lustrec-%s.cmake)" basename;
- (* Main binary *)
- fprintf fmt "%s_%s: %s.c %s_main.c@." basename nodename basename basename;
- fprintf fmt "\t${GCC} -O0 -I${INC} -I. -c %s.c@." basename;
- fprintf fmt "\t${GCC} -O0 -I${INC} -I. -c %s_main.c@." basename;
- fprintf_dependencies fmt dependencies;
- fprintf fmt "\t${GCC} -O0 -o %s_%s io_frontend.o %a %s.o %s_main.o %a@." basename nodename
- (Utils.fprintf_list ~sep:" " (fun fmt (Dep (_, s, _, _)) -> Format.fprintf fmt "%s.o" s))
- (compiled_dependencies dependencies)
- basename (* library .o *)
- basename (* main function . o *)
- (Utils.fprintf_list ~sep:" " (fun fmt lib -> fprintf fmt "-l%s" lib)) (lib_dependencies dependencies)
- ;
- fprintf fmt "@.";
- fprintf fmt "clean:@.";
- fprintf fmt "\t\\rm -f *.o %s_%s@." basename nodename;
- fprintf fmt "@.";
- fprintf fmt ".PHONY: %s_%s@." basename nodename;
- fprintf fmt "@.";
- Mod.other_targets fmt basename nodename dependencies;
- fprintf fmt "@.";
+ fprintf fmt "GCC=gcc@.";
+ fprintf fmt "LUSTREC=%s@." Sys.executable_name;
+ fprintf fmt "LUSTREC_BASE=%s@."
+ (Filename.dirname (Filename.dirname Sys.executable_name));
+ fprintf fmt "INC=${LUSTREC_BASE}/include/lustrec@.";
+ fprintf fmt "@.";
-end
+ (* Main binary *)
+ fprintf fmt "%s_%s: %s.c %s_main.c@." basename nodename basename basename;
+ fprintf fmt "\t${GCC} -O0 -I${INC} -I. -c %s.c@." basename;
+ fprintf fmt "\t${GCC} -O0 -I${INC} -I. -c %s_main.c@." basename;
+ fprintf_dependencies fmt dependencies;
+ fprintf fmt "\t${GCC} -O0 -o %s_%s io_frontend.o %a %s.o %s_main.o %a@."
+ basename nodename
+ (Utils.fprintf_list ~sep:" " (fun fmt (Dep (_, s, _, _)) ->
+ Format.fprintf fmt "%s.o" s))
+ (compiled_dependencies dependencies)
+ basename (* library .o *) basename
+ (* main function . o *)
+ (Utils.fprintf_list ~sep:" " (fun fmt lib -> fprintf fmt "-l%s" lib))
+ (lib_dependencies dependencies);
+ fprintf fmt "@.";
+ fprintf fmt "clean:@.";
+ fprintf fmt "\t\\rm -f *.o %s_%s@." basename nodename;
+ fprintf fmt "@.";
+ fprintf fmt ".PHONY: %s_%s@." basename nodename;
+ fprintf fmt "@.";
+ Mod.other_targets fmt basename nodename dependencies;
+ fprintf fmt "@."
+ end
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
diff --git a/src/backends/C/c_backend_common.ml b/src/backends/C/c_backend_common.ml
index 903ca21c0867939f74f714bc331d20f077f5b987..621edbd47ea74ab1cf72679c27bd4050632f0df5 100644
--- a/src/backends/C/c_backend_common.ml
+++ b/src/backends/C/c_backend_common.ml
@@ -18,35 +18,31 @@ module Mpfr = Lustrec_mpfr
let pp_print_version fmt () =
fprintf fmt
- "/* @[<v>\
- C code generated by %s@,\
+ "/* @[<v>C code generated by %s@,\
Version number %s@,\
Code is %s compliant@,\
Using %s numbers */@,\
@]"
- (Filename.basename Sys.executable_name)
- Version.number
+ (Filename.basename Sys.executable_name)
+ Version.number
(if !Options.ansi then "ANSI C90" else "C99")
- (if !Options.mpfr then "MPFR multi-precision" else "(double) floating-point")
+ (if !Options.mpfr then "MPFR multi-precision"
+ else "(double) floating-point")
-let protect_filename s =
- Str.global_replace (Str.regexp "\\.\\|\\ ") "_" s
+let protect_filename s = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" s
let file_to_module_name basename =
let baseNAME = Ocaml_utils.uppercase basename in
let baseNAME = protect_filename baseNAME in
baseNAME
-let pp_ptr fmt =
- fprintf fmt "*%s"
+let pp_ptr fmt = fprintf fmt "*%s"
let reset_label = "Reset"
-let pp_label fmt =
- fprintf fmt "%s:"
+let pp_label fmt = fprintf fmt "%s:"
-let var_is name v =
- v.var_id = name
+let var_is name v = v.var_id = name
let mk_local n m =
let used name =
@@ -54,35 +50,43 @@ let mk_local n m =
exists (var_is name) m.mstep.step_inputs
|| exists (var_is name) m.mstep.step_outputs
|| exists (var_is name) m.mstep.step_locals
- || exists (var_is name) m.mmemory in
+ || exists (var_is name) m.mmemory
+ in
mk_new_name used n
-(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
+(* Generation of a non-clashing name for the self memory variable (for step and
+ reset functions) *)
let mk_self = mk_local "self"
let mk_mem = mk_local "mem"
+
let mk_mem_in = mk_local "mem_in"
+
let mk_mem_out = mk_local "mem_out"
+
let mk_mem_reset = mk_local "mem_reset"
-(* Generation of a non-clashing name for the instance variable of static allocation macro *)
+(* Generation of a non-clashing name for the instance variable of static
+ allocation macro *)
let mk_instance m =
let used name =
let open List in
- exists (var_is name) m.mstep.step_inputs
- || exists (var_is name) m.mmemory in
+ exists (var_is name) m.mstep.step_inputs || exists (var_is name) m.mmemory
+ in
mk_new_name used "inst"
-(* Generation of a non-clashing name for the attribute variable of static allocation macro *)
+(* Generation of a non-clashing name for the attribute variable of static
+ allocation macro *)
let mk_attribute m =
let used name =
let open List in
- exists (var_is name) m.mstep.step_inputs
- || exists (var_is name) m.mmemory in
+ exists (var_is name) m.mstep.step_inputs || exists (var_is name) m.mmemory
+ in
mk_new_name used "attr"
let mk_call_var_decl loc id =
- { var_id = id;
+ {
+ var_id = id;
var_orig = false;
var_dec_type = mktyp Location.dummy_loc Tydec_any;
var_dec_clock = mkclock Location.dummy_loc Ckdec_any;
@@ -91,104 +95,107 @@ let mk_call_var_decl loc id =
var_parent_nodeid = None;
var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ());
var_clock = Clocks.new_var true;
- var_loc = loc }
+ var_loc = loc;
+ }
(* counter for loop variable creation *)
let loop_cpt = ref (-1)
-let reset_loop_counter () =
- loop_cpt := -1
+let reset_loop_counter () = loop_cpt := -1
let mk_loop_var m () =
- let vars = m.mstep.step_inputs
- @ m.mstep.step_outputs
- @ m.mstep.step_locals
- @ m.mmemory in
+ let vars =
+ m.mstep.step_inputs @ m.mstep.step_outputs @ m.mstep.step_locals @ m.mmemory
+ in
let rec aux () =
incr loop_cpt;
let s = sprintf "__%s_%d" "i" !loop_cpt in
if List.exists (var_is s) vars then aux () else s
- in aux ()
-(*
-let addr_cpt = ref (-1)
+ in
+ aux ()
-let reset_addr_counter () =
- addr_cpt := -1
+(* let addr_cpt = ref (-1)
-let mk_addr_var m var =
- let vars = m.mmemory in
- let rec aux () =
- incr addr_cpt;
- let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in
- if List.exists (fun v -> v.var_id = s) vars then aux () else s
- in aux ()
-*)
+ let reset_addr_counter () = addr_cpt := -1
+
+ let mk_addr_var m var = let vars = m.mmemory in let rec aux () = incr
+ addr_cpt; let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in if
+ List.exists (fun v -> v.var_id = s) vars then aux () else s in aux () *)
let pp_global_init_name fmt id = fprintf fmt "%s_INIT" id
+
let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id
-let pp_machine_memtype_name ?(ghost=false) fmt id =
+
+let pp_machine_memtype_name ?(ghost = false) fmt id =
fprintf fmt "struct %s_mem%s" id (if ghost then "_ghost" else "")
-let pp_machine_decl ?(ghost=false) pp_var fmt (id, var) =
+
+let pp_machine_decl ?(ghost = false) pp_var fmt (id, var) =
fprintf fmt "%a %a" (pp_machine_memtype_name ~ghost) id pp_var var
-let pp_machine_decl' ?(ghost=false) fmt =
+
+let pp_machine_decl' ?(ghost = false) fmt =
pp_machine_decl ~ghost pp_print_string fmt
+
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
+
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
+
let pp_machine_dealloc_name fmt id = fprintf fmt "%s_dealloc" id
+
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
+
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
+
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
+
let pp_machine_set_reset_name fmt id = fprintf fmt "%s_set_reset" id
+
let pp_machine_clear_reset_name fmt id = fprintf fmt "%s_clear_reset" id
+
let pp_machine_init_name fmt id = fprintf fmt "%s_init" id
+
let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id
+
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
let pp_mod pp_val v1 v2 fmt =
if !Options.integer_div_euclidean then
(* (a mod_C b) + (a mod_C b < 0 ? abs(b) : 0) *)
- fprintf fmt "((%a %% %a) + ((%a %% %a) < 0?(abs(%a)):0))"
- pp_val v1 pp_val v2
- pp_val v1 pp_val v2
- pp_val v2
- else (* Regular behavior: printing a % *)
+ fprintf fmt "((%a %% %a) + ((%a %% %a) < 0?(abs(%a)):0))" pp_val v1 pp_val
+ v2 pp_val v1 pp_val v2 pp_val v2
+ else
+ (* Regular behavior: printing a % *)
fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
let pp_div pp_val v1 v2 fmt =
if !Options.integer_div_euclidean then
(* (a - ((a mod_C b) + (a mod_C b < 0 ? abs(b) : 0))) div_C b *)
- fprintf fmt "(%a - %t) / %a"
- pp_val v1
- (pp_mod pp_val v1 v2)
- pp_val v2
- else (* Regular behavior: printing a / *)
+ fprintf fmt "(%a - %t) / %a" pp_val v1 (pp_mod pp_val v1 v2) pp_val v2
+ else
+ (* Regular behavior: printing a / *)
fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
-
+
let pp_basic_lib_fun is_int i pp_val fmt vl =
match i, vl with
- (* | "ite", [v1; v2; v3] -> fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *)
- | "uminus", [v] ->
+ (* | "ite", [v1; v2; v3] -> fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2
+ pp_val v3 *)
+ | "uminus", [ v ] ->
fprintf fmt "(- %a)" pp_val v
- | "not", [v] ->
+ | "not", [ v ] ->
fprintf fmt "(!%a)" pp_val v
- | "impl", [v1; v2] ->
+ | "impl", [ v1; v2 ] ->
fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2
- | "=", [v1; v2] ->
+ | "=", [ v1; v2 ] ->
fprintf fmt "(%a == %a)" pp_val v1 pp_val v2
- | "mod", [v1; v2] ->
- if is_int then
- pp_mod pp_val v1 v2 fmt
- else
- fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
- | "equi", [v1; v2] ->
+ | "mod", [ v1; v2 ] ->
+ if is_int then pp_mod pp_val v1 v2 fmt
+ else fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
+ | "equi", [ v1; v2 ] ->
fprintf fmt "(!%a == !%a)" pp_val v1 pp_val v2
- | "xor", [v1; v2] ->
+ | "xor", [ v1; v2 ] ->
fprintf fmt "(!%a != !%a)" pp_val v1 pp_val v2
- | "/", [v1; v2] ->
- if is_int then
- pp_div pp_val v1 v2 fmt
- else
- fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
- | _, [v1; v2] ->
+ | "/", [ v1; v2 ] ->
+ if is_int then pp_div pp_val v1 v2 fmt
+ else fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
+ | _, [ v1; v2 ] ->
fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2
| _ ->
(* TODO: raise proper error *)
@@ -205,8 +212,8 @@ let rec pp_c_dimension fmt dim =
| Dbool b ->
fprintf fmt "%B" b
| Dite (i, t, e) ->
- fprintf fmt "((%a)?%a:%a)"
- pp_c_dimension i pp_c_dimension t pp_c_dimension e
+ fprintf fmt "((%a)?%a:%a)" pp_c_dimension i pp_c_dimension t pp_c_dimension
+ e
| Dappl (f, args) ->
fprintf fmt "%a"
(pp_basic_lib_fun (Basic_library.is_numeric_operator f) f pp_c_dimension)
@@ -222,39 +229,40 @@ let is_basic_c_type t =
Types.(is_int_type t || is_real_type t || is_bool_type t)
let pp_c_basic_type_desc t_desc =
- if Types.is_bool_type t_desc then
- if !Options.cpp then "bool" else "_Bool"
+ if Types.is_bool_type t_desc then if !Options.cpp then "bool" else "_Bool"
else if Types.is_int_type t_desc then !Options.int_type
else if Types.is_real_type t_desc then
if !Options.mpfr then Mpfr.mpfr_t else !Options.real_type
- else
- assert false (* Not a basic C type. Do not handle arrays or pointers *)
+ else assert false
+(* Not a basic C type. Do not handle arrays or pointers *)
-let pp_basic_c_type ?(pp_c_basic_type_desc=pp_c_basic_type_desc) ?(var_opt=None) fmt t =
+let pp_basic_c_type ?(pp_c_basic_type_desc = pp_c_basic_type_desc)
+ ?(var_opt = None) fmt t =
match var_opt with
| Some v when Machine_types.is_exportable v ->
- Machine_types.pp_c_var_type fmt v
+ Machine_types.pp_c_var_type fmt v
| _ ->
- fprintf fmt "%s" (pp_c_basic_type_desc t)
+ fprintf fmt "%s" (pp_c_basic_type_desc t)
let pp_c_type ?pp_c_basic_type_desc ?var_opt var_id fmt t =
let rec aux t pp_suffix =
- if is_basic_c_type t then
- fprintf fmt "%a %s%a"
- (pp_basic_c_type ?pp_c_basic_type_desc ~var_opt) t
- var_id
- pp_suffix ()
+ if is_basic_c_type t then
+ fprintf fmt "%a %s%a"
+ (pp_basic_c_type ?pp_c_basic_type_desc ~var_opt)
+ t var_id pp_suffix ()
else
let open Types in
match (repr t).tdesc with
| Tclock t' ->
aux t' pp_suffix
- | Tarray (d, t') ->
+ | Tarray (d, t') ->
let pp_suffix' fmt () =
- fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
+ fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d
+ in
aux t' pp_suffix'
| Tstatic (_, t') ->
- fprintf fmt "const "; aux t' pp_suffix
+ fprintf fmt "const ";
+ aux t' pp_suffix
| Tconst ty ->
fprintf fmt "%s %s" ty var_id
| Tarrow (_, _) ->
@@ -263,20 +271,16 @@ let pp_c_type ?pp_c_basic_type_desc ?var_opt var_id fmt t =
(* TODO: raise proper error *)
eprintf "internal error: C_backend_common.pp_c_type %a@." print_ty t;
assert false
- in aux t (fun _ () -> ())
-(*
-let rec pp_c_initialize fmt t =
- match (Types.repr t).Types.tdesc with
- | Types.Tint -> pp_print_string fmt "0"
- | Types.Tclock t' -> pp_c_initialize fmt t'
- | Types.Tbool -> pp_print_string fmt "0"
- | Types.Treal when not !Options.mpfr -> pp_print_string fmt "0."
- | Types.Tarray (d, t') when Dimension.is_dimension_const d ->
- fprintf fmt "{%a}"
- (Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
- (Utils.duplicate 0 (Dimension.size_const_dimension d))
- | _ -> assert false
- *)
+ in
+ aux t (fun _ () -> ())
+
+(* let rec pp_c_initialize fmt t = match (Types.repr t).Types.tdesc with |
+ Types.Tint -> pp_print_string fmt "0" | Types.Tclock t' -> pp_c_initialize
+ fmt t' | Types.Tbool -> pp_print_string fmt "0" | Types.Treal when not
+ !Options.mpfr -> pp_print_string fmt "0." | Types.Tarray (d, t') when
+ Dimension.is_dimension_const d -> fprintf fmt "{%a}" (Utils.fprintf_list
+ ~sep:"," (fun fmt _ -> pp_c_initialize fmt t')) (Utils.duplicate 0
+ (Dimension.size_const_dimension d)) | _ -> assert false *)
let pp_c_tag fmt t =
pp_print_string fmt
(if t = tag_true then "1" else if t = tag_false then "0" else t)
@@ -288,33 +292,35 @@ let rec pp_c_const fmt c =
pp_print_int fmt i
| Const_real r ->
Real.pp fmt r
- (* | Const_float r -> pp_print_float fmt r *)
+ (* | Const_float r -> pp_print_float fmt r *)
| Const_tag t ->
pp_c_tag fmt t
| Const_array ca ->
pp_print_braced pp_c_const fmt ca
| Const_struct fl ->
pp_print_braced (fun fmt (_, c) -> pp_c_const fmt c) fmt fl
- | Const_string _
- | Const_modeid _ -> assert false (* string occurs in annotations not in C *)
+ | Const_string _ | Const_modeid _ ->
+ assert false
+(* string occurs in annotations not in C *)
let reset_flag_name = "_reset"
-let pp_reset_flag ?(indirect=true) pp_stru fmt stru =
- fprintf fmt "%a%s%s"
- pp_stru stru
+
+let pp_reset_flag ?(indirect = true) pp_stru fmt stru =
+ fprintf fmt "%a%s%s" pp_stru stru
(if indirect then "->" else ".")
reset_flag_name
-let pp_reset_flag' ?indirect fmt =
- pp_reset_flag ?indirect pp_print_string fmt
+
+let pp_reset_flag' ?indirect fmt = pp_reset_flag ?indirect pp_print_string fmt
let pp_reset_assign self fmt b =
fprintf fmt "%a = %i;"
- (pp_reset_flag' ~indirect:true) self (if b then 1 else 0)
+ (pp_reset_flag' ~indirect:true)
+ self
+ (if b then 1 else 0)
-(* Prints a value expression [v], with internal function calls only.
- [pp_var] is a printer for variables (typically [pp_c_var_read]),
- but an offset suffix may be added for array variables
-*)
+(* Prints a value expression [v], with internal function calls only. [pp_var] is
+ a printer for variables (typically [pp_c_var_read]), but an offset suffix may
+ be added for array variables *)
let rec pp_c_val m self pp_var fmt v =
let pp_c_val = pp_c_val m self pp_var in
match v.value_desc with
@@ -327,94 +333,77 @@ let rec pp_c_val m self pp_var fmt v =
| Power (v, _) ->
(* TODO: raise proper error *)
eprintf "internal error: C_backend_common.pp_c_val %a@."
- (Machine_code_common.pp_val m) v;
+ (Machine_code_common.pp_val m)
+ v;
assert false
| Var v ->
- if Machine_code_common.is_memory m v then
- (* array memory vars are represented by an indirection to a local var
- * with the right type, in order to avoid casting everywhere. *)
- if Types.is_array_type v.var_type
- && not (Types.is_real_type v.var_type && !Options.mpfr)
- then fprintf fmt "%a" pp_var v
- else fprintf fmt "%s->_reg.%a" self pp_var v
- else
- pp_var fmt v
+ if Machine_code_common.is_memory m v then
+ (* array memory vars are represented by an indirection to a local var
+ * with the right type, in order to avoid casting everywhere. *)
+ if
+ Types.is_array_type v.var_type
+ && not (Types.is_real_type v.var_type && !Options.mpfr)
+ then fprintf fmt "%a" pp_var v
+ else fprintf fmt "%s->_reg.%a" self pp_var v
+ else pp_var fmt v
| Fun (n, vl) ->
pp_basic_lib_fun (Types.is_int_type v.value_type) n pp_c_val fmt vl
| ResetFlag ->
pp_reset_flag' fmt self
-
-(* Access to the value of a variable:
- - if it's not a scalar output, then its name is enough
- - otherwise, dereference it (it has been declared as a pointer,
- despite its scalar Lustre type)
- - moreover, dereference memory array variables.
-*)
-let pp_c_var_read ?(test_output=true) m fmt id =
+(* Access to the value of a variable: - if it's not a scalar output, then its
+ name is enough - otherwise, dereference it (it has been declared as a
+ pointer, despite its scalar Lustre type) - moreover, dereference memory array
+ variables. *)
+let pp_c_var_read ?(test_output = true) m fmt id =
(* mpfr_t is a static array, not treated as general arrays *)
- if Types.is_address_type id.var_type
- then
- if Machine_code_common.is_memory m id
- && not (Types.is_real_type id.var_type && !Options.mpfr)
+ if Types.is_address_type id.var_type then
+ if
+ Machine_code_common.is_memory m id
+ && not (Types.is_real_type id.var_type && !Options.mpfr)
then fprintf fmt "(*%s)" id.var_id
else fprintf fmt "%s" id.var_id
- else
- if test_output && Machine_code_common.is_output m id
- then fprintf fmt "*%s" id.var_id
- else fprintf fmt "%s" id.var_id
+ else if test_output && Machine_code_common.is_output m id then
+ fprintf fmt "*%s" id.var_id
+ else fprintf fmt "%s" id.var_id
-(* Addressable value of a variable, the one that is passed around in calls:
- - if it's not a scalar non-output, then its name is enough
- - otherwise, reference it (it must be passed as a pointer,
- despite its scalar Lustre type)
-*)
+(* Addressable value of a variable, the one that is passed around in calls: - if
+ it's not a scalar non-output, then its name is enough - otherwise, reference
+ it (it must be passed as a pointer, despite its scalar Lustre type) *)
let pp_c_var_write m fmt id =
- if Types.is_address_type id.var_type
- then
- fprintf fmt "%s" id.var_id
- else
- if Machine_code_common.is_output m id
- then
- fprintf fmt "%s" id.var_id
- else
- fprintf fmt "&%s" id.var_id
+ if Types.is_address_type id.var_type then fprintf fmt "%s" id.var_id
+ else if Machine_code_common.is_output m id then fprintf fmt "%s" id.var_id
+ else fprintf fmt "&%s" id.var_id
-(* Declaration of an input variable:
- - if its type is array/matrix/etc, then declare it as a mere pointer,
- in order to cope with unknown/parametric array dimensions,
- as it is the case for generics
-*)
+(* Declaration of an input variable: - if its type is array/matrix/etc, then
+ declare it as a mere pointer, in order to cope with unknown/parametric array
+ dimensions, as it is the case for generics *)
let pp_c_decl_input_var fmt id =
- if !Options.ansi && Types.is_address_type id.var_type
- then
- pp_c_type ~var_opt:id (sprintf "(*%s)" id.var_id) fmt
+ if !Options.ansi && Types.is_address_type id.var_type then
+ pp_c_type ~var_opt:id
+ (sprintf "(*%s)" id.var_id)
+ fmt
(Types.array_base_type id.var_type)
- else
- pp_c_type ~var_opt:id id.var_id fmt id.var_type
+ else pp_c_type ~var_opt:id id.var_id fmt id.var_type
-(* Declaration of an output variable:
- - if its type is scalar, then pass its address
- - if its type is array/matrix/struct/etc, then declare it as a mere pointer,
- in order to cope with unknown/parametric array dimensions,
- as it is the case for generics
-*)
+(* Declaration of an output variable: - if its type is scalar, then pass its
+ address - if its type is array/matrix/struct/etc, then declare it as a mere
+ pointer, in order to cope with unknown/parametric array dimensions, as it is
+ the case for generics *)
let pp_c_decl_output_var fmt id =
- if (not !Options.ansi) && Types.is_address_type id.var_type
- then
+ if (not !Options.ansi) && Types.is_address_type id.var_type then
pp_c_type ~var_opt:id id.var_id fmt id.var_type
else
- pp_c_type ~var_opt:id (sprintf "(*%s)" id.var_id) fmt
+ pp_c_type ~var_opt:id
+ (sprintf "(*%s)" id.var_id)
+ fmt
(Types.array_base_type id.var_type)
-(* Declaration of a local/mem variable:
- - if it's an array/matrix/etc, its size(s) should be
- known in order to statically allocate memory,
- so we print the full type
-*)
+(* Declaration of a local/mem variable: - if it's an array/matrix/etc, its
+ size(s) should be known in order to statically allocate memory, so we print
+ the full type *)
let pp_c_decl_local_var ?pp_c_basic_type_desc m fmt id =
- if id.var_dec_const
- then
+ if id.var_dec_const then
fprintf fmt "%a = %a"
(pp_c_type ?pp_c_basic_type_desc ~var_opt:id id.var_id)
id.var_type
@@ -422,22 +411,23 @@ let pp_c_decl_local_var ?pp_c_basic_type_desc m fmt id =
(Machine_code_common.get_const_assign m id)
else
fprintf fmt "%a"
- (pp_c_type ?pp_c_basic_type_desc ~var_opt:id id.var_id) id.var_type
+ (pp_c_type ?pp_c_basic_type_desc ~var_opt:id id.var_id)
+ id.var_type
-(* Declaration of a struct variable:
- - if it's an array/matrix/etc, we declare it as a pointer
-*)
+(* Declaration of a struct variable: - if it's an array/matrix/etc, we declare
+ it as a pointer *)
let pp_c_decl_struct_var fmt id =
- if Types.is_array_type id.var_type
- then
- pp_c_type (sprintf "(*%s)" id.var_id) fmt
+ if Types.is_array_type id.var_type then
+ pp_c_type
+ (sprintf "(*%s)" id.var_id)
+ fmt
(Types.array_base_type id.var_type)
- else
- pp_c_type id.var_id fmt id.var_type
+ else pp_c_type id.var_id fmt id.var_type
-let pp_c_decl_instance_var ?(ghost=false) fmt (name, (node, _)) =
+let pp_c_decl_instance_var ?(ghost = false) fmt (name, (node, _)) =
fprintf fmt "%a %s%s"
- (pp_machine_memtype_name ~ghost) (node_name node)
+ (pp_machine_memtype_name ~ghost)
+ (node_name node)
(if ghost then "" else "*")
name
@@ -452,64 +442,78 @@ let pp_c_decl_instance_var ?(ghost=false) fmt (name, (node, _)) =
* m.mstep.step_checks *)
let has_c_prototype funname dependencies =
- (* We select the last imported node with the name funname.
- The order of evaluation of dependencies should be
- compatible with overloading. (Not checked yet) *)
+ (* We select the last imported node with the name funname. The order of
+ evaluation of dependencies should be compatible with overloading. (Not
+ checked yet) *)
let imported_node_opt =
List.fold_left
(fun res dep ->
- match res with
- | Some _ -> res
- | None ->
- let decls = dep.content in
- let matched = fun t -> match t.top_decl_desc with
- | ImportedNode nd -> nd.nodei_id = funname
- | _ -> false
- in
- if List.exists matched decls then
- match (List.find matched decls).top_decl_desc with
- | ImportedNode nd -> Some nd
- | _ -> assert false
- else
- None) None dependencies in
+ match res with
+ | Some _ ->
+ res
+ | None ->
+ let decls = dep.content in
+ let matched t =
+ match t.top_decl_desc with
+ | ImportedNode nd ->
+ nd.nodei_id = funname
+ | _ ->
+ false
+ in
+ if List.exists matched decls then
+ match (List.find matched decls).top_decl_desc with
+ | ImportedNode nd ->
+ Some nd
+ | _ ->
+ assert false
+ else None)
+ None dependencies
+ in
match imported_node_opt with
- | None -> false
- | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
-
-(* Computes the depth to which multi-dimension array assignments should be expanded.
- It equals the maximum number of nested static array constructions accessible from root [v].
-*)
+ | None ->
+ false
+ | Some nd -> (
+ match nd.nodei_prototype with Some "C" -> true | _ -> false)
+
+(* Computes the depth to which multi-dimension array assignments should be
+ expanded. It equals the maximum number of nested static array constructions
+ accessible from root [v]. *)
let rec expansion_depth v =
match v.value_desc with
- | Cst cst -> expansion_depth_cst cst
- | Var _ -> 0
- | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
- | Array vl -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
- | Access (v, _) -> max 0 (expansion_depth v - 1)
- | Power _ -> 0 (*1 + expansion_depth v*)
- | ResetFlag -> 0
+ | Cst cst ->
+ expansion_depth_cst cst
+ | Var _ ->
+ 0
+ | Fun (_, vl) ->
+ List.fold_right (fun v -> max (expansion_depth v)) vl 0
+ | Array vl ->
+ 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
+ | Access (v, _) ->
+ max 0 (expansion_depth v - 1)
+ | Power _ ->
+ 0 (*1 + expansion_depth v*)
+ | ResetFlag ->
+ 0
+
and expansion_depth_cst c =
match c with
| Const_array cl ->
1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0
- | _ -> 0
+ | _ ->
+ 0
type loop_index = LVar of ident | LInt of int ref | LAcc of value_t
-(*
-let rec value_offsets v offsets =
- match v, offsets with
- | _ , [] -> v
- | Power (v, n) , _ :: q -> value_offsets v q
- | Array vl , LInt r :: q -> value_offsets (List.nth vl !r) q
- | Cst (Const_array cl) , LInt r :: q -> value_offsets (Cst (List.nth cl !r)) q
- | Fun (f, vl) , _ -> Fun (f, List.map (fun v -> value_offsets v offsets) vl)
- | _ , LInt r :: q -> value_offsets (Access (v, Cst (Const_int !r))) q
- | _ , LVar i :: q -> value_offsets (Access (v, Var i)) q
-*)
-(* Computes the list of nested loop variables together with their dimension bounds.
- - LInt r stands for loop expansion (no loop variable, but int loop index)
- - LVar v stands for loop variable v
-*)
+
+(* let rec value_offsets v offsets = match v, offsets with | _ , [] -> v | Power
+ (v, n) , _ :: q -> value_offsets v q | Array vl , LInt r :: q ->
+ value_offsets (List.nth vl !r) q | Cst (Const_array cl) , LInt r :: q ->
+ value_offsets (Cst (List.nth cl !r)) q | Fun (f, vl) , _ -> Fun (f, List.map
+ (fun v -> value_offsets v offsets) vl) | _ , LInt r :: q -> value_offsets
+ (Access (v, Cst (Const_int !r))) q | _ , LVar i :: q -> value_offsets (Access
+ (v, Var i)) q *)
+(* Computes the list of nested loop variables together with their dimension
+ bounds. - LInt r stands for loop expansion (no loop variable, but int loop
+ index) - LVar v stands for loop variable v *)
let rec mk_loop_variables m ty depth =
match (Types.repr ty).Types.tdesc, depth with
| Types.Tarray (d, ty'), 0 ->
@@ -518,21 +522,26 @@ let rec mk_loop_variables m ty depth =
| Types.Tarray (d, ty'), _ ->
let r = ref (-1) in
(d, LInt r) :: mk_loop_variables m ty' (depth - 1)
- | _, 0 -> []
- | _ -> assert false
+ | _, 0 ->
+ []
+ | _ ->
+ assert false
let reorder_loop_variables loop_vars =
- let (int_loops, var_loops) =
- List.partition (function (_, LInt _) -> true | _ -> false) loop_vars
+ let int_loops, var_loops =
+ List.partition (function _, LInt _ -> true | _ -> false) loop_vars
in
var_loops @ int_loops
(* Prints a one loop variable suffix for arrays *)
let pp_loop_var pp_val fmt lv =
match snd lv with
- | LVar v -> fprintf fmt "[%s]" v
- | LInt r -> fprintf fmt "[%d]" !r
- | LAcc i -> fprintf fmt "[%a]" pp_val i
+ | LVar v ->
+ fprintf fmt "[%s]" v
+ | LInt r ->
+ fprintf fmt "[%d]" !r
+ | LAcc i ->
+ fprintf fmt "[%a]" pp_val i
(* Prints a suffix of loop variables for arrays *)
let pp_suffix pp_val =
@@ -540,14 +549,16 @@ let pp_suffix pp_val =
let rec is_const_index v =
match v.value_desc with
- | Cst (Const_int _) -> true
- | Fun (_, vl) -> List.for_all is_const_index vl
- | _ -> false
-
-(* Prints a value expression [v], with internal function calls only.
- [pp_var] is a printer for variables (typically [pp_c_var_read]),
- but an offset suffix may be added for array variables
-*)
+ | Cst (Const_int _) ->
+ true
+ | Fun (_, vl) ->
+ List.for_all is_const_index vl
+ | _ ->
+ false
+
+(* Prints a value expression [v], with internal function calls only. [pp_var] is
+ a printer for variables (typically [pp_c_var_read]), but an offset suffix may
+ be added for array variables *)
(* Prints a constant value before a suffix (needs casting) *)
let rec pp_c_const_suffix var_type fmt c =
match c with
@@ -559,25 +570,31 @@ let rec pp_c_const_suffix var_type fmt c =
pp_c_tag fmt t
| Const_array ca ->
let var_type = Types.array_element_type var_type in
- fprintf fmt "(%a[])%a"
- (pp_c_type "") var_type
- (pp_print_braced (pp_c_const_suffix var_type)) ca
+ fprintf fmt "(%a[])%a" (pp_c_type "") var_type
+ (pp_print_braced (pp_c_const_suffix var_type))
+ ca
| Const_struct fl ->
pp_print_braced
(fun fmt (f, c) ->
- (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)
+ (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)
fmt fl
- | Const_string _
- | Const_modeid _ -> assert false (* string occurs in annotations not in C *)
+ | Const_string _ | Const_modeid _ ->
+ assert false
+(* string occurs in annotations not in C *)
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)
-let rec pp_value_suffix ?(indirect=true) m self var_type loop_vars pp_var fmt value =
- (*eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)
- let pp_suffix = pp_suffix (pp_value_suffix ~indirect m self var_type [] pp_var) in
+let rec pp_value_suffix ?(indirect = true) m self var_type loop_vars pp_var fmt
+ value =
+ (*eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type
+ Machine_code.pp_val value pp_suffix loop_vars;*)
+ let pp_suffix =
+ pp_suffix (pp_value_suffix ~indirect m self var_type [] pp_var)
+ in
match loop_vars, value.value_desc with
| (x, LAcc i) :: q, _ when is_const_index i ->
let r = ref (Dimension.size_const_dimension (dimension_of_value i)) in
- pp_value_suffix ~indirect m self var_type ((x, LInt r)::q) pp_var fmt value
+ pp_value_suffix ~indirect m self var_type ((x, LInt r) :: q) pp_var fmt
+ value
| (_, LInt r) :: q, Cst (Const_array cl) ->
let var_type = Types.array_element_type var_type in
pp_value_suffix ~indirect m self var_type q pp_var fmt
@@ -585,39 +602,44 @@ let rec pp_value_suffix ?(indirect=true) m self var_type loop_vars pp_var fmt va
| (_, LInt r) :: q, Array vl ->
let var_type = Types.array_element_type var_type in
pp_value_suffix ~indirect m self var_type q pp_var fmt (List.nth vl !r)
- | loop_var :: q, Array vl ->
+ | loop_var :: q, Array vl ->
let var_type = Types.array_element_type var_type in
- fprintf fmt "(%a[])%a%a"
- (pp_c_type "") var_type
- (pp_print_braced (pp_value_suffix ~indirect m self var_type q pp_var)) vl
- pp_suffix [loop_var]
- | [], Array vl ->
+ fprintf fmt "(%a[])%a%a" (pp_c_type "") var_type
+ (pp_print_braced (pp_value_suffix ~indirect m self var_type q pp_var))
+ vl pp_suffix [ loop_var ]
+ | [], Array vl ->
let var_type = Types.array_element_type var_type in
- fprintf fmt "(%a[])%a"
- (pp_c_type "") var_type
- (pp_print_braced (pp_value_suffix ~indirect m self var_type [] pp_var)) vl
- | _ :: q, Power (v, _) ->
+ fprintf fmt "(%a[])%a" (pp_c_type "") var_type
+ (pp_print_braced (pp_value_suffix ~indirect m self var_type [] pp_var))
+ vl
+ | _ :: q, Power (v, _) ->
pp_value_suffix ~indirect m self var_type q pp_var fmt v
- | _, Fun (n, vl) ->
- pp_basic_lib_fun (Types.is_int_type value.value_type) n
- (pp_value_suffix ~indirect m self var_type loop_vars pp_var) fmt vl
+ | _, Fun (n, vl) ->
+ pp_basic_lib_fun
+ (Types.is_int_type value.value_type)
+ n
+ (pp_value_suffix ~indirect m self var_type loop_vars pp_var)
+ fmt vl
| _, Access (v, i) ->
let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in
pp_value_suffix m self var_type
- ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_var fmt v
+ ((Dimension.mkdim_var (), LAcc i) :: loop_vars)
+ pp_var fmt v
| _, Var v ->
if is_memory m v then
- (* array memory vars are represented by an indirection to a local var with the right type,
- in order to avoid casting everywhere. *)
- if Types.is_array_type v.var_type
- then fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
- else fprintf fmt "%s%s_reg.%a%a"
- self (if indirect then "->" else ".") pp_var v pp_suffix loop_vars
+ (* array memory vars are represented by an indirection to a local var with
+ the right type, in order to avoid casting everywhere. *)
+ if Types.is_array_type v.var_type then
+ fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
+ else
+ fprintf fmt "%s%s_reg.%a%a" self
+ (if indirect then "->" else ".")
+ pp_var v pp_suffix loop_vars
else if is_reset_flag v then
- fprintf fmt "%s%s%a%a"
- self (if indirect then "->" else ".") pp_var v pp_suffix loop_vars
- else
- fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
+ fprintf fmt "%s%s%a%a" self
+ (if indirect then "->" else ".")
+ pp_var v pp_suffix loop_vars
+ else fprintf fmt "%a%a" pp_var v pp_suffix loop_vars
| _, Cst cst ->
pp_c_const_suffix var_type fmt cst
| _, ResetFlag ->
@@ -628,7 +650,7 @@ let rec pp_value_suffix ?(indirect=true) m self var_type loop_vars pp_var fmt va
assert false
(********************************************************************************************)
-(* Struct Printing functions *)
+(* Struct Printing functions *)
(********************************************************************************************)
(* let pp_registers_struct fmt m =
@@ -642,308 +664,292 @@ let rec pp_value_suffix ?(indirect=true) m self var_type loop_vars pp_var fmt va
* pp_c_decl_struct_var
* fmt m.mmemory *)
-let print_machine_struct ?(ghost=false) fmt m =
+let print_machine_struct ?(ghost = false) fmt m =
if not (fst (Machine_code_common.get_stateless_status m)) then
(* Define struct *)
fprintf fmt "@[<v 2>%a {@,_Bool _reset;%a%a@]@,};"
- (pp_machine_memtype_name ~ghost) m.mname.node_id
+ (pp_machine_memtype_name ~ghost)
+ m.mname.node_id
(if ghost then
- (fun fmt -> function
- | [] -> pp_print_nothing fmt ()
- | _ -> fprintf fmt "@,%a _reg;"
- pp_machine_regtype_name m.mname.node_id)
- else
- pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(fun fmt () ->
- fprintf fmt "@,@[%a {" pp_machine_regtype_name m.mname.node_id)
- ~pp_sep:pp_print_semicolon
- ~pp_eol:pp_print_semicolon'
- ~pp_epilogue:(fun fmt () -> fprintf fmt "}@] _reg;")
- pp_c_decl_struct_var)
+ fun fmt -> function
+ | [] ->
+ pp_print_nothing fmt ()
+ | _ ->
+ fprintf fmt "@,%a _reg;" pp_machine_regtype_name m.mname.node_id
+ else
+ pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(fun fmt () ->
+ fprintf fmt "@,@[%a {" pp_machine_regtype_name m.mname.node_id)
+ ~pp_sep:pp_print_semicolon ~pp_eol:pp_print_semicolon'
+ ~pp_epilogue:(fun fmt () -> fprintf fmt "}@] _reg;")
+ pp_c_decl_struct_var)
m.mmemory
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:pp_print_cut
- ~pp_sep:pp_print_semicolon
- ~pp_eol:pp_print_semicolon'
+ (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut
+ ~pp_sep:pp_print_semicolon ~pp_eol:pp_print_semicolon'
(pp_c_decl_instance_var ~ghost))
m.minstances
(********************************************************************************************)
-(* Prototype Printing functions *)
+(* Prototype Printing functions *)
(********************************************************************************************)
let print_global_init_prototype fmt baseNAME =
- fprintf fmt "void %a ()"
- pp_global_init_name baseNAME
+ fprintf fmt "void %a ()" pp_global_init_name baseNAME
let print_global_clear_prototype fmt baseNAME =
- fprintf fmt "void %a ()"
- pp_global_clear_name baseNAME
+ fprintf fmt "void %a ()" pp_global_clear_name baseNAME
let print_alloc_prototype fmt (name, static) =
fprintf fmt "%a * %a %a"
- (pp_machine_memtype_name ~ghost:false) name
- pp_machine_alloc_name name
- (pp_print_parenthesized pp_c_decl_input_var) static
+ (pp_machine_memtype_name ~ghost:false)
+ name pp_machine_alloc_name name
+ (pp_print_parenthesized pp_c_decl_input_var)
+ static
let print_dealloc_prototype fmt name =
- fprintf fmt "void %a (%a * _alloc)"
- pp_machine_dealloc_name name
- (pp_machine_memtype_name ~ghost:false) name
+ fprintf fmt "void %a (%a * _alloc)" pp_machine_dealloc_name name
+ (pp_machine_memtype_name ~ghost:false)
+ name
module type MODIFIERS_GHOST_PROTO = sig
- val pp_ghost_parameters: ?cut:bool -> formatter -> (string * (formatter -> string -> unit)) list -> unit
+ val pp_ghost_parameters :
+ ?cut:bool ->
+ formatter ->
+ (string * (formatter -> string -> unit)) list ->
+ unit
end
-module EmptyGhostProto: MODIFIERS_GHOST_PROTO = struct
+module EmptyGhostProto : MODIFIERS_GHOST_PROTO = struct
let pp_ghost_parameters ?cut _ _ = ()
end
-module Protos (Mod: MODIFIERS_GHOST_PROTO) = struct
-
+module Protos (Mod : MODIFIERS_GHOST_PROTO) = struct
let pp_mem_ghost name fmt mem =
pp_machine_decl ~ghost:true
- (fun fmt mem -> fprintf fmt "\\ghost %a" pp_ptr mem) fmt
- (name, mem)
+ (fun fmt mem -> fprintf fmt "\\ghost %a" pp_ptr mem)
+ fmt (name, mem)
let print_clear_reset_prototype self mem fmt (name, static) =
- fprintf fmt "@[<v>void %a (%a%a *%s)%a@]"
- pp_machine_clear_reset_name name
- (pp_comma_list ~pp_eol:pp_print_comma
- pp_c_decl_input_var) static
- (pp_machine_memtype_name ~ghost:false) name
- self
- (Mod.pp_ghost_parameters ~cut:true) [mem, pp_mem_ghost name]
+ fprintf fmt "@[<v>void %a (%a%a *%s)%a@]" pp_machine_clear_reset_name name
+ (pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
+ static
+ (pp_machine_memtype_name ~ghost:false)
+ name self
+ (Mod.pp_ghost_parameters ~cut:true)
+ [ mem, pp_mem_ghost name ]
let print_set_reset_prototype self mem fmt (name, static) =
- fprintf fmt "@[<v>void %a (%a%a *%s)%a@]"
- pp_machine_set_reset_name name
- (pp_comma_list ~pp_eol:pp_print_comma
- pp_c_decl_input_var) static
- (pp_machine_memtype_name ~ghost:false) name
- self
- (Mod.pp_ghost_parameters ~cut:true) [mem, pp_mem_ghost name]
+ fprintf fmt "@[<v>void %a (%a%a *%s)%a@]" pp_machine_set_reset_name name
+ (pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
+ static
+ (pp_machine_memtype_name ~ghost:false)
+ name self
+ (Mod.pp_ghost_parameters ~cut:true)
+ [ mem, pp_mem_ghost name ]
let print_step_prototype self mem fmt (name, inputs, outputs) =
- fprintf fmt "@[<v>void %a (@[<v>%a%a%a *%s@])%a@]"
- pp_machine_step_name name
- (pp_comma_list ~pp_eol:pp_print_comma
- ~pp_epilogue:pp_print_cut pp_c_decl_input_var) inputs
- (pp_comma_list ~pp_eol:pp_print_comma
- ~pp_epilogue:pp_print_cut pp_c_decl_output_var) outputs
- (pp_machine_memtype_name ~ghost:false) name
- self
- (Mod.pp_ghost_parameters ~cut:true) [mem, pp_mem_ghost name]
+ fprintf fmt "@[<v>void %a (@[<v>%a%a%a *%s@])%a@]" pp_machine_step_name name
+ (pp_comma_list ~pp_eol:pp_print_comma ~pp_epilogue:pp_print_cut
+ pp_c_decl_input_var)
+ inputs
+ (pp_comma_list ~pp_eol:pp_print_comma ~pp_epilogue:pp_print_cut
+ pp_c_decl_output_var)
+ outputs
+ (pp_machine_memtype_name ~ghost:false)
+ name self
+ (Mod.pp_ghost_parameters ~cut:true)
+ [ mem, pp_mem_ghost name ]
let print_init_prototype self fmt (name, static) =
- fprintf fmt "void %a (%a%a *%s)"
- pp_machine_init_name name
- (pp_comma_list ~pp_eol:pp_print_comma
- pp_c_decl_input_var) static
- (pp_machine_memtype_name ~ghost:false) name
- self
+ fprintf fmt "void %a (%a%a *%s)" pp_machine_init_name name
+ (pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
+ static
+ (pp_machine_memtype_name ~ghost:false)
+ name self
let print_clear_prototype self fmt (name, static) =
- fprintf fmt "void %a (%a%a *%s)"
- pp_machine_clear_name name
- (pp_comma_list ~pp_eol:pp_print_comma
- pp_c_decl_input_var) static
- (pp_machine_memtype_name ~ghost:false) name
- self
+ fprintf fmt "void %a (%a%a *%s)" pp_machine_clear_name name
+ (pp_comma_list ~pp_eol:pp_print_comma pp_c_decl_input_var)
+ static
+ (pp_machine_memtype_name ~ghost:false)
+ name self
let print_stateless_prototype fmt (name, inputs, outputs) =
- fprintf fmt "void %a (@[<v>%a%a@])"
- pp_machine_step_name name
- (pp_comma_list ~pp_eol:pp_print_comma
- ~pp_epilogue:pp_print_cut pp_c_decl_input_var) inputs
- (pp_comma_list pp_c_decl_output_var) outputs
-
+ fprintf fmt "void %a (@[<v>%a%a@])" pp_machine_step_name name
+ (pp_comma_list ~pp_eol:pp_print_comma ~pp_epilogue:pp_print_cut
+ pp_c_decl_input_var)
+ inputs
+ (pp_comma_list pp_c_decl_output_var)
+ outputs
end
-let print_import_prototype fmt dep =
- fprintf fmt "#include \"%s.h\"" dep.name
+let print_import_prototype fmt dep = fprintf fmt "#include \"%s.h\"" dep.name
let print_import_alloc_prototype fmt dep =
- if dep.is_stateful then
- fprintf fmt "#include \"%s_alloc.h\"" dep.name
+ if dep.is_stateful then fprintf fmt "#include \"%s_alloc.h\"" dep.name
let pp_c_var m self pp_var fmt var =
- pp_c_val m self pp_var fmt (Machine_code_common.mk_val (Var var) var.var_type)
+ pp_c_val m self pp_var fmt (Machine_code_common.mk_val (Var var) var.var_type)
let pp_array_suffix =
pp_print_list ~pp_sep:pp_print_nothing (fun fmt v -> fprintf fmt "[%s]" v)
let mpfr_vars vars =
if !Options.mpfr then
- List.filter (fun v -> Types.(is_real_type (array_base_type v.var_type))) vars
+ List.filter
+ (fun v -> Types.(is_real_type (array_base_type v.var_type)))
+ vars
else []
let mpfr_consts consts =
if !Options.mpfr then
- List.filter (fun c -> Types.(is_real_type (array_base_type c.const_type))) consts
+ List.filter
+ (fun c -> Types.(is_real_type (array_base_type c.const_type)))
+ consts
else []
(* type directed initialization: useless wrt the lustre compilation model,
- except for MPFR injection, where values are dynamically allocated
-*)
+ except for MPFR injection, where values are dynamically allocated *)
let pp_initialize m self pp_var fmt var =
let rec aux indices fmt typ =
- if Types.is_array_type typ
- then
+ if Types.is_array_type typ then
let dim = Types.array_type_dimension typ in
let idx = mk_loop_var m () in
- fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
- idx idx idx pp_c_dimension dim idx
- (aux (idx::indices)) (Types.array_element_type typ)
+ fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" idx idx
+ idx pp_c_dimension dim idx
+ (aux (idx :: indices))
+ (Types.array_element_type typ)
else
let indices = List.rev indices in
let pp_var_suffix fmt var =
- fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
+ fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices
+ in
Mpfr.pp_inject_init pp_var_suffix fmt var
in
reset_loop_counter ();
aux [] fmt var.var_type
-(* type directed clear: useless wrt the lustre compilation model,
- except for MPFR injection, where values are dynamically allocated
-*)
+(* type directed clear: useless wrt the lustre compilation model, except for
+ MPFR injection, where values are dynamically allocated *)
let pp_clear m self pp_var fmt var =
let rec aux indices fmt typ =
- if Types.is_array_type typ
- then
+ if Types.is_array_type typ then
let dim = Types.array_type_dimension typ in
let idx = mk_loop_var m () in
- fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
- idx idx idx pp_c_dimension dim idx
- (aux (idx::indices)) (Types.array_element_type typ)
+ fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" idx idx
+ idx pp_c_dimension dim idx
+ (aux (idx :: indices))
+ (Types.array_element_type typ)
else
let indices = List.rev indices in
let pp_var_suffix fmt var =
- fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
+ fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices
+ in
Mpfr.pp_inject_clear pp_var_suffix fmt var
in
reset_loop_counter ();
aux [] fmt var.var_type
- (*** Common functions for main ***)
+(*** Common functions for main ***)
let pp_print_file file_suffix fmt (typ, arg) =
fprintf fmt
- "@[<v 2>if (traces) {@,\
- fprintf(f_%s, \"%%%s\\n\", %s);@,\
- fflush(f_%s);@]@,\
- }"
- file_suffix typ arg
- file_suffix
-
+ "@[<v 2>if (traces) {@,fprintf(f_%s, \"%%%s\\n\", %s);@,fflush(f_%s);@]@,}"
+ file_suffix typ arg file_suffix
+
let print_put_var fmt file_suffix name var_type var_id =
let pp_file = pp_print_file ("out" ^ file_suffix) in
let unclocked_t = Types.unclock_type var_type in
fprintf fmt "@[<v>%a@]"
(fun fmt () ->
- if Types.is_int_type unclocked_t then
- fprintf fmt "_put_int(\"%s\", %s);@,%a"
- name var_id
- pp_file ("d", var_id)
- else if Types.is_bool_type unclocked_t then
- fprintf fmt "_put_bool(\"%s\", %s);@,%a"
- name var_id
- pp_file ("i", var_id)
- else if Types.is_real_type unclocked_t then
- if !Options.mpfr then
- fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s), %i);@,%a"
- name var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double
- pp_file (".*f",
- string_of_int !Options.print_prec_double
- ^ ", mpfr_get_d(" ^ var_id ^ ", MPFR_RNDN)")
- else
- fprintf fmt "_put_double(\"%s\", %s, %i);@,%a"
- name var_id !Options.print_prec_double
- pp_file (".*f",
- string_of_int !Options.print_prec_double ^ ", " ^ var_id)
- else begin
- eprintf "Impossible to print the _put_xx for type %a@.@?"
- Types.print_ty var_type;
- assert false
- end) ()
+ if Types.is_int_type unclocked_t then
+ fprintf fmt "_put_int(\"%s\", %s);@,%a" name var_id pp_file ("d", var_id)
+ else if Types.is_bool_type unclocked_t then
+ fprintf fmt "_put_bool(\"%s\", %s);@,%a" name var_id pp_file
+ ("i", var_id)
+ else if Types.is_real_type unclocked_t then
+ if !Options.mpfr then
+ fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s), %i);@,%a" name
+ var_id (Mpfr.mpfr_rnd ()) !Options.print_prec_double pp_file
+ ( ".*f",
+ string_of_int !Options.print_prec_double
+ ^ ", mpfr_get_d(" ^ var_id ^ ", MPFR_RNDN)" )
+ else
+ fprintf fmt "_put_double(\"%s\", %s, %i);@,%a" name var_id
+ !Options.print_prec_double pp_file
+ (".*f", string_of_int !Options.print_prec_double ^ ", " ^ var_id)
+ else (
+ eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty
+ var_type;
+ assert false))
+ ()
let pp_file_decl fmt inout idx =
- let idx = idx + 1 in (* we start from 1: in1, in2, ... *)
+ let idx = idx + 1 in
+ (* we start from 1: in1, in2, ... *)
fprintf fmt "FILE *f_%s%i;" inout idx
let pp_file_open fmt inout idx =
- let idx = idx + 1 in (* we start from 1: in1, in2, ... *)
+ let idx = idx + 1 in
+ (* we start from 1: in1, in2, ... *)
fprintf fmt
"@[<v>const char* cst_char_suffix_%s%i = \"_simu.%s%i\";@,\
- size_t l%s%i = strlen(dir) + strlen(prefix) + strlen(cst_char_suffix_%s%i);@,\
+ size_t l%s%i = strlen(dir) + strlen(prefix) + \
+ strlen(cst_char_suffix_%s%i);@,\
char* f_%s%i_name = malloc((l%s%i+2) * sizeof(char));@,\
strcpy (f_%s%i_name, dir);@,\
strcat(f_%s%i_name, \"/\");@,\
strcat(f_%s%i_name, prefix);@,\
strcat(f_%s%i_name, cst_char_suffix_%s%i);@,\
f_%s%i = fopen(f_%s%i_name, \"w\");@,\
- free(f_%s%i_name);\
- @]"
- inout idx inout idx
- inout idx inout idx
- inout idx inout idx
- inout idx
- inout idx
- inout idx
- inout idx inout idx
- inout idx inout idx
- inout idx;
+ free(f_%s%i_name);@]"
+ inout idx inout idx inout idx inout idx inout idx inout idx inout idx inout
+ idx inout idx inout idx inout idx inout idx inout idx inout idx;
"f_" ^ inout ^ string_of_int idx
let pp_basic_assign pp_var fmt typ var_name value =
- if Types.is_real_type typ && !Options.mpfr
- then
+ if Types.is_real_type typ && !Options.mpfr then
Mpfr.pp_inject_assign pp_var fmt (var_name, value)
- else
- fprintf fmt "%a = %a;"
- pp_var var_name
- pp_var value
-
-(* type_directed assignment: array vs. statically sized type
- - [var_type]: type of variable to be assigned
- - [var_name]: name of variable to be assigned
- - [value]: assigned value
- - [pp_var]: printer for variables
-*)
+ else fprintf fmt "%a = %a;" pp_var var_name pp_var value
+
+(* type_directed assignment: array vs. statically sized type - [var_type]: type
+ of variable to be assigned - [var_name]: name of variable to be assigned -
+ [value]: assigned value - [pp_var]: printer for variables *)
let pp_assign m self pp_var fmt (var, value) =
let depth = expansion_depth value in
let var_type = var.var_type in
let var = mk_val (Var var) var_type in
- (*eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*)
+ (*eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name
+ pp_val value depth;*)
let loop_vars = mk_loop_variables m var_type depth in
let reordered_loop_vars = reorder_loop_variables loop_vars in
let rec aux typ fmt vars =
match vars with
| [] ->
- pp_basic_assign (pp_value_suffix m self var_type loop_vars pp_var)
+ pp_basic_assign
+ (pp_value_suffix m self var_type loop_vars pp_var)
fmt typ var value
| (d, LVar i) :: q ->
let typ' = Types.array_element_type typ in
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
- fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
- i i i pp_c_dimension d i
- (aux typ') q
+ fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" i i i
+ pp_c_dimension d i (aux typ') q
| (d, LInt r) :: q ->
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
let typ' = Types.array_element_type typ in
let szl = Utils.enumerate (Dimension.size_const_dimension d) in
fprintf fmt "@[<v 2>{@,%a@]@,}"
- (pp_print_list (fun fmt i -> r := i; aux typ' fmt q)) szl
- | _ -> assert false
+ (pp_print_list (fun fmt i ->
+ r := i;
+ aux typ' fmt q))
+ szl
+ | _ ->
+ assert false
in
- begin
- reset_loop_counter ();
- (*reset_addr_counter ();*)
- aux var_type fmt reordered_loop_vars;
- (*eprintf "end pp_assign@.";*)
- end
+ reset_loop_counter ();
+ (*reset_addr_counter ();*)
+ aux var_type fmt reordered_loop_vars
+(*eprintf "end pp_assign@.";*)
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
diff --git a/src/backends/C/c_backend_header.ml b/src/backends/C/c_backend_header.ml
index 8849938d387e261545f525e5823d5b3afb4040a7..999ea58cfa353e08a116ee75411602b9b3b3608c 100644
--- a/src/backends/C/c_backend_header.ml
+++ b/src/backends/C/c_backend_header.ml
@@ -17,466 +17,411 @@ open Machine_code_common
open C_backend_common
(********************************************************************************************)
-(* Header Printing functions *)
+(* Header Printing functions *)
(********************************************************************************************)
-
module type MODIFIERS_HDR = sig
- module GhostProto: MODIFIERS_GHOST_PROTO
- val print_machine_decl_prefix: Format.formatter -> machine_t -> unit
- val pp_import_arrow: formatter -> unit -> unit
+ module GhostProto : MODIFIERS_GHOST_PROTO
+
+ val print_machine_decl_prefix : Format.formatter -> machine_t -> unit
+
+ val pp_import_arrow : formatter -> unit -> unit
end
module EmptyMod = struct
module GhostProto = EmptyGhostProto
- let print_machine_decl_prefix = fun _ _ -> ()
+
+ let print_machine_decl_prefix _ _ = ()
+
let pp_import_arrow fmt () =
fprintf fmt "#include \"%s/arrow.h%s\""
(Arrow.arrow_top_decl ()).top_decl_owner
(if !Options.cpp then "pp" else "")
end
-module Main = functor (Mod: MODIFIERS_HDR) -> struct
-
- module Protos = Protos(Mod.GhostProto)
-
- let print_import_standard fmt () =
- (* if Machine_types.has_machine_type () then *)
- fprintf fmt
- "#include <stdint.h>@,\
- %a\
- %a"
- (if !Options.mpfr then
- pp_print_endcut "#include <mpfr.h>"
- else pp_print_nothing) ()
- Mod.pp_import_arrow ()
-
- let rec print_static_val pp_var fmt v =
- match v.value_desc with
- | Cst c ->
- pp_c_const fmt c
- | Var v ->
- pp_var fmt v
- | Fun (n, vl) ->
- pp_basic_lib_fun (Types.is_int_type v.value_type) n
- (print_static_val pp_var) fmt vl
- | _ ->
- (* TODO: raise proper error *)
- eprintf "Internal error: C_backend_header.print_static_val";
- assert false
-
- let print_constant_decl (m, attr, inst) pp_var fmt v =
- fprintf fmt "%s %a = %a"
- attr
- (pp_c_type (sprintf "%s ## %s" inst v.var_id)) v.var_type
- (print_static_val pp_var) (get_const_assign m v)
-
- let pp_var inst const_locals fmt v =
- if List.mem v const_locals then
- fprintf fmt "%s ## %s" inst v.var_id
- else fprintf fmt "%s" v.var_id
-
- let print_static_constant_decl (_, _, inst as macro) fmt const_locals =
- pp_print_list ~pp_open_box:pp_open_vbox0
- ~pp_sep:(pp_print_endcut ";\\") ~pp_eol:(pp_print_endcut ";\\")
- (print_constant_decl macro (pp_var inst const_locals))
- fmt
- const_locals
-
- let print_static_declare_instance
- (m, attr, inst) const_locals fmt (i, (n, static)) =
- let values = List.map (value_of_dimension m) static in
- fprintf fmt "%a(%s, %a%s)"
- pp_machine_static_declare_name (node_name n)
- attr
- (pp_print_list ~pp_open_box:pp_open_hbox ~pp_sep:pp_print_comma
- ~pp_eol:pp_print_comma (print_static_val (pp_var inst const_locals)))
- values
- i
-
- let print_static_declare_macro fmt (m, attr, inst as macro) =
- let const_locals =
- List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
- let array_mem =
- List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
- fprintf fmt
- "@[<v 2>\
- #define %a(%s, %a%s)\\@,\
- %a%s %a %s;\\@,\
- %a%a;\
- @]"
- pp_machine_static_declare_name m.mname.node_id
- attr
- (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
- (pp_c_var_read m)) m.mstatic
- inst
- (* constants *)
- (print_static_constant_decl macro) const_locals
- attr
- (pp_machine_memtype_name ~ghost:false) m.mname.node_id
- inst
- (pp_print_list ~pp_open_box:pp_open_vbox0
- ~pp_sep:(pp_print_endcut ";\\") ~pp_eol:(pp_print_endcut ";\\")
- (pp_c_decl_local_var m)) array_mem
- (pp_print_list ~pp_open_box:pp_open_vbox0
- ~pp_sep:(pp_print_endcut ";\\")
- (fun fmt (i', m') ->
- let path = sprintf "%s ## _%s" inst i' in
- fprintf fmt "%a"
- (print_static_declare_instance macro const_locals)
- (path, m'))) m.minstances
-
- let print_static_link_instance fmt (i, (m, _)) =
- fprintf fmt "%a(%s)" pp_machine_static_link_name (node_name m) i
-
- (* Allocation of a node struct:
- - if node memory is an array/matrix/etc, we cast it to a pointer (see pp_registers_struct)
- *)
- let print_static_link_macro fmt (m, _, inst) =
- let array_mem = List.filter (fun v -> Types.is_array_type v.var_type)
- m.mmemory in
- fprintf fmt
- "@[<v>@[<v 2>\
- #define %a(%s) do {\\@,\
- %a%a;\\@]@,\
- } while (0)\
- @]"
- pp_machine_static_link_name m.mname.node_id
- inst
- (pp_print_list ~pp_open_box:pp_open_vbox0
- ~pp_sep:(pp_print_endcut ";\\") ~pp_eol:(pp_print_endcut ";\\")
- (fun fmt v ->
- fprintf fmt "%s._reg.%s = (%a*) &%s"
- inst
- v.var_id
- (fun fmt v -> pp_c_type "" fmt (Types.array_base_type v.var_type)) v
- v.var_id)) array_mem
- (pp_print_list ~pp_open_box:pp_open_vbox0
- ~pp_sep:(pp_print_endcut ";\\")
- (fun fmt (i',m') ->
- let path = sprintf "%s ## _%s" inst i' in
- fprintf fmt "%a;\\@,%s.%s = &%s"
- print_static_link_instance (path,m')
- inst
- i'
- path)) m.minstances
-
- let print_static_alloc_macro fmt (m, attr, inst) =
- fprintf fmt
- "@[<v>@[<v 2>\
- #define %a(%s, %a%s)\\@,\
- %a(%s, %a%s);\\@,\
- %a(%s);\
- @]@]"
- pp_machine_static_alloc_name m.mname.node_id
- attr
- (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
- (pp_c_var_read m)) m.mstatic
- inst
- pp_machine_static_declare_name m.mname.node_id
- attr
- (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
- (pp_c_var_read m)) m.mstatic
- inst
- pp_machine_static_link_name m.mname.node_id
- inst
-
- (* TODO: ACSL
- we do multiple things:
- - provide the semantics of the node as a predicate: function step and reset are associated to ACSL predicate
- - the node is associated to a refinement contract, wrt its ACSL sem
- - if the node is a regular node associated to a contract, print the contract as function contract.
- - do not print anything if this is a contract node
- *)
- let print_machine_alloc_decl fmt m =
- Mod.print_machine_decl_prefix fmt m;
- if not (fst (get_stateless_status m)) then
- if !Options.static_mem then
- (* Static allocation *)
- let macro = (m, mk_attribute m, mk_instance m) in
- fprintf fmt "%a@,%a@,%a"
- print_static_declare_macro macro
- print_static_link_macro macro
- print_static_alloc_macro macro
- else
- (* Dynamic allocation *)
- fprintf fmt "extern %a;@,extern %a"
- print_alloc_prototype (m.mname.node_id, m.mstatic)
- print_dealloc_prototype m.mname.node_id
-
- let print_machine_struct_top_decl_from_header fmt tdecl =
- let inode = imported_node_of_top tdecl in
- if not inode.nodei_stateless then
- (* Declare struct *)
- fprintf fmt "%a;"
- (pp_machine_memtype_name ~ghost:false) inode.nodei_id
-
- let print_stateless_C_prototype fmt (name, inputs, outputs) =
- let output =
- match outputs with
- | [hd] -> hd
- | _ -> assert false
- in
- fprintf fmt "%a %s %a"
- (pp_basic_c_type ~pp_c_basic_type_desc ~var_opt:None) output.var_type
- name
- (pp_print_parenthesized pp_c_decl_input_var) inputs
-
- let print_machine_decl_top_decl_from_header fmt tdecl =
- let inode = imported_node_of_top tdecl in
- (*Mod.print_machine_decl_prefix fmt m;*)
- let prototype = (inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs) in
- if inode.nodei_prototype = Some "C" then
- if inode.nodei_stateless then
- fprintf fmt "extern %a;" print_stateless_C_prototype prototype
- else begin
+module Main =
+functor
+ (Mod : MODIFIERS_HDR)
+ ->
+ struct
+ module Protos = Protos (Mod.GhostProto)
+
+ let print_import_standard fmt () =
+ (* if Machine_types.has_machine_type () then *)
+ fprintf fmt "#include <stdint.h>@,%a%a"
+ (if !Options.mpfr then pp_print_endcut "#include <mpfr.h>"
+ else pp_print_nothing)
+ () Mod.pp_import_arrow ()
+
+ let rec print_static_val pp_var fmt v =
+ match v.value_desc with
+ | Cst c ->
+ pp_c_const fmt c
+ | Var v ->
+ pp_var fmt v
+ | Fun (n, vl) ->
+ pp_basic_lib_fun
+ (Types.is_int_type v.value_type)
+ n (print_static_val pp_var) fmt vl
+ | _ ->
(* TODO: raise proper error *)
- Format.eprintf "internal error: print_machine_decl_top_decl_from_header";
+ eprintf "Internal error: C_backend_header.print_static_val";
assert false
- end
- else if inode.nodei_stateless then
- fprintf fmt "extern %a;" Protos.print_stateless_prototype prototype
- else
- let static_inputs = List.filter (fun v -> v.var_dec_const)
- inode.nodei_inputs in
- let used name =
- List.exists (fun v -> v.var_id = name)
- (inode.nodei_inputs @ inode.nodei_outputs) in
- let self = mk_new_name used "self" in
- let mem = mk_new_name used "mem" in
- let static_prototype = (inode.nodei_id, static_inputs) in
- fprintf fmt
- "extern %a;@,\
- extern %a;@,\
- extern %a;@,\
- extern %a;@,\
- extern %a;"
- (Protos.print_set_reset_prototype self mem) static_prototype
- (Protos.print_clear_reset_prototype self mem) static_prototype
- (Protos.print_init_prototype self) static_prototype
- (Protos.print_clear_prototype self) static_prototype
- (Protos.print_step_prototype self mem) prototype
-
- let print_const_top_decl fmt tdecl =
- let cdecl = const_of_top tdecl in
- fprintf fmt "extern %a;"
- (pp_c_type cdecl.const_id)
- (if !Options.mpfr && Types.(is_real_type (array_base_type cdecl.const_type))
- then Types.dynamic_type cdecl.const_type
- else cdecl.const_type)
-
- let rec pp_c_type_decl filename cpt var fmt tdecl =
- match tdecl with
- | Tydec_any ->
- assert false
- | Tydec_int ->
- fprintf fmt "int %s" var
- | Tydec_real when !Options.mpfr ->
- fprintf fmt "%s %s" Mpfr.mpfr_t var
- | Tydec_real ->
- fprintf fmt "double %s" var
- (* | Tydec_float -> fprintf fmt "float %s" var *)
- | Tydec_bool ->
- fprintf fmt "_Bool %s" var
- | Tydec_clock ty ->
- pp_c_type_decl filename cpt var fmt ty
- | Tydec_const c ->
- fprintf fmt "%s %s" c var
- | Tydec_array (d, ty) ->
- fprintf fmt "%a[%a]" (pp_c_type_decl filename cpt var) ty pp_c_dimension d
- | Tydec_enum tl ->
- incr cpt;
- fprintf fmt "enum _enum_%s_%d %a %s" (protect_filename filename) !cpt
- (pp_print_braced pp_print_string) tl var
- | Tydec_struct fl ->
- incr cpt;
- fprintf fmt "struct _struct_%s_%d %a %s" (protect_filename filename) !cpt
- (pp_print_braced ~pp_sep:pp_print_semicolon
- (fun fmt (label, tdesc) -> pp_c_type_decl filename cpt label fmt tdesc))
- fl var
- (* let print_type_definitions fmt filename =
- * let cpt_type = ref 0 in
- * Hashtbl.iter (fun typ decl ->
- * match typ with
- * | Tydec_const var ->
- * begin match decl.top_decl_desc with
- * | TypeDef tdef ->
- * fprintf fmt "typedef %a;@.@."
- * (pp_c_type_decl filename cpt_type var) tdef.tydef_desc
- * | _ -> assert false
- * end
- * | _ -> ()) type_table *)
-
- let reset_type_definitions, print_type_definition_top_decl_from_header =
- let cpt_type = ref 0 in
- (fun () -> cpt_type := 0),
- (fun filename fmt tdecl ->
- let typ = typedef_of_top tdecl in
- fprintf fmt "typedef %a;"
- (pp_c_type_decl filename cpt_type typ.tydef_id) typ.tydef_desc)
-
- (********************************************************************************************)
- (* MAIN Header Printing functions *)
- (********************************************************************************************)
-
- let print_alloc_header header_fmt basename _prog machines dependencies spec =
- (* Include once: start *)
- let baseNAME = file_to_module_name basename in
- fprintf header_fmt
- "@[<v>\
- %a@,\
- #ifndef _%s_alloc@,\
- #define _%s_alloc@,\
- @,\
- /* Import header from %s */@,\
- %a@,\
- @,\
- %a\
- %a\
- %a\
- #endif\
- @]"
-
- (* Print the svn version number and the supported C standard (C90 or C99) *)
- pp_print_version ()
-
- baseNAME baseNAME
-
- (* Import the header *)
- basename
- print_import_prototype
- {
- local = true;
- name = basename;
- content = [];
- is_stateful = true (* assuming it is staful *);
- }
-
- (* Print dependencies *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut "/* Import dependencies */")
- print_import_alloc_prototype
- ~pp_epilogue:pp_print_cutcut) dependencies
-
- (* Print the struct definitions of all machines. *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut "/* Struct definitions */")
- ~pp_sep:pp_print_cutcut
- print_machine_struct
- ~pp_epilogue:pp_print_cutcut) machines
-
- (* Print the prototypes of all machines *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut
- "/* Node allocation function/macro prototypes */")
- ~pp_sep:pp_print_cutcut
- print_machine_alloc_decl
- ~pp_epilogue:pp_print_cutcut) machines
- (* Include once: end *)
-
- (* Function called when compiling a lusi file and generating the associated C
- header. *)
- let print_header_from_header header_fmt basename header =
- (* Include once: start *)
- let baseNAME = file_to_module_name basename in
- let types = get_typedefs header in
- let consts = get_consts header in
- let nodes = get_imported_nodes header in
- let dependencies = get_dependencies header in
- reset_type_definitions ();
- fprintf header_fmt
- "@[<v>\
- %a@,\
- #ifndef _%s@,\
- #define _%s@,\
- @,\
- /* Import standard library */@,\
- %a@,\
- @,\
- %a\
- %a\
- %a\
- %a\
- %a\
- %a\
- #endif\
- @]@."
-
- (* Print the version number and the supported C standard (C90 or C99) *)
- pp_print_version ()
-
- baseNAME baseNAME
-
- (* imports standard library definitions (arrow) *)
- print_import_standard ()
-
- (* imports dependencies *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut "/* Import dependencies */")
- (fun fmt dep ->
- let local, name = dependency_of_top dep in
- print_import_prototype fmt
- {
- local;
- name;
- content = [];
- is_stateful = true (* assuming it is stateful *)
- })
- ~pp_epilogue:pp_print_cutcut)
- dependencies
-
- (* Print the type definitions from the type table *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut "/* Types definitions */")
- (print_type_definition_top_decl_from_header basename)
- ~pp_epilogue:pp_print_cutcut)
- types
-
- (* Print the global constant declarations. *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:
- (pp_print_endcut
- "/* Global constants (declarations, definitions are in C file) */")
- print_const_top_decl
- ~pp_epilogue:pp_print_cutcut)
- consts
-
- (* MPFR *)
- (if !Options.mpfr then
- fun fmt () -> fprintf fmt
- "/* Global initialization declaration */@,\
- extern %a;@,@,\
- /* Global clear declaration */@,\
- extern %a;@,@,"
- print_global_init_prototype baseNAME
- print_global_clear_prototype baseNAME
- else pp_print_nothing) ()
-
- (* Print the struct declarations of all machines. *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut "/* Struct declarations */")
- print_machine_struct_top_decl_from_header
- ~pp_epilogue:pp_print_cutcut)
- nodes
-
- (* Print the prototypes of all machines *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut "/* Nodes declarations */")
- ~pp_sep:pp_print_cutcut
- print_machine_decl_top_decl_from_header
- ~pp_epilogue:pp_print_cutcut)
- nodes
-
-end
+ let print_constant_decl (m, attr, inst) pp_var fmt v =
+ fprintf fmt "%s %a = %a" attr
+ (pp_c_type (sprintf "%s ## %s" inst v.var_id))
+ v.var_type (print_static_val pp_var) (get_const_assign m v)
+
+ let pp_var inst const_locals fmt v =
+ if List.mem v const_locals then fprintf fmt "%s ## %s" inst v.var_id
+ else fprintf fmt "%s" v.var_id
+
+ let print_static_constant_decl ((_, _, inst) as macro) fmt const_locals =
+ pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_sep:(pp_print_endcut ";\\")
+ ~pp_eol:(pp_print_endcut ";\\")
+ (print_constant_decl macro (pp_var inst const_locals))
+ fmt const_locals
+
+ let print_static_declare_instance (m, attr, inst) const_locals fmt
+ (i, (n, static)) =
+ let values = List.map (value_of_dimension m) static in
+ fprintf fmt "%a(%s, %a%s)" pp_machine_static_declare_name (node_name n)
+ attr
+ (pp_print_list ~pp_open_box:pp_open_hbox ~pp_sep:pp_print_comma
+ ~pp_eol:pp_print_comma
+ (print_static_val (pp_var inst const_locals)))
+ values i
+
+ let print_static_declare_macro fmt ((m, attr, inst) as macro) =
+ let const_locals =
+ List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals
+ in
+ let array_mem =
+ List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory
+ in
+ fprintf fmt "@[<v 2>#define %a(%s, %a%s)\\@,%a%s %a %s;\\@,%a%a;@]"
+ pp_machine_static_declare_name m.mname.node_id attr
+ (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
+ (pp_c_var_read m))
+ m.mstatic inst
+ (* constants *)
+ (print_static_constant_decl macro)
+ const_locals attr
+ (pp_machine_memtype_name ~ghost:false)
+ m.mname.node_id inst
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_sep:(pp_print_endcut ";\\") ~pp_eol:(pp_print_endcut ";\\")
+ (pp_c_decl_local_var m))
+ array_mem
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_sep:(pp_print_endcut ";\\") (fun fmt (i', m') ->
+ let path = sprintf "%s ## _%s" inst i' in
+ fprintf fmt "%a"
+ (print_static_declare_instance macro const_locals)
+ (path, m')))
+ m.minstances
+
+ let print_static_link_instance fmt (i, (m, _)) =
+ fprintf fmt "%a(%s)" pp_machine_static_link_name (node_name m) i
+
+ (* Allocation of a node struct: - if node memory is an array/matrix/etc, we
+ cast it to a pointer (see pp_registers_struct) *)
+ let print_static_link_macro fmt (m, _, inst) =
+ let array_mem =
+ List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory
+ in
+ fprintf fmt "@[<v>@[<v 2>#define %a(%s) do {\\@,%a%a;\\@]@,} while (0)@]"
+ pp_machine_static_link_name m.mname.node_id inst
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_sep:(pp_print_endcut ";\\") ~pp_eol:(pp_print_endcut ";\\")
+ (fun fmt v ->
+ fprintf fmt "%s._reg.%s = (%a*) &%s" inst v.var_id
+ (fun fmt v ->
+ pp_c_type "" fmt (Types.array_base_type v.var_type))
+ v v.var_id))
+ array_mem
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_sep:(pp_print_endcut ";\\") (fun fmt (i', m') ->
+ let path = sprintf "%s ## _%s" inst i' in
+ fprintf fmt "%a;\\@,%s.%s = &%s" print_static_link_instance
+ (path, m') inst i' path))
+ m.minstances
+
+ let print_static_alloc_macro fmt (m, attr, inst) =
+ fprintf fmt
+ "@[<v>@[<v 2>#define %a(%s, %a%s)\\@,%a(%s, %a%s);\\@,%a(%s);@]@]"
+ pp_machine_static_alloc_name m.mname.node_id attr
+ (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
+ (pp_c_var_read m))
+ m.mstatic inst pp_machine_static_declare_name m.mname.node_id attr
+ (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
+ (pp_c_var_read m))
+ m.mstatic inst pp_machine_static_link_name m.mname.node_id inst
+
+ (* TODO: ACSL we do multiple things: - provide the semantics of the node as
+ a predicate: function step and reset are associated to ACSL predicate -
+ the node is associated to a refinement contract, wrt its ACSL sem - if
+ the node is a regular node associated to a contract, print the contract
+ as function contract. - do not print anything if this is a contract node *)
+ let print_machine_alloc_decl fmt m =
+ Mod.print_machine_decl_prefix fmt m;
+ if not (fst (get_stateless_status m)) then
+ if !Options.static_mem then
+ (* Static allocation *)
+ let macro = m, mk_attribute m, mk_instance m in
+ fprintf fmt "%a@,%a@,%a" print_static_declare_macro macro
+ print_static_link_macro macro print_static_alloc_macro macro
+ else
+ (* Dynamic allocation *)
+ fprintf fmt "extern %a;@,extern %a" print_alloc_prototype
+ (m.mname.node_id, m.mstatic)
+ print_dealloc_prototype m.mname.node_id
+
+ let print_machine_struct_top_decl_from_header fmt tdecl =
+ let inode = imported_node_of_top tdecl in
+ if not inode.nodei_stateless then
+ (* Declare struct *)
+ fprintf fmt "%a;" (pp_machine_memtype_name ~ghost:false) inode.nodei_id
+
+ let print_stateless_C_prototype fmt (name, inputs, outputs) =
+ let output = match outputs with [ hd ] -> hd | _ -> assert false in
+ fprintf fmt "%a %s %a"
+ (pp_basic_c_type ~pp_c_basic_type_desc ~var_opt:None)
+ output.var_type name
+ (pp_print_parenthesized pp_c_decl_input_var)
+ inputs
+
+ let print_machine_decl_top_decl_from_header fmt tdecl =
+ let inode = imported_node_of_top tdecl in
+ (*Mod.print_machine_decl_prefix fmt m;*)
+ let prototype = inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs in
+ if inode.nodei_prototype = Some "C" then
+ if inode.nodei_stateless then
+ fprintf fmt "extern %a;" print_stateless_C_prototype prototype
+ else (
+ (* TODO: raise proper error *)
+ Format.eprintf
+ "internal error: print_machine_decl_top_decl_from_header";
+ assert false)
+ else if inode.nodei_stateless then
+ fprintf fmt "extern %a;" Protos.print_stateless_prototype prototype
+ else
+ let static_inputs =
+ List.filter (fun v -> v.var_dec_const) inode.nodei_inputs
+ in
+ let used name =
+ List.exists
+ (fun v -> v.var_id = name)
+ (inode.nodei_inputs @ inode.nodei_outputs)
+ in
+ let self = mk_new_name used "self" in
+ let mem = mk_new_name used "mem" in
+ let static_prototype = inode.nodei_id, static_inputs in
+ fprintf fmt "extern %a;@,extern %a;@,extern %a;@,extern %a;@,extern %a;"
+ (Protos.print_set_reset_prototype self mem)
+ static_prototype
+ (Protos.print_clear_reset_prototype self mem)
+ static_prototype
+ (Protos.print_init_prototype self)
+ static_prototype
+ (Protos.print_clear_prototype self)
+ static_prototype
+ (Protos.print_step_prototype self mem)
+ prototype
+
+ let print_const_top_decl fmt tdecl =
+ let cdecl = const_of_top tdecl in
+ fprintf fmt "extern %a;" (pp_c_type cdecl.const_id)
+ (if
+ !Options.mpfr
+ && Types.(is_real_type (array_base_type cdecl.const_type))
+ then Types.dynamic_type cdecl.const_type
+ else cdecl.const_type)
+
+ let rec pp_c_type_decl filename cpt var fmt tdecl =
+ match tdecl with
+ | Tydec_any ->
+ assert false
+ | Tydec_int ->
+ fprintf fmt "int %s" var
+ | Tydec_real when !Options.mpfr ->
+ fprintf fmt "%s %s" Mpfr.mpfr_t var
+ | Tydec_real ->
+ fprintf fmt "double %s" var
+ (* | Tydec_float -> fprintf fmt "float %s" var *)
+ | Tydec_bool ->
+ fprintf fmt "_Bool %s" var
+ | Tydec_clock ty ->
+ pp_c_type_decl filename cpt var fmt ty
+ | Tydec_const c ->
+ fprintf fmt "%s %s" c var
+ | Tydec_array (d, ty) ->
+ fprintf fmt "%a[%a]"
+ (pp_c_type_decl filename cpt var)
+ ty pp_c_dimension d
+ | Tydec_enum tl ->
+ incr cpt;
+ fprintf fmt "enum _enum_%s_%d %a %s"
+ (protect_filename filename)
+ !cpt
+ (pp_print_braced pp_print_string)
+ tl var
+ | Tydec_struct fl ->
+ incr cpt;
+ fprintf fmt "struct _struct_%s_%d %a %s"
+ (protect_filename filename)
+ !cpt
+ (pp_print_braced ~pp_sep:pp_print_semicolon (fun fmt (label, tdesc) ->
+ pp_c_type_decl filename cpt label fmt tdesc))
+ fl var
+
+ (* let print_type_definitions fmt filename =
+ * let cpt_type = ref 0 in
+ * Hashtbl.iter (fun typ decl ->
+ * match typ with
+ * | Tydec_const var ->
+ * begin match decl.top_decl_desc with
+ * | TypeDef tdef ->
+ * fprintf fmt "typedef %a;@.@."
+ * (pp_c_type_decl filename cpt_type var) tdef.tydef_desc
+ * | _ -> assert false
+ * end
+ * | _ -> ()) type_table *)
+
+ let reset_type_definitions, print_type_definition_top_decl_from_header =
+ let cpt_type = ref 0 in
+ ( (fun () -> cpt_type := 0),
+ fun filename fmt tdecl ->
+ let typ = typedef_of_top tdecl in
+ fprintf fmt "typedef %a;"
+ (pp_c_type_decl filename cpt_type typ.tydef_id)
+ typ.tydef_desc )
+
+ (********************************************************************************************)
+ (* MAIN Header Printing functions *)
+ (********************************************************************************************)
+
+ let print_alloc_header header_fmt basename _prog machines dependencies spec
+ =
+ (* Include once: start *)
+ let baseNAME = file_to_module_name basename in
+ fprintf header_fmt
+ "@[<v>%a@,\
+ #ifndef _%s_alloc@,\
+ #define _%s_alloc@,\
+ @,\
+ /* Import header from %s */@,\
+ %a@,\
+ @,\
+ %a%a%a#endif@]"
+ (* Print the svn version number and the supported C standard (C90 or
+ C99) *)
+ pp_print_version () baseNAME baseNAME (* Import the header *) basename
+ print_import_prototype
+ {
+ local = true;
+ name = basename;
+ content = [];
+ is_stateful = true (* assuming it is staful *);
+ }
+ (* Print dependencies *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut "/* Import dependencies */")
+ print_import_alloc_prototype ~pp_epilogue:pp_print_cutcut)
+ dependencies
+ (* Print the struct definitions of all machines. *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut "/* Struct definitions */")
+ ~pp_sep:pp_print_cutcut print_machine_struct
+ ~pp_epilogue:pp_print_cutcut)
+ machines
+ (* Print the prototypes of all machines *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:
+ (pp_print_endcut "/* Node allocation function/macro prototypes */")
+ ~pp_sep:pp_print_cutcut print_machine_alloc_decl
+ ~pp_epilogue:pp_print_cutcut)
+ machines
+ (* Include once: end *)
+
+ (* Function called when compiling a lusi file and generating the associated
+ C header. *)
+ let print_header_from_header header_fmt basename header =
+ (* Include once: start *)
+ let baseNAME = file_to_module_name basename in
+ let types = get_typedefs header in
+ let consts = get_consts header in
+ let nodes = get_imported_nodes header in
+ let dependencies = get_dependencies header in
+ reset_type_definitions ();
+ fprintf header_fmt
+ "@[<v>%a@,\
+ #ifndef _%s@,\
+ #define _%s@,\
+ @,\
+ /* Import standard library */@,\
+ %a@,\
+ @,\
+ %a%a%a%a%a%a#endif@]@."
+ (* Print the version number and the supported C standard (C90 or C99) *)
+ pp_print_version () baseNAME baseNAME
+ (* imports standard library definitions (arrow) *)
+ print_import_standard ()
+ (* imports dependencies *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut "/* Import dependencies */")
+ (fun fmt dep ->
+ let local, name = dependency_of_top dep in
+ print_import_prototype fmt
+ {
+ local;
+ name;
+ content = [];
+ is_stateful = true (* assuming it is stateful *);
+ })
+ ~pp_epilogue:pp_print_cutcut)
+ dependencies
+ (* Print the type definitions from the type table *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut "/* Types definitions */")
+ (print_type_definition_top_decl_from_header basename)
+ ~pp_epilogue:pp_print_cutcut)
+ types
+ (* Print the global constant declarations. *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:
+ (pp_print_endcut
+ "/* Global constants (declarations, definitions are in C file) \
+ */")
+ print_const_top_decl ~pp_epilogue:pp_print_cutcut)
+ consts
+ (* MPFR *)
+ (if !Options.mpfr then fun fmt () ->
+ fprintf fmt
+ "/* Global initialization declaration */@,\
+ extern %a;@,\
+ @,\
+ /* Global clear declaration */@,\
+ extern %a;@,\
+ @,"
+ print_global_init_prototype baseNAME print_global_clear_prototype
+ baseNAME
+ else pp_print_nothing)
+ ()
+ (* Print the struct declarations of all machines. *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut "/* Struct declarations */")
+ print_machine_struct_top_decl_from_header
+ ~pp_epilogue:pp_print_cutcut)
+ nodes
+ (* Print the prototypes of all machines *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut "/* Nodes declarations */")
+ ~pp_sep:pp_print_cutcut print_machine_decl_top_decl_from_header
+ ~pp_epilogue:pp_print_cutcut)
+ nodes
+ end
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
(* End: *)
diff --git a/src/backends/C/c_backend_main.ml b/src/backends/C/c_backend_main.ml
index b66d794ccaa6f21e7c0b1ec86046b55f42c3a22c..c0fd5904f36a652cecbf5d418b60a571ea8e6d6a 100644
--- a/src/backends/C/c_backend_main.ml
+++ b/src/backends/C/c_backend_main.ml
@@ -16,371 +16,319 @@ open Utils.Format
open C_backend_common
open Utils
-module type MODIFIERS_MAINSRC = sig
-end
+module type MODIFIERS_MAINSRC = sig end
-module EmptyMod = struct
-end
+module EmptyMod = struct end
-module Main = functor (Mod: MODIFIERS_MAINSRC) -> struct
+module Main =
+functor
+ (Mod : MODIFIERS_MAINSRC)
+ ->
+ struct
+ (********************************************************************************************)
+ (* Main related functions *)
+ (********************************************************************************************)
- (********************************************************************************************)
- (* Main related functions *)
- (********************************************************************************************)
+ let pp_c_main_var_input fmt id = fprintf fmt "%s" id.var_id
- let pp_c_main_var_input fmt id =
- fprintf fmt "%s" id.var_id
+ let pp_c_main_var_output fmt id =
+ if Types.is_address_type id.var_type then fprintf fmt "%s" id.var_id
+ else fprintf fmt "&%s" id.var_id
- let pp_c_main_var_output fmt id =
- if Types.is_address_type id.var_type
- then
- fprintf fmt "%s" id.var_id
- else
- fprintf fmt "&%s" id.var_id
+ let print_put_output fmt id o' o =
+ let suff = string_of_int (id + 1) in
+ print_put_var fmt suff o'.var_id o.var_type o.var_id
- let print_put_output fmt id o' o =
- let suff = string_of_int (id + 1) in
- print_put_var fmt suff o'.var_id o.var_type o.var_id
-
- let print_main_inout_declaration fmt m =
- fprintf fmt
- "/* Declaration of inputs/outputs variables */@,\
- %a%a\
- @[<v 2>if (traces) {@,\
- %a%a@]@,\
- }"
- (pp_print_list_i
- ~pp_open_box:pp_open_vbox0
- ~pp_epilogue:pp_print_cut
- (fun fmt idx v ->
- fprintf fmt "%a; %a"
- (pp_c_type v.var_id) v.var_type
- (fun fmt () -> pp_file_decl fmt "in" idx) ())) m.mstep.step_inputs
- (pp_print_list_i
- ~pp_open_box:pp_open_vbox0
- ~pp_epilogue:pp_print_cut
- (fun fmt idx v ->
- fprintf fmt "%a; %a"
- (pp_c_type v.var_id) v.var_type
- (fun fmt () -> pp_file_decl fmt "out" idx) ())) m.mstep.step_outputs
- (pp_print_list_i
- ~pp_epilogue:pp_print_cut
- (fun fmt idx _ ->
- ignore (pp_file_open fmt "in" idx))) m.mstep.step_inputs
- (pp_print_list_i
- (fun fmt idx _ ->
- ignore (pp_file_open fmt "out" idx))) m.mstep.step_outputs
-
- let print_main_memory_allocation mname main_mem fmt m =
- if not (fst (get_stateless_status m)) then
+ let print_main_inout_declaration fmt m =
fprintf fmt
- "@[<v>/* Main memory allocation */@,\
- %a@,\
+ "/* Declaration of inputs/outputs variables */@,\
+ %a%a@[<v 2>if (traces) {@,\
+ %a%a@]@,\
+ }"
+ (pp_print_list_i ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
+ (fun fmt idx v ->
+ fprintf fmt "%a; %a" (pp_c_type v.var_id) v.var_type
+ (fun fmt () -> pp_file_decl fmt "in" idx)
+ ()))
+ m.mstep.step_inputs
+ (pp_print_list_i ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
+ (fun fmt idx v ->
+ fprintf fmt "%a; %a" (pp_c_type v.var_id) v.var_type
+ (fun fmt () -> pp_file_decl fmt "out" idx)
+ ()))
+ m.mstep.step_outputs
+ (pp_print_list_i ~pp_epilogue:pp_print_cut (fun fmt idx _ ->
+ ignore (pp_file_open fmt "in" idx)))
+ m.mstep.step_inputs
+ (pp_print_list_i (fun fmt idx _ -> ignore (pp_file_open fmt "out" idx)))
+ m.mstep.step_outputs
+
+ let print_main_memory_allocation mname main_mem fmt m =
+ if not (fst (get_stateless_status m)) then
+ fprintf fmt
+ "@[<v>/* Main memory allocation */@,\
+ %a@,\
+ @,\
+ /* Initialize the main memory */@,\
+ %a(%s);@]"
+ (fun fmt () ->
+ if !Options.static_mem && !Options.main_node <> "" then
+ fprintf fmt "%a(static,main_mem);" pp_machine_static_alloc_name
+ mname
+ else
+ fprintf fmt "%a *main_mem = %a();"
+ (pp_machine_memtype_name ~ghost:false)
+ mname pp_machine_alloc_name mname)
+ () pp_machine_set_reset_name mname main_mem
+
+ let print_global_initialize fmt basename =
+ let mNAME = file_to_module_name basename in
+ fprintf fmt "/* Initialize global constants */@,%a();" pp_global_init_name
+ mNAME
+
+ let print_global_clear fmt basename =
+ let mNAME = file_to_module_name basename in
+ fprintf fmt "/* Clear global constants */@,%a();" pp_global_clear_name
+ mNAME
+
+ let print_main_initialize mname main_mem fmt m =
+ let inputs = mpfr_vars m.mstep.step_inputs in
+ let outputs = mpfr_vars m.mstep.step_outputs in
+ if not (fst (get_stateless_status m)) then
+ fprintf fmt "/* Initialize inputs, outputs and memories */@,%a%a%a(%s);"
+ (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_eol:pp_print_cut
+ (pp_initialize m main_mem (pp_c_var_read m)))
+ inputs
+ (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_eol:pp_print_cut
+ (pp_initialize m main_mem (pp_c_var_read m)))
+ outputs pp_machine_init_name mname main_mem
+ else
+ fprintf fmt "/* Initialize inputs and outputs */@,%a%a@ "
+ (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_eol:pp_print_cut
+ (pp_initialize m main_mem (pp_c_var_read m)))
+ inputs
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_initialize m main_mem (pp_c_var_read m)))
+ outputs
+
+ let print_main_clear mname main_mem fmt m =
+ let inputs = mpfr_vars m.mstep.step_inputs in
+ let outputs = mpfr_vars m.mstep.step_outputs in
+ if not (fst (get_stateless_status m)) then
+ fprintf fmt
+ "@[<v>/* Clear inputs, outputs and memories */@,%a%a%a(%s);@]"
+ (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_eol:pp_print_cut
+ (pp_clear m main_mem (pp_c_var_read m)))
+ inputs
+ (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_eol:pp_print_cut
+ (pp_clear m main_mem (pp_c_var_read m)))
+ outputs pp_machine_clear_name mname main_mem
+ else
+ fprintf fmt "@[<v>/* Clear inputs and outputs */@,%a%a@]"
+ (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_eol:pp_print_cut
+ (pp_clear m main_mem (pp_c_var_read m)))
+ inputs
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_clear m main_mem (pp_c_var_read m)))
+ outputs
+
+ let print_get_input fmt id v' v =
+ let pp_file = pp_print_file ("in" ^ string_of_int (id + 1)) in
+ let unclocked_t = Types.unclock_type v.var_type in
+ fprintf fmt "@[<v>%a@]"
+ (fun fmt () ->
+ if Types.is_int_type unclocked_t then
+ fprintf fmt "%s = _get_int(\"%s\");@,%a" v.var_id v'.var_id pp_file
+ ("d", v.var_id)
+ else if Types.is_bool_type unclocked_t then
+ fprintf fmt "%s = _get_bool(\"%s\");@,%a" v.var_id v'.var_id pp_file
+ ("i", v.var_id)
+ else if Types.is_real_type unclocked_t then
+ if !Options.mpfr then
+ fprintf fmt
+ "double %s_tmp = _get_double(\"%s\");@,\
+ %a@,\
+ mpfr_set_d(%s, %s_tmp, %i);" v.var_id v'.var_id pp_file
+ ("f", v.var_id ^ "_tmp")
+ v.var_id v.var_id (Mpfr.mpfr_prec ())
+ else
+ fprintf fmt "%s = _get_double(\"%s\");@,%a" v.var_id v'.var_id
+ pp_file ("f", v.var_id)
+ else (
+ Global.main_node := !Options.main_node;
+ eprintf "Code generation error: %a%a@." Error.pp_error_msg
+ Error.Main_wrong_kind Location.pp_loc v'.var_loc;
+ raise (Error.Error (v'.var_loc, Error.Main_wrong_kind))))
+ ()
+
+ let pp_main_call mname self fmt m (inputs : value_t list)
+ (outputs : var_decl list) =
+ if fst (Machine_code_common.get_stateless_status m) then
+ fprintf fmt "%a (%a%a);" pp_machine_step_name mname
+ (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
+ (pp_c_val m self pp_c_main_var_input))
+ inputs
+ (pp_print_list ~pp_sep:pp_print_comma pp_c_main_var_output)
+ outputs
+ else
+ fprintf fmt "%a (%a%a%s);" pp_machine_step_name mname
+ (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
+ (pp_c_val m self pp_c_main_var_input))
+ inputs
+ (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
+ pp_c_main_var_output)
+ outputs self
+
+ let print_main_loop mname main_mem fmt m =
+ let input_values =
+ List.map (fun v -> mk_val (Var v) v.var_type) m.mstep.step_inputs
+ in
+ fprintf fmt
+ "ISATTY = isatty(0);@,\
@,\
- /* Initialize the main memory */@,\
- %a(%s);@]"
+ /* Infinite loop */@,\
+ @[<v 2>while(1){@,\
+ fflush(stdout);@,\
+ @[<v 2>if (traces) {@,\
+ %a%a@]@,\
+ }@,\
+ %a%a%a"
+ (pp_print_list_i ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
+ (fun fmt idx _ -> fprintf fmt "fflush(f_in%i);" (idx + 1)))
+ m.mstep.step_inputs
+ (pp_print_list_i ~pp_open_box:pp_open_vbox0 (fun fmt idx _ ->
+ fprintf fmt "fflush(f_out%i);" (idx + 1)))
+ m.mstep.step_outputs
+ (pp_print_list_i2 ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
+ print_get_input)
+ (m.mname.node_inputs, m.mstep.step_inputs)
(fun fmt () ->
- if !Options.static_mem && !Options.main_node <> "" then
- fprintf fmt "%a(static,main_mem);"
- pp_machine_static_alloc_name mname
- else
- fprintf fmt "%a *main_mem = %a();"
- (pp_machine_memtype_name ~ghost:false) mname
- pp_machine_alloc_name mname) ()
- pp_machine_set_reset_name mname
- main_mem
-
- let print_global_initialize fmt basename =
- let mNAME = file_to_module_name basename in
- fprintf fmt "/* Initialize global constants */@,%a();"
- pp_global_init_name mNAME
+ pp_main_call mname main_mem fmt m input_values m.mstep.step_outputs)
+ ()
+ (pp_print_list_i2 ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut
+ print_put_output)
+ (m.mname.node_outputs, m.mstep.step_outputs)
- let print_global_clear fmt basename =
- let mNAME = file_to_module_name basename in
- fprintf fmt "/* Clear global constants */@,%a();"
- pp_global_clear_name mNAME
-
- let print_main_initialize mname main_mem fmt m =
- let inputs = mpfr_vars m.mstep.step_inputs in
- let outputs = mpfr_vars m.mstep.step_outputs in
- if not (fst (get_stateless_status m))
- then
+ let print_usage fmt () =
fprintf fmt
- "/* Initialize inputs, outputs and memories */@,\
- %a%a%a(%s);"
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_eol:pp_print_cut
- (pp_initialize m main_mem (pp_c_var_read m))) inputs
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_eol:pp_print_cut
- (pp_initialize m main_mem (pp_c_var_read m))) outputs
- pp_machine_init_name mname
- main_mem
- else
+ "@[<v 2>void usage(char *argv[]) {@,\
+ printf(\"Usage: %%s\\n\", argv[0]);@,\
+ printf(\" -t: produce trace files for input/output flows\\n\");@,\
+ printf(\" -d<dir>: directory containing traces (default: \
+ _traces)\\n\");@,\
+ printf(\" -p<prefix>: prefix_simu.scope<id> (default: \
+ file_node)\\n\");@,\
+ exit (8);@]@,\
+ }"
+
+ let print_options fmt name =
fprintf fmt
- "/* Initialize inputs and outputs */@,\
- %a%a@ "
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_eol:pp_print_cut
- (pp_initialize m main_mem (pp_c_var_read m))) inputs
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- (pp_initialize m main_mem (pp_c_var_read m))) outputs
+ "@[<v>int traces = 0;@,\
+ char* prefix = \"%s\";@,\
+ char* dir = \".\";@,\
+ @[<v 2>while ((argc > 1) && (argv[1][0] == '-')) {@,\
+ @[<v 2>switch (argv[1][1]) {@,\
+ @[<v 2>case 't':@,\
+ traces = 1;@,\
+ break;@,\
+ @]@,\
+ @[<v 2>case 'd':@,\
+ dir = &argv[1][2];@,\
+ break;@,\
+ @]@,\
+ @[<v 2>case 'p':@,\
+ prefix = &argv[1][2];@,\
+ break;@,\
+ @]@,\
+ @[<v 2>default:@,\
+ printf(\"Wrong Argument: %%s\\n\", argv[1]);@,\
+ usage(argv);@]@]@,\
+ }@,\
+ ++argv;@,\
+ --argc;@]@,\
+ }@]"
+ name
+
+ let print_main_code fmt (basename, m) =
+ let mname = m.mname.node_id in
+ (* TODO: find a proper way to shorthen long names. This causes segfault in
+ the binary when trying to fprintf in them *)
+ let mname =
+ if String.length mname > 50 then string_of_int (Hashtbl.hash mname)
+ else mname
+ in
+ let main_mem =
+ if !Options.static_mem && !Options.main_node <> "" then "&main_mem"
+ else "main_mem"
+ in
- let print_main_clear mname main_mem fmt m =
- let inputs = mpfr_vars m.mstep.step_inputs in
- let outputs = mpfr_vars m.mstep.step_outputs in
- if not (fst (get_stateless_status m))
- then
- fprintf fmt
- "@[<v>/* Clear inputs, outputs and memories */@,\
- %a%a%a(%s);@]"
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_eol:pp_print_cut
- (pp_clear m main_mem (pp_c_var_read m))) inputs
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_eol:pp_print_cut
- (pp_clear m main_mem (pp_c_var_read m))) outputs
- pp_machine_clear_name mname
- main_mem
- else
fprintf fmt
- "@[<v>/* Clear inputs and outputs */@,\
- %a%a@]"
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_eol:pp_print_cut
- (pp_clear m main_mem (pp_c_var_read m))) inputs
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- (pp_clear m main_mem (pp_c_var_read m))) outputs
-
-let print_get_input fmt id v' v =
- let pp_file = pp_print_file ("in" ^ string_of_int (id + 1)) in
- let unclocked_t = Types.unclock_type v.var_type in
- fprintf fmt "@[<v>%a@]"
- (fun fmt () ->
- if Types.is_int_type unclocked_t then
- fprintf fmt "%s = _get_int(\"%s\");@,%a"
- v.var_id v'.var_id
- pp_file ("d", v.var_id)
- else if Types.is_bool_type unclocked_t then
- fprintf fmt "%s = _get_bool(\"%s\");@,%a"
- v.var_id v'.var_id
- pp_file ("i", v.var_id)
- else if Types.is_real_type unclocked_t then
- if !Options.mpfr then
- fprintf fmt "double %s_tmp = _get_double(\"%s\");@,\
- %a@,\
- mpfr_set_d(%s, %s_tmp, %i);"
- v.var_id v'.var_id
- pp_file ("f", v.var_id ^ "_tmp")
- v.var_id v.var_id (Mpfr.mpfr_prec ())
- else
- fprintf fmt "%s = _get_double(\"%s\");@,%a"
- v.var_id v'.var_id
- pp_file ("f", v.var_id)
- else begin
- Global.main_node := !Options.main_node;
- eprintf "Code generation error: %a%a@."
- Error.pp_error_msg Error.Main_wrong_kind
- Location.pp_loc v'.var_loc;
- raise (Error.Error (v'.var_loc, Error.Main_wrong_kind))
- end) ()
-
-let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) =
- if fst (Machine_code_common.get_stateless_status m)
- then
- fprintf fmt "%a (%a%a);"
- pp_machine_step_name mname
- (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
- (pp_c_val m self pp_c_main_var_input)) inputs
- (pp_print_list ~pp_sep:pp_print_comma pp_c_main_var_output) outputs
- else
- fprintf fmt "%a (%a%a%s);"
- pp_machine_step_name mname
- (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
- (pp_c_val m self pp_c_main_var_input)) inputs
- (pp_print_list ~pp_sep:pp_print_comma ~pp_eol:pp_print_comma
- pp_c_main_var_output) outputs
- self
-
- let print_main_loop mname main_mem fmt m =
- let input_values = List.map (fun v ->
- mk_val (Var v) v.var_type) m.mstep.step_inputs in
- fprintf fmt
- "ISATTY = isatty(0);@,\
- @,\
- /* Infinite loop */@,\
- @[<v 2>while(1){@,\
- fflush(stdout);@,\
- @[<v 2>if (traces) {@,\
- %a%a\
- @]@,\
- }@,\
- %a%a%a"
-
- (pp_print_list_i
- ~pp_open_box:pp_open_vbox0
- ~pp_epilogue:pp_print_cut
- (fun fmt idx _ -> fprintf fmt "fflush(f_in%i);" (idx + 1)))
- m.mstep.step_inputs
-
- (pp_print_list_i
- ~pp_open_box:pp_open_vbox0
- (fun fmt idx _ -> fprintf fmt "fflush(f_out%i);" (idx + 1)))
- m.mstep.step_outputs
-
- (pp_print_list_i2
- ~pp_open_box:pp_open_vbox0
- ~pp_epilogue:pp_print_cut
- print_get_input)
- (m.mname.node_inputs, m.mstep.step_inputs)
-
- (fun fmt () ->
- pp_main_call mname main_mem fmt m input_values m.mstep.step_outputs) ()
-
- (pp_print_list_i2
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:pp_print_cut
- print_put_output)
- (m.mname.node_outputs, m.mstep.step_outputs)
-
- let print_usage fmt () =
- fprintf fmt
- "@[<v 2>\
- void usage(char *argv[]) {@,\
- printf(\"Usage: %%s\\n\", argv[0]);@,\
- printf(\" -t: produce trace files for input/output flows\\n\");@,\
- printf(\" -d<dir>: directory containing traces (default: _traces)\\n\");@,\
- printf(\" -p<prefix>: prefix_simu.scope<id> (default: file_node)\\n\");@,\
- exit (8);@]@,\
- }"
-
- let print_options fmt name =
- fprintf fmt
- "@[<v>int traces = 0;@,\
- char* prefix = \"%s\";@,\
- char* dir = \".\";@,\
- @[<v 2>while ((argc > 1) && (argv[1][0] == '-')) {@,\
- @[<v 2>switch (argv[1][1]) {@,\
- @[<v 2>case 't':@,\
- traces = 1;@,\
- break;@,\
- @]@,\
- @[<v 2>case 'd':@,\
- dir = &argv[1][2];@,\
- break;@,\
- @]@,\
- @[<v 2>case 'p':@,\
- prefix = &argv[1][2];@,\
- break;@,\
- @]@,\
- @[<v 2>default:@,\
- printf(\"Wrong Argument: %%s\\n\", argv[1]);@,\
- usage(argv);@]@]@,\
- }@,\
- ++argv;@,\
- --argc;@]@,\
- }@]"
- name
-
- let print_main_code fmt (basename, m) =
- let mname = m.mname.node_id in
- (* TODO: find a proper way to shorthen long names. This causes segfault in the binary when trying to fprintf in them *)
- let mname = if String.length mname > 50
- then string_of_int (Hashtbl.hash mname) else mname in
- let main_mem =
- if !Options.static_mem && !Options.main_node <> ""
- then "&main_mem"
- else "main_mem" in
-
- fprintf fmt
- "@[<v>\
- %a@,\
- @,\
- @[<v 2>int main (int argc, char *argv[]) {@,\
- %a@,\
- @,\
- %a@,\
- %a@,\
- %a@,\
- %a@,\
- %a@,\
- %a@]@,\
- }@,\
- %areturn 1;@]@,}@]@."
-
- print_usage ()
-
- print_options (basename ^ "_" ^ mname)
-
- print_main_inout_declaration m
-
- (Plugins.c_backend_main_loop_body_prefix basename mname) ()
-
- (print_main_memory_allocation mname main_mem) m
-
- (fun fmt () ->
- if !Options.mpfr then
- fprintf fmt "@[<v>%a@,%a@]@,"
- print_global_initialize basename
- (print_main_initialize mname main_mem) m) ()
-
- (print_main_loop mname main_mem) m
-
- Plugins.c_backend_main_loop_body_suffix ()
-
- (fun fmt () ->
- if !Options.mpfr then
- fprintf fmt "@[<v>%a@,%a@]@,"
- (print_main_clear mname main_mem) m
- print_global_clear basename) ()
-
- let print_main_header fmt () =
- fprintf fmt
- "@[<v>#include <stdio.h>@,\
- #include <unistd.h>@,\
- %a@]"
- (fun fmt () -> fprintf fmt
- (if !Options.cpp then
- "#include \"%s/io_frontend.hpp\""
- else
- "#include <string.h>@,\
- #include \"%s/io_frontend.h\"")
- (Options_management.core_dependency "io_frontend")) ()
-
- let print_main_c main_fmt main_machine basename _prog _machines _dependencies =
- fprintf main_fmt
- "@[<v>\
- %a@,\
- #include <stdlib.h>@,\
- #include <assert.h>@,\
- %a@,\
- @,\
- %a@,\
- %a
- @]@."
- print_main_header ()
- print_import_alloc_prototype
- {
- local = true;
- name = basename;
- content = [];
- is_stateful = true (* assuming it is stateful*)
- }
-
- (* Print the svn version number and the supported C standard (C90 or C99) *)
- pp_print_version ()
-
- print_main_code (basename, main_machine)
-
-end
+ "@[<v>%a@,\
+ @,\
+ @[<v 2>int main (int argc, char *argv[]) {@,\
+ %a@,\
+ @,\
+ %a@,\
+ %a@,\
+ %a@,\
+ %a@,\
+ %a@,\
+ %a@]@,\
+ }@,\
+ %areturn 1;@]@,\
+ }@]@."
+ print_usage () print_options
+ (basename ^ "_" ^ mname)
+ print_main_inout_declaration m
+ (Plugins.c_backend_main_loop_body_prefix basename mname)
+ ()
+ (print_main_memory_allocation mname main_mem)
+ m
+ (fun fmt () ->
+ if !Options.mpfr then
+ fprintf fmt "@[<v>%a@,%a@]@," print_global_initialize basename
+ (print_main_initialize mname main_mem)
+ m)
+ ()
+ (print_main_loop mname main_mem)
+ m Plugins.c_backend_main_loop_body_suffix ()
+ (fun fmt () ->
+ if !Options.mpfr then
+ fprintf fmt "@[<v>%a@,%a@]@,"
+ (print_main_clear mname main_mem)
+ m print_global_clear basename)
+ ()
+
+ let print_main_header fmt () =
+ fprintf fmt "@[<v>#include <stdio.h>@,#include <unistd.h>@,%a@]"
+ (fun fmt () ->
+ fprintf fmt
+ (if !Options.cpp then "#include \"%s/io_frontend.hpp\""
+ else "#include <string.h>@,#include \"%s/io_frontend.h\"")
+ (Options_management.core_dependency "io_frontend"))
+ ()
+
+ let print_main_c main_fmt main_machine basename _prog _machines
+ _dependencies =
+ fprintf main_fmt
+ "@[<v>%a@,\
+ #include <stdlib.h>@,\
+ #include <assert.h>@,\
+ %a@,\
+ @,\
+ %a@,\
+ %a\n\
+ \ @]@." print_main_header () print_import_alloc_prototype
+ {
+ local = true;
+ name = basename;
+ content = [];
+ is_stateful = true (* assuming it is stateful*);
+ }
+ (* Print the svn version number and the supported C standard (C90 or
+ C99) *)
+ pp_print_version () print_main_code (basename, main_machine)
+ end
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
diff --git a/src/backends/C/c_backend_makefile.ml b/src/backends/C/c_backend_makefile.ml
index 1b4471649f63ccf2feb6c4ee99a619508c164ff9..717d686b961fa30f4bc54531618ce237078e8423 100644
--- a/src/backends/C/c_backend_makefile.ml
+++ b/src/backends/C/c_backend_makefile.ml
@@ -13,115 +13,126 @@ open Format
open Lustre_types
let pp_dep fmt dep =
- Format.fprintf fmt "%b, %s, {%a}, %b"
- dep.local dep.name Printers.pp_prog dep.content dep.is_stateful
-
-let pp_deps fmt deps = Format.fprintf fmt "@[<v 0>%a@ @]" (Utils.fprintf_list ~sep:"@ ," pp_dep) deps
+ Format.fprintf fmt "%b, %s, {%a}, %b" dep.local dep.name Printers.pp_prog
+ dep.content dep.is_stateful
+
+let pp_deps fmt deps =
+ Format.fprintf fmt "@[<v 0>%a@ @]" (Utils.fprintf_list ~sep:"@ ," pp_dep) deps
let header_has_code header =
- List.exists
- (fun top ->
+ List.exists
+ (fun top ->
match top.top_decl_desc with
- | Const _ -> true
- | ImportedNode nd -> nd.nodei_in_lib = []
- | _ -> false
- )
+ | Const _ ->
+ true
+ | ImportedNode nd ->
+ nd.nodei_in_lib = []
+ | _ ->
+ false)
header
let header_libs header =
- List.fold_left (fun accu top ->
- match top.top_decl_desc with
- | ImportedNode nd -> Utils.list_union nd.nodei_in_lib accu
- | _ -> accu
- ) [] header
-
-
-let compiled_dependencies deps =
+ List.fold_left
+ (fun accu top ->
+ match top.top_decl_desc with
+ | ImportedNode nd ->
+ Utils.list_union nd.nodei_in_lib accu
+ | _ ->
+ accu)
+ [] header
+
+let compiled_dependencies deps =
List.filter (fun dep -> header_has_code dep.content) deps
-let lib_dependencies deps =
- List.fold_left
- (fun accu dep -> Utils.list_union (header_libs dep.content) accu) [] deps
-
-let fprintf_dependencies fmt (deps: dep_t list) =
+let lib_dependencies deps =
+ List.fold_left
+ (fun accu dep -> Utils.list_union (header_libs dep.content) accu)
+ [] deps
+
+let fprintf_dependencies fmt (deps : dep_t list) =
(* Format.eprintf "Deps: %a@." pp_deps dep; *)
let compiled_deps = compiled_dependencies deps in
+
(* Format.eprintf "Compiled Deps: %a@." pp_deps compiled_dep; *)
-
- List.iter (fun s -> Log.report ~level:1 (fun fmt -> fprintf fmt "Adding dependency: %s@." s);
- fprintf fmt "\t${GCC} -I${INC} -c %s@." s)
- (("${INC}/io_frontend.c"):: (* IO functions when a main function is computed *)
- (List.map
- (fun dep ->
- (if dep.local then dep.name else Version.include_path ^ "/" ^ dep.name) ^ ".c")
- compiled_deps))
-
-module type MODIFIERS_MKF =
-sig (* dep was (bool * ident * top_decl list) *)
- val other_targets: Format.formatter -> string -> string -> dep_t list -> unit
+ List.iter
+ (fun s ->
+ Log.report ~level:1 (fun fmt -> fprintf fmt "Adding dependency: %s@." s);
+ fprintf fmt "\t${GCC} -I${INC} -c %s@." s)
+ ("${INC}/io_frontend.c"
+ ::
+ (* IO functions when a main function is computed *)
+ List.map
+ (fun dep ->
+ (if dep.local then dep.name else Version.include_path ^ "/" ^ dep.name)
+ ^ ".c")
+ compiled_deps)
+
+module type MODIFIERS_MKF = sig
+ (* dep was (bool * ident * top_decl list) *)
+ val other_targets : Format.formatter -> string -> string -> dep_t list -> unit
end
-module EmptyMod =
-(struct
+module EmptyMod : MODIFIERS_MKF = struct
let other_targets _ _ _ _ = ()
-end: MODIFIERS_MKF)
-
-module Main = functor (Mod: MODIFIERS_MKF) ->
-struct
-
-(* TODO: BEWARE OF THE BUG !! in case of very long nodename or maybe even
- basename, the string basename_nodename exceed a limit length for files on linux
- and prevent gcc to generate the binary of that name.
-
-To be solved (later) with
-- either the default name if it short
-- a shorter version if it is long (md5?)
-- a provided name given when calling the makefile so the user can control the
- expected name of the binary
-
-*)
-
- let print_makefile basename nodename (dependencies: dep_t list) fmt =
- let binname =
- let s = basename ^ "_" ^ nodename in
- if String.length s > 100 (* seems that GCC fails from 144 characters and
- on: File name too long collect2 ld error. *)
- then
- if String.length nodename > 100 then
- basename ^ "_run" (* shorter version *)
- else
- nodename ^ "run"
- else
- s
- in
- fprintf fmt "BINNAME?=%s@." binname;
- fprintf fmt "GCC=gcc -O0@.";
- fprintf fmt "LUSTREC=%s@." Sys.executable_name;
- fprintf fmt "LUSTREC_BASE=%s@." (Filename.dirname (Filename.dirname Sys.executable_name));
- fprintf fmt "INC=%s@." Version.include_path (*"${LUSTREC_BASE}/include/lustrec"*);
- fprintf fmt "@.";
-
- (* Main binary *)
- fprintf fmt "%s_%s: %s.c %s_main.c@." basename "run"(*nodename*) basename basename;
- fprintf fmt "\t${GCC} -I${INC} -I. -c %s.c@." basename;
- fprintf fmt "\t${GCC} -I${INC} -I. -c %s_main.c@." basename;
- fprintf_dependencies fmt dependencies;
- fprintf fmt "\t${GCC} -o ${BINNAME} io_frontend.o %a %s.o %s_main.o %a@."
- (Utils.fprintf_list ~sep:" " (fun fmt dep -> Format.fprintf fmt "%s.o" dep.name))
- (compiled_dependencies dependencies)
- basename (* library .o *)
- basename (* main function . o *)
- (Utils.fprintf_list ~sep:" " (fun fmt lib -> fprintf fmt "-l%s" lib)) (lib_dependencies dependencies)
- ;
- fprintf fmt "@.";
- fprintf fmt "clean:@.";
- fprintf fmt "\t\\rm -f *.o ${BINNAME}@.";
- fprintf fmt "@.";
- Mod.other_targets fmt basename nodename dependencies;
- fprintf fmt "@.";
-
end
+module Main =
+functor
+ (Mod : MODIFIERS_MKF)
+ ->
+ struct
+ (* TODO: BEWARE OF THE BUG !! in case of very long nodename or maybe even
+ basename, the string basename_nodename exceed a limit length for files on
+ linux and prevent gcc to generate the binary of that name.
+
+ To be solved (later) with - either the default name if it short - a
+ shorter version if it is long (md5?) - a provided name given when calling
+ the makefile so the user can control the expected name of the binary *)
+
+ let print_makefile basename nodename (dependencies : dep_t list) fmt =
+ let binname =
+ let s = basename ^ "_" ^ nodename in
+ if
+ String.length s > 100
+ (* seems that GCC fails from 144 characters and on: File name too long
+ collect2 ld error. *)
+ then
+ if String.length nodename > 100 then basename ^ "_run"
+ (* shorter version *)
+ else nodename ^ "run"
+ else s
+ in
+ fprintf fmt "BINNAME?=%s@." binname;
+ fprintf fmt "GCC=gcc -O0@.";
+ fprintf fmt "LUSTREC=%s@." Sys.executable_name;
+ fprintf fmt "LUSTREC_BASE=%s@."
+ (Filename.dirname (Filename.dirname Sys.executable_name));
+ fprintf fmt "INC=%s@." Version.include_path
+ (*"${LUSTREC_BASE}/include/lustrec"*);
+ fprintf fmt "@.";
+
+ (* Main binary *)
+ fprintf fmt "%s_%s: %s.c %s_main.c@." basename "run" (*nodename*) basename
+ basename;
+ fprintf fmt "\t${GCC} -I${INC} -I. -c %s.c@." basename;
+ fprintf fmt "\t${GCC} -I${INC} -I. -c %s_main.c@." basename;
+ fprintf_dependencies fmt dependencies;
+ fprintf fmt "\t${GCC} -o ${BINNAME} io_frontend.o %a %s.o %s_main.o %a@."
+ (Utils.fprintf_list ~sep:" " (fun fmt dep ->
+ Format.fprintf fmt "%s.o" dep.name))
+ (compiled_dependencies dependencies)
+ basename (* library .o *) basename
+ (* main function . o *)
+ (Utils.fprintf_list ~sep:" " (fun fmt lib -> fprintf fmt "-l%s" lib))
+ (lib_dependencies dependencies);
+ fprintf fmt "@.";
+ fprintf fmt "clean:@.";
+ fprintf fmt "\t\\rm -f *.o ${BINNAME}@.";
+ fprintf fmt "@.";
+ Mod.other_targets fmt basename nodename dependencies;
+ fprintf fmt "@."
+ end
+
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
(* End: *)
diff --git a/src/backends/C/c_backend_mauve.ml b/src/backends/C/c_backend_mauve.ml
index d64a4af8f17b4a8975114fed4a744f3c76f0d673..860a6c076cccf1a3b80cb3059c5ed7b3c58f1881 100644
--- a/src/backends/C/c_backend_mauve.ml
+++ b/src/backends/C/c_backend_mauve.ml
@@ -5,25 +5,20 @@ open C_backend_common
open Utils
open Printers
-(* module type MODIFIERS_MAINSRC =
-sig
-end
-
-module EmptyMod =
-struct
-end
-
-module Mauve = functor (Mod: MODIFIERS_MAINSRC) ->
-struct
-end
- *)
+(* module type MODIFIERS_MAINSRC = sig end
+
+ module EmptyMod = struct end
+
+ module Mauve = functor (Mod: MODIFIERS_MAINSRC) -> struct end *)
(********************************************************************************************)
-(* Main related functions *)
+(* Main related functions *)
(********************************************************************************************)
let shell_name node = node ^ "Shell"
-let core_name node = node ^ "Core"
-let fsm_name node = node ^ "FSM"
+
+let core_name node = node ^ "Core"
+
+let fsm_name node = node ^ "FSM"
(* -------------------------------------------------- *)
(* Hearder *)
@@ -31,7 +26,9 @@ let fsm_name node = node ^ "FSM"
let print_mauve_header fmt basename =
fprintf fmt "#include \"mauve/runtime.hpp\"@.";
- print_import_alloc_prototype fmt {local=true; name=basename; content=[]; is_stateful=true} (* assuming it is stateful*) ;
+ print_import_alloc_prototype fmt
+ { local = true; name = basename; content = []; is_stateful = true }
+ (* assuming it is stateful*);
pp_print_newline fmt ();
pp_print_newline fmt ()
@@ -41,31 +38,34 @@ let print_mauve_header fmt basename =
let mauve_default_value v =
(* let v_name = v.var_id in *)
-
if Types.is_bool_type v.var_type then "false"
else if Types.is_int_type v.var_type then "0"
else if Types.is_real_type v.var_type then "0.0"
else assert false
-let print_mauve_default fmt mauve_machine v =
- let v_name: string = v.var_id in
+let print_mauve_default fmt mauve_machine v =
+ let v_name : string = v.var_id in
let found = ref false in
- let annotations: expr_annot list = mauve_machine.mname.node_annot in
+ let annotations : expr_annot list = mauve_machine.mname.node_annot in
List.iter
- (fun (al: expr_annot) ->
- List.iter
- (fun ((sl, e): string list * eexpr) -> if not !found then match sl with
- | ["mauve"; "default"; name] ->
- if v_name = name then begin (pp_expr fmt e.eexpr_qfexpr); found := true; end
- | _ -> ();
- ) al.annots;
- ) annotations;
+ (fun (al : expr_annot) ->
+ List.iter
+ (fun ((sl, e) : string list * eexpr) ->
+ if not !found then
+ match sl with
+ | [ "mauve"; "default"; name ] ->
+ if v_name = name then (
+ pp_expr fmt e.eexpr_qfexpr;
+ found := true)
+ | _ ->
+ ())
+ al.annots)
+ annotations;
if not !found then fprintf fmt "%s" (mauve_default_value v)
-
let print_mauve_shell fmt mauve_machine =
let node_name = mauve_machine.mname.node_id in
-
+
fprintf fmt "/*@.";
fprintf fmt " * SHELL@.";
fprintf fmt " */@.";
@@ -78,18 +78,20 @@ let print_mauve_shell fmt mauve_machine =
(fun v ->
let v_name = v.var_id in
let v_type = pp_c_basic_type_desc v.var_type in
- fprintf fmt "\tReadPort<%s> & port_%s = mk_readPort<%s>(\"%s\", " v_type v_name v_type v_name;
+ fprintf fmt "\tReadPort<%s> & port_%s = mk_readPort<%s>(\"%s\", " v_type
+ v_name v_type v_name;
print_mauve_default fmt mauve_machine v;
- fprintf fmt ");@.";
- ) mauve_machine.mstep.step_inputs;
+ fprintf fmt ");@.")
+ mauve_machine.mstep.step_inputs;
(* out ports *)
fprintf fmt "\t// OutputPorts@.";
List.iter
(fun v ->
let v_name = v.var_id in
let v_type = pp_c_basic_type_desc v.var_type in
- fprintf fmt "\tWritePort<%s> & port_%s = mk_writePort<%s>(\"%s\");@." v_type v_name v_type v_name;
- ) mauve_machine.mstep.step_outputs;
+ fprintf fmt "\tWritePort<%s> & port_%s = mk_writePort<%s>(\"%s\");@."
+ v_type v_name v_type v_name)
+ mauve_machine.mstep.step_outputs;
fprintf fmt "};@.";
@@ -100,13 +102,13 @@ let print_mauve_step fmt node_name mauve_machine =
List.iter
(fun v ->
let v_name = v.var_id in
- fprintf fmt "%s, " v_name;
- ) mauve_machine.mstep.step_inputs;
+ fprintf fmt "%s, " v_name)
+ mauve_machine.mstep.step_inputs;
List.iter
(fun v ->
let v_name = v.var_id in
- fprintf fmt "&%s, " v_name;
- ) mauve_machine.mstep.step_outputs;
+ fprintf fmt "&%s, " v_name)
+ mauve_machine.mstep.step_outputs;
fprintf fmt "node";
fprintf fmt ");@."
@@ -121,7 +123,8 @@ let print_mauve_core fmt mauve_machine =
fprintf fmt " * CORE@.";
fprintf fmt " */@.";
- fprintf fmt "struct %s: public Core<%s> {@." (core_name node_name) (shell_name node_name);
+ fprintf fmt "struct %s: public Core<%s> {@." (core_name node_name)
+ (shell_name node_name);
(* Attribute *)
fprintf fmt "\tstruct %s_mem * node;@." node_name;
@@ -132,20 +135,20 @@ let print_mauve_core fmt mauve_machine =
(fun v ->
let v_name = v.var_id in
let v_type = pp_c_basic_type_desc v.var_type in
- fprintf fmt "\t\t%s %s = port_%s.read();@." v_type v_name v_name;
- ) mauve_machine.mstep.step_inputs;
+ fprintf fmt "\t\t%s %s = port_%s.read();@." v_type v_name v_name)
+ mauve_machine.mstep.step_inputs;
List.iter
(fun v ->
let v_name = v.var_id in
let v_type = pp_c_basic_type_desc v.var_type in
- fprintf fmt "\t\t%s %s;@." v_type v_name;
- ) mauve_machine.mstep.step_outputs;
+ fprintf fmt "\t\t%s %s;@." v_type v_name)
+ mauve_machine.mstep.step_outputs;
print_mauve_step fmt node_name mauve_machine;
List.iter
(fun v ->
let v_name = v.var_id in
- fprintf fmt "\t\tport_%s.write(%s);@." v_name v_name;
- ) mauve_machine.mstep.step_outputs;
+ fprintf fmt "\t\tport_%s.write(%s);@." v_name v_name)
+ mauve_machine.mstep.step_outputs;
fprintf fmt "\t}@.";
pp_print_newline fmt ();
(* Configure *)
@@ -167,33 +170,47 @@ let print_mauve_core fmt mauve_machine =
(* FSM *)
(* -------------------------------------------------- *)
-let print_period_conversion fmt expr = (
+let print_period_conversion fmt expr =
match expr.expr_desc with
- | Expr_tuple [p; u] -> (
- match u.expr_desc with
- | Expr_ident "s" -> fprintf fmt "sec_to_ns("; (pp_expr fmt p); fprintf fmt ")"
- | Expr_ident "ssec"-> fprintf fmt "sec_to_ns("; (pp_expr fmt p); fprintf fmt ")"
- | Expr_ident "ms" -> fprintf fmt "ms_to_ns(" ; (pp_expr fmt p); fprintf fmt ")"
- | Expr_ident "ns" -> pp_expr fmt p
- | _ -> assert false
- )
- | _ -> assert false
- )
-
-let print_mauve_period fmt mauve_machine =
+ | Expr_tuple [ p; u ] -> (
+ match u.expr_desc with
+ | Expr_ident "s" ->
+ fprintf fmt "sec_to_ns(";
+ pp_expr fmt p;
+ fprintf fmt ")"
+ | Expr_ident "ssec" ->
+ fprintf fmt "sec_to_ns(";
+ pp_expr fmt p;
+ fprintf fmt ")"
+ | Expr_ident "ms" ->
+ fprintf fmt "ms_to_ns(";
+ pp_expr fmt p;
+ fprintf fmt ")"
+ | Expr_ident "ns" ->
+ pp_expr fmt p
+ | _ ->
+ assert false)
+ | _ ->
+ assert false
+
+let print_mauve_period fmt mauve_machine =
let found = ref false in
- let annotations: expr_annot list = mauve_machine.mname.node_annot in
+ let annotations : expr_annot list = mauve_machine.mname.node_annot in
List.iter
- (fun (al: expr_annot) ->
- List.iter
- (fun ((sl, e): string list * eexpr) -> if not !found then match sl with
- | ["mauve"; "period" ] -> (print_period_conversion fmt e.eexpr_qfexpr); found := true;
- | _ -> ();
- ) al.annots;
- ) annotations;
+ (fun (al : expr_annot) ->
+ List.iter
+ (fun ((sl, e) : string list * eexpr) ->
+ if not !found then
+ match sl with
+ | [ "mauve"; "period" ] ->
+ print_period_conversion fmt e.eexpr_qfexpr;
+ found := true
+ | _ ->
+ ())
+ al.annots)
+ annotations;
if not !found then fprintf fmt "0"
-
let print_mauve_fsm fmt mauve_machine =
let node_name = mauve_machine.mname.node_id in
@@ -201,11 +218,16 @@ let print_mauve_fsm fmt mauve_machine =
fprintf fmt " * FSM@.";
fprintf fmt " */@.";
- fprintf fmt "struct %s: public FiniteStateMachine<%s, %s> {@." (fsm_name node_name) (shell_name node_name) (core_name node_name);
+ fprintf fmt "struct %s: public FiniteStateMachine<%s, %s> {@."
+ (fsm_name node_name) (shell_name node_name) (core_name node_name);
(* Attribute *)
- fprintf fmt "\tExecState<%s> & update = mk_execution (\"Update\" , &%s::update);@." (core_name node_name) (core_name node_name);
- fprintf fmt "\tSynchroState<%s> & synchro = mk_synchronization(\"Synchro\", " (core_name node_name);
+ fprintf fmt
+ "\tExecState<%s> & update = mk_execution (\"Update\" , \
+ &%s::update);@."
+ (core_name node_name) (core_name node_name);
+ fprintf fmt "\tSynchroState<%s> & synchro = mk_synchronization(\"Synchro\", "
+ (core_name node_name);
print_mauve_period fmt mauve_machine;
fprintf fmt ");@.";
pp_print_newline fmt ();
diff --git a/src/backends/C/c_backend_spec.ml b/src/backends/C/c_backend_spec.ml
index eb4688481321acf3e2023d18728e890b01b91636..70dec97ec2f862b09aec6c1f8e6c43f57fc9fa99 100644
--- a/src/backends/C/c_backend_spec.ml
+++ b/src/backends/C/c_backend_spec.ml
@@ -1,4 +1,3 @@
-
(********************************************************************)
(* *)
(* The LustreC compiler toolset / The LustreC Development Team *)
@@ -23,10 +22,10 @@ open Machine_code_common
(**************************************************************************)
-(* TODO ACSL
- Return updates machines (eg with local annotations) and acsl preamble *)
+(* TODO ACSL Return updates machines (eg with local annotations) and acsl
+ preamble *)
let preprocess_acsl machines = machines, []
-
+
let pp_acsl_basic_type_desc t_desc =
if Types.is_bool_type t_desc then
(* if !Options.cpp then "bool" else "_Bool" *)
@@ -36,44 +35,33 @@ let pp_acsl_basic_type_desc t_desc =
if t_desc.tid = -1 then "int" else "integer"
else if Types.is_real_type t_desc then
if !Options.mpfr then Mpfr.mpfr_t else !Options.real_type
- else
- assert false (* Not a basic C type. Do not handle arrays or pointers *)
+ else assert false
+(* Not a basic C type. Do not handle arrays or pointers *)
-let pp_acsl pp fmt =
- fprintf fmt "@[<v>/*%@ @[<v>%a@]@,*/@]" pp
+let pp_acsl pp fmt = fprintf fmt "@[<v>/*%@ @[<v>%a@]@,*/@]" pp
-let pp_acsl_cut pp fmt =
- fprintf fmt "%a@," (pp_acsl pp)
+let pp_acsl_cut pp fmt = fprintf fmt "%a@," (pp_acsl pp)
-let pp_acsl_line pp fmt =
- fprintf fmt "//%@ @[<h>%a@]" pp
+let pp_acsl_line pp fmt = fprintf fmt "//%@ @[<h>%a@]" pp
-let pp_acsl_line' pp fmt =
- fprintf fmt "/*%@ @[<h>%a@] */" pp
+let pp_acsl_line' pp fmt = fprintf fmt "/*%@ @[<h>%a@] */" pp
-let pp_acsl_line_cut pp fmt =
- fprintf fmt "%a@," (pp_acsl_line pp)
+let pp_acsl_line_cut pp fmt = fprintf fmt "%a@," (pp_acsl_line pp)
-let pp_requires pp_req fmt =
- fprintf fmt "requires %a;" pp_req
+let pp_requires pp_req fmt = fprintf fmt "requires %a;" pp_req
-let pp_ensures pp_ens fmt =
- fprintf fmt "ensures %a;" pp_ens
+let pp_ensures pp_ens fmt = fprintf fmt "ensures %a;" pp_ens
-let pp_assumes pp_asm fmt =
- fprintf fmt "assumes %a;" pp_asm
+let pp_assumes pp_asm fmt = fprintf fmt "assumes %a;" pp_asm
let pp_assigns pp =
pp_comma_list
~pp_prologue:(fun fmt () -> pp_print_string fmt "assigns ")
- ~pp_epilogue:pp_print_semicolon'
- pp
+ ~pp_epilogue:pp_print_semicolon' pp
-let pp_ghost pp_gho fmt =
- fprintf fmt "ghost %a" pp_gho
+let pp_ghost pp_gho fmt = fprintf fmt "ghost %a" pp_gho
-let pp_assert pp_ast fmt =
- fprintf fmt "assert %a;" pp_ast
+let pp_assert pp_ast fmt = fprintf fmt "assert %a;" pp_ast
let pp_mem_valid pp_var fmt (name, var) =
fprintf fmt "%s_valid(%a)" name pp_var var
@@ -90,157 +78,127 @@ let pp_access pp_stru pp_field fmt (stru, field) =
let pp_access' = pp_access pp_print_string pp_print_string
-let pp_var_decl fmt v =
- pp_print_string fmt v.var_id
+let pp_var_decl fmt v = pp_print_string fmt v.var_id
let pp_reg self fmt field =
pp_access pp_indirect' pp_var_decl fmt ((self, "_reg"), field)
-let pp_true fmt () =
- pp_print_string fmt "\\true"
+let pp_true fmt () = pp_print_string fmt "\\true"
-let pp_false fmt () =
- pp_print_string fmt "\\false"
+let pp_false fmt () = pp_print_string fmt "\\false"
-let pp_at pp_v fmt (v, l) =
- fprintf fmt "\\at(%a, %s)" pp_v v l
+let pp_at pp_v fmt (v, l) = fprintf fmt "\\at(%a, %s)" pp_v v l
let instances machines m =
let open List in
let grow paths i td mems =
match paths with
- | [] -> [[i, (td, mems)]]
- | _ -> map (cons (i, (td, mems))) paths
+ | [] ->
+ [ [ i, (td, mems) ] ]
+ | _ ->
+ map (cons (i, (td, mems))) paths
in
let rec aux paths m =
- map (fun (i, (td, _)) ->
+ map
+ (fun (i, (td, _)) ->
try
let m = find (fun m -> m.mname.node_id = node_name td) machines in
aux (grow paths i td m.mmemory) m
with Not_found -> grow paths i td [])
- m.minstances |> flatten
+ m.minstances
+ |> flatten
in
aux [] m |> map rev
let memories insts =
- List.(map (fun path ->
- let _, (_, mems) = hd (rev path) in
- map (fun mem -> path, mem) mems) insts |> flatten)
-
-let pp_instance ?(indirect=true) ptr =
+ List.(
+ map
+ (fun path ->
+ let _, (_, mems) = hd (rev path) in
+ map (fun mem -> path, mem) mems)
+ insts
+ |> flatten)
+
+let pp_instance ?(indirect = true) ptr =
pp_print_list
~pp_prologue:(fun fmt () -> fprintf fmt "%s->" ptr)
~pp_sep:(fun fmt () -> pp_print_string fmt (if indirect then "->" else "."))
(fun fmt (i, _) -> pp_print_string fmt i)
-let pp_memory ?(indirect=true) ptr fmt (path, mem) =
+let pp_memory ?(indirect = true) ptr fmt (path, mem) =
pp_access
((if indirect then pp_indirect else pp_access)
- (pp_instance ~indirect ptr) pp_print_string)
- pp_var_decl
- fmt ((path, "_reg"), mem)
+ (pp_instance ~indirect ptr)
+ pp_print_string)
+ pp_var_decl fmt
+ ((path, "_reg"), mem)
let prefixes l =
let rec pref acc = function
- | x :: l -> pref ([x] :: List.map (List.cons x) acc) l
- | [] -> acc
+ | x :: l ->
+ pref ([ x ] :: List.map (List.cons x) acc) l
+ | [] ->
+ acc
in
pref [] (List.rev l)
-let powerset_instances paths =
- List.map prefixes paths |> List.flatten
+let powerset_instances paths = List.map prefixes paths |> List.flatten
let pp_separated self mem fmt (paths, ptrs) =
- fprintf fmt "\\separated(@[<v>%s, %s@;%a@;%a@])"
- self
- mem
- (pp_comma_list
- ~pp_prologue:pp_print_comma'
- (pp_instance self))
+ fprintf fmt "\\separated(@[<v>%s, %s@;%a@;%a@])" self mem
+ (pp_comma_list ~pp_prologue:pp_print_comma' (pp_instance self))
paths
- (pp_comma_list
- ~pp_prologue:pp_print_comma'
- pp_var_decl)
+ (pp_comma_list ~pp_prologue:pp_print_comma' pp_var_decl)
ptrs
let pp_separated' =
pp_comma_list
~pp_prologue:(fun fmt () -> pp_print_string fmt "\\separated(")
- ~pp_epilogue:pp_print_cpar
- pp_var_decl
+ ~pp_epilogue:pp_print_cpar pp_var_decl
-let pp_par pp fmt =
- fprintf fmt "(%a)" pp
+let pp_par pp fmt = fprintf fmt "(%a)" pp
let pp_forall pp_l pp_r fmt (l, r) =
- fprintf fmt "@[<v 2>\\forall %a;@,%a@]"
- pp_l l
- pp_r r
+ fprintf fmt "@[<v 2>\\forall %a;@,%a@]" pp_l l pp_r r
let pp_exists pp_l pp_r fmt (l, r) =
- fprintf fmt "@[<v 2>\\exists %a;@,%a@]"
- pp_l l
- pp_r r
+ fprintf fmt "@[<v 2>\\exists %a;@,%a@]" pp_l l pp_r r
-let pp_equal pp_l pp_r fmt (l, r) =
- fprintf fmt "%a == %a"
- pp_l l
- pp_r r
+let pp_equal pp_l pp_r fmt (l, r) = fprintf fmt "%a == %a" pp_l l pp_r r
-let pp_different pp_l pp_r fmt (l, r) =
- fprintf fmt "%a != %a"
- pp_l l
- pp_r r
+let pp_different pp_l pp_r fmt (l, r) = fprintf fmt "%a != %a" pp_l l pp_r r
let pp_implies pp_l pp_r fmt (l, r) =
- fprintf fmt "@[<v>%a ==>@ %a@]"
- pp_l l
- pp_r r
+ fprintf fmt "@[<v>%a ==>@ %a@]" pp_l l pp_r r
-let pp_and pp_l pp_r fmt (l, r) =
- fprintf fmt "@[<v>%a @ && %a@]"
- pp_l l
- pp_r r
+let pp_and pp_l pp_r fmt (l, r) = fprintf fmt "@[<v>%a @ && %a@]" pp_l l pp_r r
let pp_and_l pp_v fmt =
- pp_print_list
- ~pp_open_box:pp_open_vbox0
+ pp_print_list ~pp_open_box:pp_open_vbox0
~pp_sep:(fun fmt () -> fprintf fmt "@,&& ")
- pp_v
- fmt
+ pp_v fmt
-let pp_or pp_l pp_r fmt (l, r) =
- fprintf fmt "@[<v>%a @ || %a@]"
- pp_l l
- pp_r r
+let pp_or pp_l pp_r fmt (l, r) = fprintf fmt "@[<v>%a @ || %a@]" pp_l l pp_r r
let pp_or_l pp_v fmt =
- pp_print_list
- ~pp_open_box:pp_open_vbox0
+ pp_print_list ~pp_open_box:pp_open_vbox0
~pp_sep:(fun fmt () -> fprintf fmt "@,|| ")
- pp_v
- fmt
+ pp_v fmt
-let pp_not pp fmt =
- fprintf fmt "!%a" pp
+let pp_not pp fmt = fprintf fmt "!%a" pp
let pp_valid pp =
pp_and_l
- (* pp_print_list *)
+ (* pp_print_list *)
(* ~pp_sep:pp_print_cut *)
(fun fmt x -> fprintf fmt "\\valid(%a)" pp x)
-let pp_old pp fmt =
- fprintf fmt "\\old(%a)" pp
+let pp_old pp fmt = fprintf fmt "\\old(%a)" pp
let pp_ite pp_c pp_t pp_f fmt (c, t, f) =
- fprintf fmt "(%a @[<hov>? %a@ : %a)@]"
- pp_c c
- pp_t t
- pp_f f
+ fprintf fmt "(%a @[<hov>? %a@ : %a)@]" pp_c c pp_t t pp_f f
-let pp_paren pp fmt v =
- fprintf fmt "(%a)" pp v
+let pp_paren pp fmt v = fprintf fmt "(%a)" pp v
let pp_initialization pp_mem fmt (name, mem) =
fprintf fmt "%s_initialization(%a)" name pp_mem mem
@@ -251,20 +209,14 @@ let pp_local m =
pp_c_decl_local_var ~pp_c_basic_type_desc:pp_acsl_basic_type_desc m
let pp_locals m =
- pp_comma_list
- ~pp_open_box:(fun fmt () -> pp_open_hovbox fmt 0)
- (pp_local m)
+ pp_comma_list ~pp_open_box:(fun fmt () -> pp_open_hovbox fmt 0) (pp_local m)
-let pp_ptr_decl fmt v =
- pp_ptr fmt v.var_id
+let pp_ptr_decl fmt v = pp_ptr fmt v.var_id
let pp_basic_assign_spec pp_l pp_r fmt typ var_name value =
- if Types.is_real_type typ && !Options.mpfr
- then
- assert false
+ if Types.is_real_type typ && !Options.mpfr then assert false
(* Mpfr.pp_inject_assign pp_var fmt (var_name, value) *)
- else
- pp_equal pp_l pp_r fmt (var_name, value)
+ else pp_equal pp_l pp_r fmt (var_name, value)
let pp_assign_spec m self_l pp_var_l indirect_l self_r pp_var_r indirect_r fmt
(var_type, var_name, value) =
@@ -275,37 +227,35 @@ let pp_assign_spec m self_l pp_var_l indirect_l self_r pp_var_r indirect_r fmt
match vars with
| [] ->
pp_basic_assign_spec
- (pp_value_suffix ~indirect:indirect_l m self_l var_type loop_vars pp_var_l)
- (pp_value_suffix ~indirect:indirect_r m self_r var_type loop_vars pp_var_r)
+ (pp_value_suffix ~indirect:indirect_l m self_l var_type loop_vars
+ pp_var_l)
+ (pp_value_suffix ~indirect:indirect_r m self_r var_type loop_vars
+ pp_var_r)
fmt typ var_name value
| (_d, LVar _i) :: _q ->
assert false
- (* let typ' = Types.array_element_type typ in
- * fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
- * i i i pp_c_dimension d i
- * (aux typ') q *)
+ (* let typ' = Types.array_element_type typ in
+ * fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
+ * i i i pp_c_dimension d i
+ * (aux typ') q *)
| (_d, LInt _r) :: _q ->
assert false
- (* let typ' = Types.array_element_type typ in
- * let szl = Utils.enumerate (Dimension.size_const_dimension d) in
- * fprintf fmt "@[<v 2>{@,%a@]@,}"
- * (pp_print_list (fun fmt i -> r := i; aux typ' fmt q)) szl *)
- | _ -> assert false
+ (* let typ' = Types.array_element_type typ in
+ * let szl = Utils.enumerate (Dimension.size_const_dimension d) in
+ * fprintf fmt "@[<v 2>{@,%a@]@,}"
+ * (pp_print_list (fun fmt i -> r := i; aux typ' fmt q)) szl *)
+ | _ ->
+ assert false
in
- begin
- reset_loop_counter ();
- aux var_type fmt reordered_loop_vars;
- end
+ reset_loop_counter ();
+ aux var_type fmt reordered_loop_vars
-let pp_nothing fmt () =
- pp_print_string fmt "\\nothing"
+let pp_nothing fmt () = pp_print_string fmt "\\nothing"
let pp_memory_pack_aux ?i pp_mem pp_self fmt (name, mem, self) =
- fprintf fmt "%s_pack%a(@[<hov>%a,@ %a@])"
- name
- (pp_print_option pp_print_int) i
- pp_mem mem
- pp_self self
+ fprintf fmt "%s_pack%a(@[<hov>%a,@ %a@])" name
+ (pp_print_option pp_print_int)
+ i pp_mem mem pp_self self
let pp_memory_pack pp_mem pp_self fmt (mp, mem, self) =
pp_memory_pack_aux ?i:mp.mpindex pp_mem pp_self fmt
@@ -313,24 +263,26 @@ let pp_memory_pack pp_mem pp_self fmt (mp, mem, self) =
let pp_memory_pack_aux' ?i fmt =
pp_memory_pack_aux ?i pp_print_string pp_print_string fmt
-let pp_memory_pack' fmt =
- pp_memory_pack pp_print_string pp_print_string fmt
+
+let pp_memory_pack' fmt = pp_memory_pack pp_print_string pp_print_string fmt
let pp_transition_aux ?i m pp_mem_in pp_mem_out pp_input pp_output fmt
(name, inputs, locals, outputs, mem_in, mem_out) =
let stateless = fst (get_stateless_status m) in
- fprintf fmt "%s_transition%a(@[<hov>%t%a%a%t%a@])"
- name
- (pp_print_option pp_print_int) i
+ fprintf fmt "%s_transition%a(@[<hov>%t%a%a%t%a@])" name
+ (pp_print_option pp_print_int)
+ i
(fun fmt -> if not stateless then pp_mem_in fmt mem_in)
(pp_comma_list
~pp_prologue:(fun fmt () -> if not stateless then pp_print_comma fmt ())
- pp_input) inputs
+ pp_input)
+ inputs
(pp_print_option (fun fmt _ ->
pp_comma_list ~pp_prologue:pp_print_comma pp_input fmt locals))
i
(fun fmt -> if not stateless then fprintf fmt ",@ %a" pp_mem_out mem_out)
- (pp_comma_list ~pp_prologue:pp_print_comma pp_output) outputs
+ (pp_comma_list ~pp_prologue:pp_print_comma pp_output)
+ outputs
let pp_transition m pp_mem_in pp_mem_out pp_input pp_output fmt
(t, mem_in, mem_out) =
@@ -339,17 +291,18 @@ let pp_transition m pp_mem_in pp_mem_out pp_input pp_output fmt
let pp_transition_aux' ?i m =
pp_transition_aux ?i m pp_print_string pp_print_string pp_var_decl pp_var_decl
+
let pp_transition_aux'' ?i m =
pp_transition_aux ?i m pp_print_string pp_print_string pp_var_decl pp_ptr_decl
+
let pp_transition' m =
pp_transition m pp_print_string pp_print_string pp_var_decl pp_var_decl
+
let pp_transition'' m =
pp_transition m pp_print_string pp_print_string pp_var_decl pp_ptr_decl
let pp_reset_cleared pp_mem_in pp_mem_out fmt (name, mem_in, mem_out) =
- fprintf fmt "%s_reset_cleared(@[<hov>%a,@ %a@])"
- name
- pp_mem_in mem_in
+ fprintf fmt "%s_reset_cleared(@[<hov>%a,@ %a@])" name pp_mem_in mem_in
pp_mem_out mem_out
let pp_reset_cleared' = pp_reset_cleared pp_print_string pp_print_string
@@ -357,22 +310,22 @@ let pp_reset_cleared' = pp_reset_cleared pp_print_string pp_print_string
let pp_functional_update mems fmt mem =
let rec aux fmt mems =
match mems with
- | [] -> pp_print_string fmt mem
+ | [] ->
+ pp_print_string fmt mem
| x :: mems ->
fprintf fmt "{ @[<hov>%a@ \\with ._reg.%s = %s@] }" aux mems x x
in
aux fmt
- (* if Utils.ISet.is_empty mems then
- * pp_print_string fmt mem
- * else
- * fprintf fmt "{ %s @[<hov>\\with %a@] }"
- * mem
- * (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@;<1 -6>\\with ")
- * (fun fmt x -> fprintf fmt "._reg.%s = %s" x x)) *)
- (Utils.ISet.elements mems)
+ (* if Utils.ISet.is_empty mems then
+ * pp_print_string fmt mem
+ * else
+ * fprintf fmt "{ %s @[<hov>\\with %a@] }"
+ * mem
+ * (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@;<1 -6>\\with ")
+ * (fun fmt x -> fprintf fmt "._reg.%s = %s" x x)) *)
+ (Utils.ISet.elements mems)
module PrintSpec = struct
-
type mode =
| MemoryPackMode
| TransitionMode
@@ -387,39 +340,52 @@ module PrintSpec = struct
| StateVar x ->
fprintf fmt "%s.%a" mem pp_var_decl x
- let pp_expr:
- type a. ?output:bool -> machine_t -> ident -> formatter
- -> (value_t, a) expression_t -> unit =
- fun ?(output=false) m mem fmt -> function
- | Val v -> pp_c_val m mem (pp_c_var_read ~test_output:output m) fmt v
- | Tag t -> pp_print_string fmt t
- | Var v -> pp_var_decl fmt v
- | Memory r -> pp_reg mem fmt r
+ let pp_expr :
+ type a.
+ ?output:bool ->
+ machine_t ->
+ ident ->
+ formatter ->
+ (value_t, a) expression_t ->
+ unit =
+ fun ?(output = false) m mem fmt -> function
+ | Val v ->
+ pp_c_val m mem (pp_c_var_read ~test_output:output m) fmt v
+ | Tag t ->
+ pp_print_string fmt t
+ | Var v ->
+ pp_var_decl fmt v
+ | Memory r ->
+ pp_reg mem fmt r
let pp_predicate mode m mem_in mem_in' mem_out mem_out' fmt p =
- let output, mem_update = match mode with
- | InstrMode _ -> true, false
- | TransitionFootprintMode -> false, true
- | _ -> false, false
+ let output, mem_update =
+ match mode with
+ | InstrMode _ ->
+ true, false
+ | TransitionFootprintMode ->
+ false, true
+ | _ ->
+ false, false
in
- let pp_expr:
- type a. ?output:bool -> formatter -> (value_t, a) expression_t -> unit =
- fun ?output fmt e -> pp_expr ?output m mem_out fmt e
+ let pp_expr :
+ type a. ?output:bool -> formatter -> (value_t, a) expression_t -> unit =
+ fun ?output fmt e -> pp_expr ?output m mem_out fmt e
in
match p with
| Transition (f, inst, i, inputs, locals, outputs, r, mems) ->
- let pp_mem_in, pp_mem_out = match inst with
+ let pp_mem_in, pp_mem_out =
+ match inst with
| None ->
- pp_print_string,
- if mem_update then pp_functional_update mems else pp_print_string
+ ( pp_print_string,
+ if mem_update then pp_functional_update mems else pp_print_string )
| Some inst ->
- (fun fmt mem_in ->
- if r then pp_print_string fmt mem_in
- else pp_access' fmt (mem_in, inst)),
- (fun fmt mem_out -> pp_access' fmt (mem_out, inst))
+ ( (fun fmt mem_in ->
+ if r then pp_print_string fmt mem_in
+ else pp_access' fmt (mem_in, inst)),
+ fun fmt mem_out -> pp_access' fmt (mem_out, inst) )
in
- pp_transition_aux ?i m pp_mem_in pp_mem_out pp_expr (pp_expr ~output)
- fmt
+ pp_transition_aux ?i m pp_mem_in pp_mem_out pp_expr (pp_expr ~output) fmt
(f, inputs, locals, outputs, mem_in', mem_out')
| Reset (_f, inst, r) ->
pp_ite
@@ -429,33 +395,40 @@ module PrintSpec = struct
fmt
(r, (mem_out, 1), (mem_out, (mem_in, inst)))
| MemoryPack (f, inst, i) ->
- let pp_mem, pp_self = match inst with
+ let pp_mem, pp_self =
+ match inst with
| None ->
pp_print_string, pp_print_string
| Some inst ->
- (fun fmt mem -> pp_access' fmt (mem, inst)),
- (fun fmt self -> pp_indirect' fmt (self, inst))
+ ( (fun fmt mem -> pp_access' fmt (mem, inst)),
+ fun fmt self -> pp_indirect' fmt (self, inst) )
in
pp_memory_pack_aux ?i pp_mem pp_self fmt (f, mem_out, mem_in)
| ResetCleared f ->
pp_reset_cleared' fmt (f, mem_in, mem_out)
- (* fprintf fmt "ResetCleared_%a" pp_print_string f *)
- | Initialization -> ()
+ (* fprintf fmt "ResetCleared_%a" pp_print_string f *)
+ | Initialization ->
+ ()
let reset_flag = dummy_var_decl "_reset" Type_predef.type_bool
- let val_of_expr: type a. (value_t, a) expression_t -> value_t = function
- | Val v -> v
- | Tag t -> id_to_tag t
- | Var v -> vdecl_to_val v
- | Memory (StateVar v) -> vdecl_to_val v
- | Memory ResetFlag -> vdecl_to_val reset_flag
+ let val_of_expr : type a. (value_t, a) expression_t -> value_t = function
+ | Val v ->
+ v
+ | Tag t ->
+ id_to_tag t
+ | Var v ->
+ vdecl_to_val v
+ | Memory (StateVar v) ->
+ vdecl_to_val v
+ | Memory ResetFlag ->
+ vdecl_to_val reset_flag
let find_arrow m =
- try
- List.find (fun (_, (td, _)) -> Arrow.td_is_arrow td) m.minstances
- |> fst
- with Not_found -> eprintf "Internal error: arrow not found"; raise Not_found
+ try List.find (fun (_, (td, _)) -> Arrow.td_is_arrow td) m.minstances |> fst
+ with Not_found ->
+ eprintf "Internal error: arrow not found";
+ raise Not_found
let pp_spec mode m fmt f =
let rec pp_spec mode fmt f =
@@ -479,11 +452,10 @@ module PrintSpec = struct
| InstrMode self ->
let mem = "*" ^ mem in
fprintf str_formatter "%a" (pp_at pp_print_string) (mem, reset_label);
- self, flush_str_formatter (), false,
- mem, mem, false
+ self, flush_str_formatter (), false, mem, mem, false
in
- let pp_expr: type a. formatter -> (value_t, a) expression_t -> unit =
- fun fmt e -> pp_expr m mem_out fmt e
+ let pp_expr : type a. formatter -> (value_t, a) expression_t -> unit =
+ fun fmt e -> pp_expr m mem_out fmt e
in
let pp_spec' = pp_spec mode in
match f with
@@ -492,10 +464,11 @@ module PrintSpec = struct
| False ->
pp_false fmt ()
| Equal (a, b) ->
- pp_assign_spec m
- mem_out (pp_c_var_read ~test_output:false m) indirect_l
- mem_in (pp_c_var_read ~test_output:false m) indirect_r
- fmt
+ pp_assign_spec m mem_out
+ (pp_c_var_read ~test_output:false m)
+ indirect_l mem_in
+ (pp_c_var_read ~test_output:false m)
+ indirect_r fmt
(type_of_l_value a, val_of_expr a, val_of_expr b)
| And fs ->
pp_and_l pp_spec' fmt fs
@@ -513,29 +486,31 @@ module PrintSpec = struct
pp_predicate mode m mem_in mem_in' mem_out mem_out' fmt p
| StateVarPack ResetFlag ->
let r = vdecl_to_val reset_flag in
- pp_assign_spec m
- mem_out (pp_c_var_read ~test_output:false m) indirect_l
- mem_in (pp_c_var_read ~test_output:false m) indirect_r
- fmt
+ pp_assign_spec m mem_out
+ (pp_c_var_read ~test_output:false m)
+ indirect_l mem_in
+ (pp_c_var_read ~test_output:false m)
+ indirect_r fmt
(Type_predef.type_bool, r, r)
| StateVarPack (StateVar v) ->
let v' = vdecl_to_val v in
let inst = find_arrow m in
- pp_par (pp_implies
- (pp_not (pp_initialization pp_access'))
- (pp_assign_spec m
- mem_out (pp_c_var_read ~test_output:false m) indirect_l
- mem_in (pp_c_var_read ~test_output:false m) indirect_r))
+ pp_par
+ (pp_implies
+ (pp_not (pp_initialization pp_access'))
+ (pp_assign_spec m mem_out
+ (pp_c_var_read ~test_output:false m)
+ indirect_l mem_in
+ (pp_c_var_read ~test_output:false m)
+ indirect_r))
fmt
- ((Arrow.arrow_id, (mem_out, inst)),
- (v.var_type, v', v'))
+ ((Arrow.arrow_id, (mem_out, inst)), (v.var_type, v', v'))
| ExistsMem (f, rc, tr) ->
pp_exists
(pp_machine_decl' ~ghost:true)
(pp_and (pp_spec ResetOut) (pp_spec ResetIn))
fmt
- ((f, mk_mem_reset m),
- (rc, tr))
+ ((f, mk_mem_reset m), (rc, tr))
in
match mode with
| TransitionFootprintMode ->
@@ -543,22 +518,17 @@ module PrintSpec = struct
let mem_out = mk_mem_out m in
pp_forall
(pp_machine_decl ~ghost:true (pp_comma_list pp_print_string))
- (pp_spec mode)
- fmt ((m.mname.node_id, [mem_in; mem_out]), f)
+ (pp_spec mode) fmt
+ ((m.mname.node_id, [ mem_in; mem_out ]), f)
| _ ->
pp_spec mode fmt f
-
end
let pp_predicate pp_l pp_r fmt (l, r) =
- fprintf fmt "@[<v 2>predicate %a =@,%a;@]"
- pp_l l
- pp_r r
+ fprintf fmt "@[<v 2>predicate %a =@,%a;@]" pp_l l pp_r r
let pp_lemma pp_l pp_r fmt (l, r) =
- fprintf fmt "@[<v 2>lemma %a:@,%a;@]"
- pp_l l
- pp_r r
+ fprintf fmt "@[<v 2>lemma %a:@,%a;@]" pp_l l pp_r r
let pp_mem_valid_def fmt m =
if not (fst (get_stateless_status m)) then
@@ -570,13 +540,11 @@ let pp_mem_valid_def fmt m =
(pp_and
(pp_and_l (fun fmt (inst, (td, _)) ->
if Arrow.td_is_arrow td then
- pp_valid pp_indirect' fmt [self, inst]
- else
- pp_mem_valid pp_indirect' fmt (node_name td, (self, inst))))
+ pp_valid pp_indirect' fmt [ self, inst ]
+ else pp_mem_valid pp_indirect' fmt (node_name td, (self, inst))))
(pp_valid pp_print_string)))
fmt
- ((name, (name, self)),
- (m.minstances, [self]))
+ ((name, (name, self)), (m.minstances, [ self ]))
let pp_memory_pack_def m fmt mp =
let name = mp.mpname.node_id in
@@ -587,20 +555,17 @@ let pp_memory_pack_def m fmt mp =
(pp_memory_pack (pp_machine_decl' ~ghost:true) (pp_machine_decl pp_ptr))
(PrintSpec.pp_spec MemoryPackMode m))
fmt
- ((mp, (name, mem), (name, self)),
- mp.mpformula)
+ ((mp, (name, mem), (name, self)), mp.mpformula)
let print_machine_ghost_struct fmt m =
pp_acsl (pp_ghost (print_machine_struct ~ghost:true)) fmt m
let pp_memory_pack_defs fmt m =
if not (fst (get_stateless_status m)) then
- fprintf fmt "%a@,%a"
- print_machine_ghost_struct m
- (pp_print_list
- ~pp_epilogue:pp_print_cut
- ~pp_open_box:pp_open_vbox0
- (pp_memory_pack_def m)) m.mspec.mmemory_packs
+ fprintf fmt "%a@,%a" print_machine_ghost_struct m
+ (pp_print_list ~pp_epilogue:pp_print_cut ~pp_open_box:pp_open_vbox0
+ (pp_memory_pack_def m))
+ m.mspec.mmemory_packs
let pp_transition_def m fmt t =
let name = t.tname.node_id in
@@ -609,58 +574,56 @@ let pp_transition_def m fmt t =
pp_acsl
(pp_predicate
(pp_transition m
- (pp_machine_decl' ~ghost:true) (pp_machine_decl' ~ghost:true)
- (pp_local m)
- (pp_local m))
+ (pp_machine_decl' ~ghost:true)
+ (pp_machine_decl' ~ghost:true)
+ (pp_local m) (pp_local m))
(PrintSpec.pp_spec TransitionMode m))
fmt
- ((t, (name, mem_in), (name, mem_out)),
- t.tformula)
+ ((t, (name, mem_in), (name, mem_out)), t.tformula)
let pp_transition_defs fmt m =
- pp_print_list
- ~pp_epilogue:pp_print_cut
- ~pp_open_box:pp_open_vbox0
+ pp_print_list ~pp_epilogue:pp_print_cut ~pp_open_box:pp_open_vbox0
(pp_transition_def m) fmt m.mspec.mtransitions
let pp_transition_footprint fmt t =
- fprintf fmt "%s_transition%a_footprint"
- t.tname.node_id
- (pp_print_option pp_print_int) t.tindex
+ fprintf fmt "%s_transition%a_footprint" t.tname.node_id
+ (pp_print_option pp_print_int)
+ t.tindex
let pp_transition_footprint_lemma m fmt t =
let open Utils.ISet in
let name = t.tname.node_id in
- let mems = diff (of_list (List.map (fun v -> v.var_id) m.mmemory)) t.tfootprint in
- let memories = List.map (fun v ->
- { v with var_type = { v.var_type with tid = -1 }})
+ let mems =
+ diff (of_list (List.map (fun v -> v.var_id) m.mmemory)) t.tfootprint
+ in
+ let memories =
+ List.map
+ (fun v -> { v with var_type = { v.var_type with tid = -1 } })
(List.filter (fun v -> not (mem v.var_id t.tfootprint)) m.mmemory)
in
if not (is_empty mems) then
pp_acsl
- (pp_lemma
- pp_transition_footprint
+ (pp_lemma pp_transition_footprint
(PrintSpec.pp_spec TransitionFootprintMode m))
fmt
- (t,
- Forall (
- memories @ t.tinputs @ t.tlocals @ t.toutputs,
- Imply (Spec_common.mk_transition ?i:t.tindex name
- (vdecls_to_vals t.tinputs)
- (vdecls_to_vals t.tlocals)
+ ( t,
+ Forall
+ ( memories @ t.tinputs @ t.tlocals @ t.toutputs,
+ Imply
+ ( Spec_common.mk_transition ?i:t.tindex name
+ (vdecls_to_vals t.tinputs) (vdecls_to_vals t.tlocals)
(vdecls_to_vals t.toutputs),
Spec_common.mk_transition ~mems ?i:t.tindex name
- (vdecls_to_vals t.tinputs)
- (vdecls_to_vals t.tlocals)
- (vdecls_to_vals t.toutputs))))
+ (vdecls_to_vals t.tinputs) (vdecls_to_vals t.tlocals)
+ (vdecls_to_vals t.toutputs) ) ) )
let pp_transition_footprint_lemmas fmt m =
- pp_print_list
- ~pp_epilogue:pp_print_cut
- ~pp_open_box:pp_open_vbox0
- (pp_transition_footprint_lemma m) fmt
- (List.filter (fun t -> match t.tindex with Some i when i > 0 -> true | _ -> false)
- m.mspec.mtransitions)
+ pp_print_list ~pp_epilogue:pp_print_cut ~pp_open_box:pp_open_vbox0
+ (pp_transition_footprint_lemma m)
+ fmt
+ (List.filter
+ (fun t -> match t.tindex with Some i when i > 0 -> true | _ -> false)
+ m.mspec.mtransitions)
let pp_initialization_def fmt m =
if not (fst (get_stateless_status m)) then
@@ -673,8 +636,9 @@ let pp_initialization_def fmt m =
if Arrow.td_is_arrow td then
pp_initialization pp_access' fmt (node_name td, (mem_in, i))
else
- pp_equal (pp_reset_flag ~indirect:false pp_access') pp_print_int
- fmt
+ pp_equal
+ (pp_reset_flag ~indirect:false pp_access')
+ pp_print_int fmt
((mem_in, i), 1))))
fmt
((name, (name, mem_in)), m.minstances)
@@ -687,7 +651,8 @@ let pp_reset_cleared_def fmt m =
pp_acsl
(pp_predicate
(pp_reset_cleared
- (pp_machine_decl' ~ghost:true) (pp_machine_decl' ~ghost:true))
+ (pp_machine_decl' ~ghost:true)
+ (pp_machine_decl' ~ghost:true))
(pp_ite
(pp_reset_flag' ~indirect:false)
(pp_and
@@ -695,28 +660,24 @@ let pp_reset_cleared_def fmt m =
pp_initialization')
(pp_equal pp_print_string pp_print_string)))
fmt
- ((name, (name, mem_in), (name, mem_out)),
- (mem_in,
- ((mem_out, 0), (name, mem_out)),
- (mem_out, mem_in)))
+ ( (name, (name, mem_in), (name, mem_out)),
+ (mem_in, ((mem_out, 0), (name, mem_out)), (mem_out, mem_in)) )
-let pp_at pp_p fmt (p, l) =
- fprintf fmt "\\at(%a, %s)" pp_p p l
+let pp_at pp_p fmt (p, l) = fprintf fmt "\\at(%a, %s)" pp_p p l
let label_pre = "Pre"
-let pp_at_pre pp_p fmt p =
- pp_at pp_p fmt (p, label_pre)
+let pp_at_pre pp_p fmt p = pp_at pp_p fmt (p, label_pre)
-let pp_register_chain ?(indirect=true) ptr =
+let pp_register_chain ?(indirect = true) ptr =
pp_print_list
~pp_prologue:(fun fmt () -> fprintf fmt "%s->" ptr)
- ~pp_epilogue:(fun fmt () -> fprintf fmt "%s_reg._first"
- (if indirect then "->" else "."))
+ ~pp_epilogue:(fun fmt () ->
+ fprintf fmt "%s_reg._first" (if indirect then "->" else "."))
~pp_sep:(fun fmt () -> pp_print_string fmt (if indirect then "->" else "."))
(fun fmt (i, _) -> pp_print_string fmt i)
-let pp_reset_flag_chain ?(indirect=true) ptr fmt mems =
+let pp_reset_flag_chain ?(indirect = true) ptr fmt mems =
pp_print_list
~pp_prologue:(fun fmt () -> fprintf fmt "%s->" ptr)
~pp_epilogue:(fun fmt () -> pp_reset_flag' ~indirect fmt "")
@@ -727,171 +688,206 @@ let pp_reset_flag_chain ?(indirect=true) ptr fmt mems =
let pp_arrow_reset_ghost mem fmt inst =
fprintf fmt "%s_reset_ghost(%a)" Arrow.arrow_id pp_indirect' (mem, inst)
-module GhostProto: MODIFIERS_GHOST_PROTO = struct
- let pp_ghost_parameters ?(cut=true) fmt vs =
+module GhostProto : MODIFIERS_GHOST_PROTO = struct
+ let pp_ghost_parameters ?(cut = true) fmt vs =
fprintf fmt "%a%a"
- (if cut then pp_print_cut else pp_print_nothing) ()
+ (if cut then pp_print_cut else pp_print_nothing)
+ ()
(pp_acsl_line'
- (pp_ghost
- (pp_print_parenthesized (fun fmt (x, pp) -> pp fmt x))))
+ (pp_ghost (pp_print_parenthesized (fun fmt (x, pp) -> pp fmt x))))
vs
end
module HdrMod = struct
-
module GhostProto = GhostProto
- let print_machine_decl_prefix = fun _ _ -> ()
+ let print_machine_decl_prefix _ _ = ()
let pp_import_arrow fmt () =
fprintf fmt "#include \"%s/arrow_spec.h%s\""
(Arrow.arrow_top_decl ()).top_decl_owner
(if !Options.cpp then "pp" else "")
-
end
module SrcMod = struct
-
module GhostProto = GhostProto
let pp_predicates (* dependencies *) fmt machines =
let pp_preds comment pp =
- pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut comment)
- pp
- ~pp_epilogue:pp_print_cutcut in
- fprintf fmt
- "%a%a%a%a%a%a"
- (pp_preds "/* ACSL `valid` predicates */"
- pp_mem_valid_def) machines
- (pp_preds "/* ACSL `memory pack` simulations */"
- pp_memory_pack_defs) machines
- (pp_preds "/* ACSL initialization annotations */"
- pp_initialization_def) machines
- (pp_preds "/* ACSL reset cleared annotations */"
- pp_reset_cleared_def) machines
- (pp_preds "/* ACSL transition annotations */"
- pp_transition_defs) machines
+ pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut comment) pp ~pp_epilogue:pp_print_cutcut
+ in
+ fprintf fmt "%a%a%a%a%a%a"
+ (pp_preds "/* ACSL `valid` predicates */" pp_mem_valid_def)
+ machines
+ (pp_preds "/* ACSL `memory pack` simulations */" pp_memory_pack_defs)
+ machines
+ (pp_preds "/* ACSL initialization annotations */" pp_initialization_def)
+ machines
+ (pp_preds "/* ACSL reset cleared annotations */" pp_reset_cleared_def)
+ machines
+ (pp_preds "/* ACSL transition annotations */" pp_transition_defs)
+ machines
(pp_preds "/* ACSL transition memory footprints lemmas */"
- pp_transition_footprint_lemmas) machines
+ pp_transition_footprint_lemmas)
+ machines
let pp_clear_reset_spec fmt self mem m =
let name = m.mname.node_id in
- let arws, narws = List.partition (fun (_, (td, _)) -> Arrow.td_is_arrow td)
- m.minstances in
- let mk_insts = List.map (fun x -> [x]) in
- pp_acsl_cut (fun fmt () ->
+ let arws, narws =
+ List.partition (fun (_, (td, _)) -> Arrow.td_is_arrow td) m.minstances
+ in
+ let mk_insts = List.map (fun x -> [ x ]) in
+ pp_acsl_cut
+ (fun fmt () ->
fprintf fmt
- "%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,\
- @[<v 2>behavior reset:@;\
- %a@,%a@]@,\
- @[<v 2>behavior no_reset:@;\
- %a@,%a@]@,\
- complete behaviors;@,\
- disjoint behaviors;"
- (pp_requires pp_mem_valid') (name, self)
- (pp_requires (pp_separated self mem)) (mk_insts m.minstances, [])
+ "%a@,\
+ %a@,\
+ %a@,\
+ %a@,\
+ %a@,\
+ %a@,\
+ %a@,\
+ %a@,\
+ %a@,\
+ %a@,\
+ @[<v 2>behavior reset:@;\
+ %a@,\
+ %a@]@,\
+ @[<v 2>behavior no_reset:@;\
+ %a@,\
+ %a@]@,\
+ complete behaviors;@,\
+ disjoint behaviors;"
+ (pp_requires pp_mem_valid')
+ (name, self)
+ (pp_requires (pp_separated self mem))
+ (mk_insts m.minstances, [])
(pp_requires (pp_memory_pack_aux pp_ptr pp_print_string))
(name, mem, self)
- (pp_ensures (pp_memory_pack_aux
- ~i:(List.length m.mspec.mmemory_packs - 2)
- pp_ptr pp_print_string))
+ (pp_ensures
+ (pp_memory_pack_aux
+ ~i:(List.length m.mspec.mmemory_packs - 2)
+ pp_ptr pp_print_string))
(name, mem, self)
- (pp_assigns pp_reset_flag') [self]
- (pp_assigns (pp_register_chain self)) (mk_insts arws)
- (pp_assigns (pp_reset_flag_chain self)) (mk_insts narws)
- (pp_assigns pp_reset_flag') [mem]
- (pp_assigns (pp_register_chain ~indirect:false mem)) (mk_insts arws)
- (pp_assigns (pp_reset_flag_chain ~indirect:false mem)) (mk_insts narws)
- (pp_assumes (pp_equal pp_reset_flag' pp_print_int)) (mem, 1)
- (pp_ensures (pp_initialization pp_ptr)) (name, mem)
- (pp_assumes (pp_equal pp_reset_flag' pp_print_int)) (mem, 0)
- (pp_ensures (pp_equal pp_ptr (pp_old pp_ptr))) (mem, mem)
- )
+ (pp_assigns pp_reset_flag')
+ [ self ]
+ (pp_assigns (pp_register_chain self))
+ (mk_insts arws)
+ (pp_assigns (pp_reset_flag_chain self))
+ (mk_insts narws)
+ (pp_assigns pp_reset_flag')
+ [ mem ]
+ (pp_assigns (pp_register_chain ~indirect:false mem))
+ (mk_insts arws)
+ (pp_assigns (pp_reset_flag_chain ~indirect:false mem))
+ (mk_insts narws)
+ (pp_assumes (pp_equal pp_reset_flag' pp_print_int))
+ (mem, 1)
+ (pp_ensures (pp_initialization pp_ptr))
+ (name, mem)
+ (pp_assumes (pp_equal pp_reset_flag' pp_print_int))
+ (mem, 0)
+ (pp_ensures (pp_equal pp_ptr (pp_old pp_ptr)))
+ (mem, mem))
fmt ()
let pp_set_reset_spec fmt self mem m =
let name = m.mname.node_id in
- pp_acsl_cut (fun fmt () ->
- fprintf fmt
- "%a@,%a@,%a"
- (pp_ensures (pp_memory_pack_aux pp_ptr pp_print_string)) (name, mem, self)
- (pp_ensures (pp_equal pp_reset_flag' pp_print_int)) (mem, 1)
- (pp_assigns pp_reset_flag') [self; mem])
+ pp_acsl_cut
+ (fun fmt () ->
+ fprintf fmt "%a@,%a@,%a"
+ (pp_ensures (pp_memory_pack_aux pp_ptr pp_print_string))
+ (name, mem, self)
+ (pp_ensures (pp_equal pp_reset_flag' pp_print_int))
+ (mem, 1)
+ (pp_assigns pp_reset_flag')
+ [ self; mem ])
fmt ()
let pp_step_spec fmt machines self mem m =
let name = m.mname.node_id in
let insts = instances machines m in
let insts' = powerset_instances insts in
- let insts'' = List.(filter (fun l -> l <> [])
- (map (filter (fun (_, (td, _)) ->
- not (Arrow.td_is_arrow td))) insts)) in
+ let insts'' =
+ List.(
+ filter
+ (fun l -> l <> [])
+ (map (filter (fun (_, (td, _)) -> not (Arrow.td_is_arrow td))) insts))
+ in
let inputs = m.mstep.step_inputs in
let outputs = m.mstep.step_outputs in
- pp_acsl_cut (fun fmt () ->
+ pp_acsl_cut
+ (fun fmt () ->
if fst (get_stateless_status m) then
- fprintf fmt
- "%a@,%a@,%a@,%a"
- (pp_requires (pp_valid pp_var_decl)) outputs
- (pp_requires pp_separated') outputs
- (pp_assigns pp_ptr_decl) outputs
+ fprintf fmt "%a@,%a@,%a@,%a"
+ (pp_requires (pp_valid pp_var_decl))
+ outputs
+ (pp_requires pp_separated')
+ outputs (pp_assigns pp_ptr_decl) outputs
(pp_ensures (pp_transition_aux'' m))
(name, inputs, [], outputs, "", "")
else
fprintf fmt
"%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a@,%a"
- (pp_requires (pp_valid pp_var_decl)) outputs
- (pp_requires pp_mem_valid') (name, self)
- (pp_requires (pp_separated self mem)) (insts', outputs)
+ (pp_requires (pp_valid pp_var_decl))
+ outputs
+ (pp_requires pp_mem_valid')
+ (name, self)
+ (pp_requires (pp_separated self mem))
+ (insts', outputs)
(pp_requires (pp_memory_pack_aux pp_ptr pp_print_string))
(name, mem, self)
(pp_ensures (pp_memory_pack_aux pp_ptr pp_print_string))
(name, mem, self)
- (pp_ensures (pp_transition_aux m (pp_old pp_ptr)
- pp_ptr pp_var_decl pp_ptr_decl))
+ (pp_ensures
+ (pp_transition_aux m (pp_old pp_ptr) pp_ptr pp_var_decl
+ pp_ptr_decl))
(name, inputs, [], outputs, mem, mem)
(pp_assigns pp_ptr_decl) outputs
- (pp_assigns (pp_reg self)) m.mmemory
- (pp_assigns pp_reset_flag') [self]
- (pp_assigns (pp_memory self)) (memories insts')
- (pp_assigns (pp_register_chain self)) insts
- (pp_assigns (pp_reset_flag_chain self)) insts''
- (pp_assigns (pp_reg mem)) m.mmemory
- (pp_assigns pp_reset_flag') [mem]
- (pp_assigns (pp_memory ~indirect:false mem)) (memories insts')
- (pp_assigns (pp_register_chain ~indirect:false mem)) insts
- (pp_assigns (pp_reset_flag_chain ~indirect:false mem)) insts''
- )
+ (pp_assigns (pp_reg self))
+ m.mmemory
+ (pp_assigns pp_reset_flag')
+ [ self ]
+ (pp_assigns (pp_memory self))
+ (memories insts')
+ (pp_assigns (pp_register_chain self))
+ insts
+ (pp_assigns (pp_reset_flag_chain self))
+ insts''
+ (pp_assigns (pp_reg mem))
+ m.mmemory
+ (pp_assigns pp_reset_flag')
+ [ mem ]
+ (pp_assigns (pp_memory ~indirect:false mem))
+ (memories insts')
+ (pp_assigns (pp_register_chain ~indirect:false mem))
+ insts
+ (pp_assigns (pp_reset_flag_chain ~indirect:false mem))
+ insts'')
fmt ()
- let pp_ghost_instr_code m self fmt instr = match instr.instr_desc with
+ let pp_ghost_instr_code m self fmt instr =
+ match instr.instr_desc with
| MStateAssign (x, v) ->
fprintf fmt "@,%a"
- (pp_acsl_line
- (pp_ghost
- (pp_assign m self (pp_c_var_read m))))
+ (pp_acsl_line (pp_ghost (pp_assign m self (pp_c_var_read m))))
(x, v)
| MResetAssign b ->
- fprintf fmt "@,%a"
- (pp_acsl_line
- (pp_ghost
- (pp_reset_assign self)))
- b
+ fprintf fmt "@,%a" (pp_acsl_line (pp_ghost (pp_reset_assign self))) b
| MSetReset inst ->
let td, _ = List.assoc inst m.minstances in
if Arrow.td_is_arrow td then
- fprintf fmt "@,%a;"
- (pp_acsl_line
- (pp_ghost
- (pp_arrow_reset_ghost self)))
- inst
- | _ -> ()
+ fprintf fmt "@,%a;"
+ (pp_acsl_line (pp_ghost (pp_arrow_reset_ghost self)))
+ inst
+ | _ ->
+ ()
let pp_step_instr_spec m self mem fmt instr =
fprintf fmt "%a%a"
- (pp_ghost_instr_code m mem) instr
+ (pp_ghost_instr_code m mem)
+ instr
(pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut
(pp_acsl_line' (pp_assert (PrintSpec.pp_spec (InstrMode self) m))))
instr.instr_spec
@@ -899,11 +895,10 @@ module SrcMod = struct
let pp_ghost_parameter mem fmt inst =
GhostProto.pp_ghost_parameters ~cut:false fmt
(match inst with
- | Some inst ->
- [inst, fun fmt inst -> fprintf fmt "&%a" pp_indirect' (mem, inst)]
- | None ->
- [mem, pp_print_string])
-
+ | Some inst ->
+ [ (inst, fun fmt inst -> fprintf fmt "&%a" pp_indirect' (mem, inst)) ]
+ | None ->
+ [ mem, pp_print_string ])
end
(**************************************************************************)
@@ -911,43 +906,50 @@ end
(**************************************************************************)
module MakefileMod = struct
-
let other_targets fmt basename _nodename dependencies =
fprintf fmt "FRAMACEACSL=`frama-c -print-share-path`/e-acsl@.";
(* EACSL version of library file . c *)
fprintf fmt "%s_eacsl.c: %s.c %s.h@." basename basename basename;
fprintf fmt
- "\tframa-c -e-acsl-full-mmodel -machdep x86_64 -e-acsl %s.c -then-on e-acsl -print -ocode %s_eacsl.c@."
+ "\tframa-c -e-acsl-full-mmodel -machdep x86_64 -e-acsl %s.c -then-on \
+ e-acsl -print -ocode %s_eacsl.c@."
basename basename;
fprintf fmt "@.";
fprintf fmt "@.";
- (* EACSL version of library file . c + main .c *)
- fprintf fmt "%s_main_eacsl.c: %s.c %s.h %s_main.c@." basename basename basename basename;
- fprintf fmt "\tframa-c -e-acsl-full-mmodel -machdep x86_64 -e-acsl %s.c %s_main.c -then-on e-acsl -print -ocode %s_main_eacsl.i@."
+ (* EACSL version of library file . c + main .c *)
+ fprintf fmt "%s_main_eacsl.c: %s.c %s.h %s_main.c@." basename basename
+ basename basename;
+ fprintf fmt
+ "\tframa-c -e-acsl-full-mmodel -machdep x86_64 -e-acsl %s.c %s_main.c \
+ -then-on e-acsl -print -ocode %s_main_eacsl.i@."
basename basename basename;
(* Ugly hack to deal with eacsl bugs *)
- fprintf fmt "\tgrep -v _fc_stdout %s_main_eacsl.i > %s_main_eacsl.c" basename basename;
+ fprintf fmt "\tgrep -v _fc_stdout %s_main_eacsl.i > %s_main_eacsl.c"
+ basename basename;
fprintf fmt "@.";
fprintf fmt "@.";
(* EACSL version of binary *)
fprintf fmt "%s_main_eacsl: %s_main_eacsl.c@." basename basename;
- fprintf fmt "\t${GCC} -Wno-attributes -I${INC} -I. -c %s_main_eacsl.c@." basename; (* compiling instrumented lib + main *)
+ fprintf fmt "\t${GCC} -Wno-attributes -I${INC} -I. -c %s_main_eacsl.c@."
+ basename;
+ (* compiling instrumented lib + main *)
C_backend_makefile.fprintf_dependencies fmt dependencies;
- fprintf fmt "\t${GCC} -Wno-attributes -o %s_main_eacsl io_frontend.o %a %s %s_main_eacsl.o %a@."
+ fprintf fmt
+ "\t${GCC} -Wno-attributes -o %s_main_eacsl io_frontend.o %a %s \
+ %s_main_eacsl.o %a@."
basename
- (Utils.fprintf_list ~sep:" " (fun fmt dep -> Format.fprintf fmt "%s.o" dep.name))
+ (Utils.fprintf_list ~sep:" " (fun fmt dep ->
+ Format.fprintf fmt "%s.o" dep.name))
(C_backend_makefile.compiled_dependencies dependencies)
("${FRAMACEACSL}/e_acsl.c "
- ^ "${FRAMACEACSL}/memory_model/e_acsl_bittree.c "
- ^ "${FRAMACEACSL}/memory_model/e_acsl_mmodel.c")
+ ^ "${FRAMACEACSL}/memory_model/e_acsl_bittree.c "
+ ^ "${FRAMACEACSL}/memory_model/e_acsl_mmodel.c")
basename
(Utils.fprintf_list ~sep:" " (fun fmt lib -> fprintf fmt "-l%s" lib))
- (C_backend_makefile.lib_dependencies dependencies)
- ;
+ (C_backend_makefile.lib_dependencies dependencies);
fprintf fmt "@."
-
end
(* Local Variables: *)
diff --git a/src/backends/C/c_backend_src.ml b/src/backends/C/c_backend_src.ml
index e7d245cfb09c293f15e6d101cf565bb6c8ccdebc..e7711d4d89472c9e7b46fa817d96d288aa7242c9 100644
--- a/src/backends/C/c_backend_src.ml
+++ b/src/backends/C/c_backend_src.ml
@@ -17,853 +17,841 @@ open Machine_code_common
open C_backend_common
module type MODIFIERS_SRC = sig
- module GhostProto: MODIFIERS_GHOST_PROTO
- val pp_predicates: formatter -> machine_t list -> unit
- val pp_set_reset_spec: formatter -> ident -> ident -> machine_t -> unit
- val pp_clear_reset_spec: formatter -> ident -> ident -> machine_t -> unit
- val pp_step_spec: formatter -> machine_t list -> ident -> ident -> machine_t -> unit
- val pp_step_instr_spec: machine_t -> ident -> ident -> formatter -> instr_t -> unit
- val pp_ghost_parameter: ident -> formatter -> ident option -> unit
+ module GhostProto : MODIFIERS_GHOST_PROTO
+
+ val pp_predicates : formatter -> machine_t list -> unit
+
+ val pp_set_reset_spec : formatter -> ident -> ident -> machine_t -> unit
+
+ val pp_clear_reset_spec : formatter -> ident -> ident -> machine_t -> unit
+
+ val pp_step_spec :
+ formatter -> machine_t list -> ident -> ident -> machine_t -> unit
+
+ val pp_step_instr_spec :
+ machine_t -> ident -> ident -> formatter -> instr_t -> unit
+
+ val pp_ghost_parameter : ident -> formatter -> ident option -> unit
end
module EmptyMod = struct
module GhostProto = EmptyGhostProto
+
let pp_predicates _ _ = ()
+
let pp_set_reset_spec _ _ _ _ = ()
+
let pp_clear_reset_spec _ _ _ _ = ()
+
let pp_step_spec _ _ _ _ _ = ()
+
let pp_step_instr_spec _ _ _ _ _ = ()
+
let pp_ghost_parameter _ _ _ = ()
end
-module Main = functor (Mod: MODIFIERS_SRC) -> struct
-
- module Protos = Protos(Mod.GhostProto)
-
- (********************************************************************************************)
- (* Instruction Printing functions *)
- (********************************************************************************************)
-
-
- let rec merge_static_loop_profiles lp1 lp2 =
- match lp1, lp2 with
- | [] , _ -> lp2
- | _ , [] -> lp1
- | p1 :: q1, p2 :: q2 -> (p1 || p2) :: merge_static_loop_profiles q1 q2
-
- (* Returns a list of bool values, indicating whether the indices must be static or not *)
- let rec static_loop_profile v =
- match v.value_desc with
- | Cst cst -> static_loop_profile_cst cst
- | Var _ | ResetFlag -> []
- | Fun (_, vl) ->
- List.fold_right
- (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl []
- | Array vl ->
- true :: List.fold_right
- (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl []
- | Access (v, _) ->
- begin match static_loop_profile v with [] -> [] | _ :: q -> q end
- | Power (v, _) -> false :: static_loop_profile v
- and static_loop_profile_cst cst =
- match cst with
- Const_array cl ->
- List.fold_right
- (fun c lp -> merge_static_loop_profiles lp (static_loop_profile_cst c))
- cl []
- | _ -> []
-
-
- (* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution
- which may yield constant arrays in expressions.
- Type is needed to correctly print constant arrays.
- *)
- let pp_c_val m self pp_var fmt v =
- pp_value_suffix m self v.value_type [] pp_var fmt v
-
- let pp_machine_ pp_machine_name fn_name m fmt ?inst self mem =
- let name, is_arrow, static =
- match inst with
- | Some inst ->
- let node, static = try List.assoc inst m.minstances with Not_found ->
- eprintf "internal error: %s %s %s %s:@."
- fn_name m.mname.node_id self inst;
- raise Not_found
- in
- node_name node, Arrow.td_is_arrow node, static
- | None ->
- m.mname.node_id, false, []
- in
- let is_arrow_reset = is_arrow && fn_name = "pp_machine_set_reset" in
- fprintf fmt "%a(%a%s%a)%a;"
- (if is_arrow_reset then
- (fun fmt -> fprintf fmt "%s_reset")
- else
- pp_machine_name) name
- (pp_comma_list ~pp_eol:pp_print_comma Dimension.pp_dimension) static
- self
- (pp_print_option (fun fmt -> fprintf fmt "->%s")) inst
- (if is_arrow_reset then pp_print_nothing else Mod.pp_ghost_parameter mem)
- inst
-
- let pp_machine_set_reset m self mem fmt inst =
- pp_machine_ pp_machine_set_reset_name "pp_machine_set_reset" m fmt ~inst
- self mem
-
- let pp_machine_clear_reset m self mem fmt =
- pp_machine_ pp_machine_clear_reset_name "pp_machine_clear_reset" m fmt
- self mem
-
- let pp_machine_init m self mem fmt inst =
- pp_machine_ pp_machine_init_name "pp_machine_init" m fmt ~inst self mem
-
- let pp_machine_clear m self mem fmt inst =
- pp_machine_ pp_machine_clear_name "pp_machine_clear" m fmt ~inst self mem
-
- let pp_call m self mem pp_read pp_write fmt i inputs outputs =
- try (* stateful node instance *)
- let n, _ = List.assoc i m.minstances in
- fprintf fmt "%a(%a%a%s->%s)%a;"
- pp_machine_step_name (node_name n)
- (pp_comma_list ~pp_eol:pp_print_comma
- (pp_c_val m self pp_read)) inputs
- (pp_comma_list ~pp_eol:pp_print_comma
- pp_write) outputs
- self
- i
- (Mod.pp_ghost_parameter mem) (Some i)
- with Not_found -> (* stateless node instance *)
- let n, _ = List.assoc i m.mcalls in
- fprintf fmt "%a(%a%a);"
- pp_machine_step_name (node_name n)
- (pp_comma_list ~pp_eol:pp_print_comma
- (pp_c_val m self pp_read)) inputs
- (pp_comma_list pp_write) outputs
-
- let pp_basic_instance_call m self mem =
- pp_call m self mem (pp_c_var_read m) (pp_c_var_write m)
-
- let pp_arrow_call m self mem fmt i outputs =
- match outputs with
- | [x] ->
- fprintf fmt "%a = %a(%s->%s)%a;"
- (pp_c_var_read m) x
- pp_machine_step_name Arrow.arrow_id
- self
- i
- (Mod.pp_ghost_parameter mem) (Some i)
- | _ -> assert false
-
- let pp_instance_call m self mem fmt i inputs outputs =
- let pp_offset pp_var indices fmt var =
- fprintf fmt "%a%a"
- pp_var var
- (pp_print_list ~pp_sep:pp_print_nothing (fun fmt -> fprintf fmt "[%s]"))
- indices
- in
- let rec aux indices fmt typ =
- if Types.is_array_type typ
+module Main =
+functor
+ (Mod : MODIFIERS_SRC)
+ ->
+ struct
+ module Protos = Protos (Mod.GhostProto)
+
+ (********************************************************************************************)
+ (* Instruction Printing functions *)
+ (********************************************************************************************)
+
+ let rec merge_static_loop_profiles lp1 lp2 =
+ match lp1, lp2 with
+ | [], _ ->
+ lp2
+ | _, [] ->
+ lp1
+ | p1 :: q1, p2 :: q2 ->
+ (p1 || p2) :: merge_static_loop_profiles q1 q2
+
+ (* Returns a list of bool values, indicating whether the indices must be
+ static or not *)
+ let rec static_loop_profile v =
+ match v.value_desc with
+ | Cst cst ->
+ static_loop_profile_cst cst
+ | Var _ | ResetFlag ->
+ []
+ | Fun (_, vl) ->
+ List.fold_right
+ (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v))
+ vl []
+ | Array vl ->
+ true
+ ::
+ List.fold_right
+ (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v))
+ vl []
+ | Access (v, _) -> (
+ match static_loop_profile v with [] -> [] | _ :: q -> q)
+ | Power (v, _) ->
+ false :: static_loop_profile v
+
+ and static_loop_profile_cst cst =
+ match cst with
+ | Const_array cl ->
+ List.fold_right
+ (fun c lp ->
+ merge_static_loop_profiles lp (static_loop_profile_cst c))
+ cl []
+ | _ ->
+ []
+
+ (* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution
+ which may yield constant arrays in expressions. Type is needed to
+ correctly print constant arrays. *)
+ let pp_c_val m self pp_var fmt v =
+ pp_value_suffix m self v.value_type [] pp_var fmt v
+
+ let pp_machine_ pp_machine_name fn_name m fmt ?inst self mem =
+ let name, is_arrow, static =
+ match inst with
+ | Some inst ->
+ let node, static =
+ try List.assoc inst m.minstances
+ with Not_found ->
+ eprintf "internal error: %s %s %s %s:@." fn_name m.mname.node_id
+ self inst;
+ raise Not_found
+ in
+ node_name node, Arrow.td_is_arrow node, static
+ | None ->
+ m.mname.node_id, false, []
+ in
+ let is_arrow_reset = is_arrow && fn_name = "pp_machine_set_reset" in
+ fprintf fmt "%a(%a%s%a)%a;"
+ (if is_arrow_reset then fun fmt -> fprintf fmt "%s_reset"
+ else pp_machine_name)
+ name
+ (pp_comma_list ~pp_eol:pp_print_comma Dimension.pp_dimension)
+ static self
+ (pp_print_option (fun fmt -> fprintf fmt "->%s"))
+ inst
+ (if is_arrow_reset then pp_print_nothing
+ else Mod.pp_ghost_parameter mem)
+ inst
+
+ let pp_machine_set_reset m self mem fmt inst =
+ pp_machine_ pp_machine_set_reset_name "pp_machine_set_reset" m fmt ~inst
+ self mem
+
+ let pp_machine_clear_reset m self mem fmt =
+ pp_machine_ pp_machine_clear_reset_name "pp_machine_clear_reset" m fmt
+ self mem
+
+ let pp_machine_init m self mem fmt inst =
+ pp_machine_ pp_machine_init_name "pp_machine_init" m fmt ~inst self mem
+
+ let pp_machine_clear m self mem fmt inst =
+ pp_machine_ pp_machine_clear_name "pp_machine_clear" m fmt ~inst self mem
+
+ let pp_call m self mem pp_read pp_write fmt i inputs outputs =
+ try
+ (* stateful node instance *)
+ let n, _ = List.assoc i m.minstances in
+ fprintf fmt "%a(%a%a%s->%s)%a;" pp_machine_step_name (node_name n)
+ (pp_comma_list ~pp_eol:pp_print_comma (pp_c_val m self pp_read))
+ inputs
+ (pp_comma_list ~pp_eol:pp_print_comma pp_write)
+ outputs self i
+ (Mod.pp_ghost_parameter mem)
+ (Some i)
+ with Not_found ->
+ (* stateless node instance *)
+ let n, _ = List.assoc i m.mcalls in
+ fprintf fmt "%a(%a%a);" pp_machine_step_name (node_name n)
+ (pp_comma_list ~pp_eol:pp_print_comma (pp_c_val m self pp_read))
+ inputs (pp_comma_list pp_write) outputs
+
+ let pp_basic_instance_call m self mem =
+ pp_call m self mem (pp_c_var_read m) (pp_c_var_write m)
+
+ let pp_arrow_call m self mem fmt i outputs =
+ match outputs with
+ | [ x ] ->
+ fprintf fmt "%a = %a(%s->%s)%a;" (pp_c_var_read m) x
+ pp_machine_step_name Arrow.arrow_id self i
+ (Mod.pp_ghost_parameter mem)
+ (Some i)
+ | _ ->
+ assert false
+
+ let pp_instance_call m self mem fmt i inputs outputs =
+ let pp_offset pp_var indices fmt var =
+ fprintf fmt "%a%a" pp_var var
+ (pp_print_list ~pp_sep:pp_print_nothing (fun fmt ->
+ fprintf fmt "[%s]"))
+ indices
+ in
+ let rec aux indices fmt typ =
+ if Types.is_array_type typ then
+ let dim = Types.array_type_dimension typ in
+ let idx = mk_loop_var m () in
+ fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" idx
+ idx idx pp_c_dimension dim idx
+ (aux (idx :: indices))
+ (Types.array_element_type typ)
+ else
+ let pp_read = pp_offset (pp_c_var_read m) indices in
+ let pp_write = pp_offset (pp_c_var_write m) indices in
+ pp_call m self mem pp_read pp_write fmt i inputs outputs
+ in
+ reset_loop_counter ();
+ aux [] fmt (List.hd inputs).Machine_code_types.value_type
+
+ let rec pp_conditional dependencies m self mem fmt c tl el =
+ let pp_machine_instrs =
+ pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut
+ (pp_machine_instr dependencies m self mem)
+ in
+ let pp_cond = pp_c_val m self (pp_c_var_read m) in
+ match tl, el with
+ | [], _ :: _ ->
+ fprintf fmt "@[<v 2>if (!%a) {%a@]@,}" pp_cond c pp_machine_instrs el
+ | _, [] ->
+ fprintf fmt "@[<v 2>if (%a) {%a@]@,}" pp_cond c pp_machine_instrs tl
+ | _, _ ->
+ fprintf fmt "@[<v 2>if (%a) {%a@]@,@[<v 2>} else {%a@]@,}" pp_cond c
+ pp_machine_instrs tl pp_machine_instrs el
+
+ and pp_machine_instr dependencies m self mem fmt instr =
+ let pp_instr fmt instr =
+ match get_instr_desc instr with
+ | MNoReset _ ->
+ ()
+ | MSetReset inst ->
+ pp_machine_set_reset m self mem fmt inst
+ | MClearReset ->
+ fprintf fmt "%t@,%a"
+ (pp_machine_clear_reset m self mem)
+ pp_label reset_label
+ | MResetAssign b ->
+ pp_reset_assign self fmt b
+ | MLocalAssign (i, v) ->
+ pp_assign m self (pp_c_var_read m) fmt (i, v)
+ | MStateAssign (i, v) ->
+ pp_assign m self (pp_c_var_read m) fmt (i, v)
+ | MStep ([ i0 ], i, vl)
+ when Basic_library.is_value_internal_fun
+ (mk_val (Fun (i, vl)) i0.var_type) ->
+ pp_machine_instr dependencies m self mem fmt
+ (update_instr_desc instr
+ (MLocalAssign (i0, mk_val (Fun (i, vl)) i0.var_type)))
+ | MStep (il, i, vl) when !Options.mpfr && Mpfr.is_homomorphic_fun i ->
+ pp_instance_call m self mem fmt i vl il
+ | MStep ([ i0 ], i, vl) when has_c_prototype i dependencies ->
+ fprintf fmt "%a = %s%a;"
+ (pp_c_val m self (pp_c_var_read m))
+ (mk_val (Var i0) i0.var_type)
+ i
+ (pp_print_parenthesized (pp_c_val m self (pp_c_var_read m)))
+ vl
+ | MStep (il, i, vl) ->
+ let td, _ = List.assoc i m.minstances in
+ if Arrow.td_is_arrow td then pp_arrow_call m self mem fmt i il
+ else pp_basic_instance_call m self mem fmt i vl il
+ | MBranch (_, []) ->
+ eprintf "internal error: C_backend_src.pp_machine_instr %a@."
+ (pp_instr m) instr;
+ assert false
+ | MBranch (g, hl) ->
+ if
+ let t = fst (List.hd hl) in
+ t = tag_true || t = tag_false
+ then
+ (* boolean case, needs special treatment in C because truth value is
+ not unique *)
+ (* may disappear if we optimize code by replacing last branch test
+ with default *)
+ let tl = try List.assoc tag_true hl with Not_found -> [] in
+ let el = try List.assoc tag_false hl with Not_found -> [] in
+ let no_noreset =
+ List.filter (fun i ->
+ match i.instr_desc with MNoReset _ -> false | _ -> true)
+ in
+ pp_conditional dependencies m self mem fmt g (no_noreset tl)
+ (no_noreset el)
+ else
+ (* enum type case *)
+ (*let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst
+ (List.hd hl))) in*)
+ fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
+ (pp_c_val m self (pp_c_var_read m))
+ g
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_machine_branch dependencies m self mem))
+ hl
+ | MSpec s ->
+ fprintf fmt "@[/*@@ %s */@]@ " s
+ | MComment s ->
+ fprintf fmt "/*%s*/@ " s
+ in
+ fprintf fmt "%a%a" pp_instr instr
+ (Mod.pp_step_instr_spec m self mem)
+ instr
+
+ and pp_machine_branch dependencies m self mem fmt (t, h) =
+ fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_c_tag t
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ (pp_machine_instr dependencies m self mem))
+ h
+
+ (* let pp_machine_nospec_instr dependencies m self fmt instr =
+ * pp_machine_instr dependencies m self fmt instr
+ *
+ * let pp_machine_step_instr dependencies m self mem fmt instr =
+ * fprintf fmt "%a%a"
+ * (pp_machine_instr dependencies m self) instr
+ * (Mod.pp_step_instr_spec m self mem) instr *)
+
+ (********************************************************************************************)
+ (* C file Printing functions *)
+ (********************************************************************************************)
+
+ let print_const_def fmt tdecl =
+ let cdecl = const_of_top tdecl in
+ if
+ !Options.mpfr && Types.(is_real_type (array_base_type cdecl.const_type))
then
- let dim = Types.array_type_dimension typ in
- let idx = mk_loop_var m () in
- fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
- idx idx idx pp_c_dimension dim idx
- (aux (idx::indices)) (Types.array_element_type typ)
+ fprintf fmt "%a;" (pp_c_type cdecl.const_id)
+ (Types.dynamic_type cdecl.const_type)
else
- let pp_read = pp_offset (pp_c_var_read m) indices in
- let pp_write = pp_offset (pp_c_var_write m) indices in
- pp_call m self mem pp_read pp_write fmt i inputs outputs
- in
- reset_loop_counter ();
- aux [] fmt (List.hd inputs).Machine_code_types.value_type
-
- let rec pp_conditional dependencies m self mem fmt c tl el =
- let pp_machine_instrs =
- pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut
- (pp_machine_instr dependencies m self mem) in
- let pp_cond = pp_c_val m self (pp_c_var_read m) in
- match tl, el with
- | [], _ :: _ ->
- fprintf fmt "@[<v 2>if (!%a) {%a@]@,}"
- pp_cond c
- pp_machine_instrs el
- | _, [] ->
- fprintf fmt "@[<v 2>if (%a) {%a@]@,}"
- pp_cond c
- pp_machine_instrs tl
- | _, _ ->
- fprintf fmt "@[<v 2>if (%a) {%a@]@,@[<v 2>} else {%a@]@,}"
- pp_cond c
- pp_machine_instrs tl
- pp_machine_instrs el
-
- and pp_machine_instr dependencies m self mem fmt instr =
- let pp_instr fmt instr = match get_instr_desc instr with
- | MNoReset _ -> ()
- | MSetReset inst ->
- pp_machine_set_reset m self mem fmt inst
- | MClearReset ->
- fprintf fmt "%t@,%a"
- (pp_machine_clear_reset m self mem) pp_label reset_label
- | MResetAssign b ->
- pp_reset_assign self fmt b
- | MLocalAssign (i, v) ->
- pp_assign m self (pp_c_var_read m) fmt (i, v)
- | MStateAssign (i, v) ->
- pp_assign m self (pp_c_var_read m) fmt (i, v)
- | MStep ([i0], i, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (i, vl)) i0.var_type) ->
- pp_machine_instr dependencies m self mem fmt
- (update_instr_desc instr (MLocalAssign (i0, mk_val (Fun (i, vl)) i0.var_type)))
- | MStep (il, i, vl) when !Options.mpfr && Mpfr.is_homomorphic_fun i ->
- pp_instance_call m self mem fmt i vl il
- | MStep ([i0], i, vl) when has_c_prototype i dependencies ->
- fprintf fmt "%a = %s%a;"
- (pp_c_val m self (pp_c_var_read m)) (mk_val (Var i0) i0.var_type)
- i
- (pp_print_parenthesized (pp_c_val m self (pp_c_var_read m))) vl
- | MStep (il, i, vl) ->
- let td, _ = List.assoc i m.minstances in
- if Arrow.td_is_arrow td then
- pp_arrow_call m self mem fmt i il
- else
- pp_basic_instance_call m self mem fmt i vl il
- | MBranch (_, []) ->
- eprintf "internal error: C_backend_src.pp_machine_instr %a@."
- (pp_instr m) instr;
- assert false
- | MBranch (g, hl) ->
- if let t = fst (List.hd hl) in t = tag_true || t = tag_false
- then (* boolean case, needs special treatment in C because truth value is not unique *)
- (* may disappear if we optimize code by replacing last branch test with default *)
- let tl = try List.assoc tag_true hl with Not_found -> [] in
- let el = try List.assoc tag_false hl with Not_found -> [] in
- let no_noreset = List.filter (fun i -> match i.instr_desc with
- | MNoReset _ -> false
- | _ -> true)
- in
- pp_conditional dependencies m self mem fmt g
- (no_noreset tl) (no_noreset el)
- else (* enum type case *)
- (*let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst (List.hd hl))) in*)
- fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
- (pp_c_val m self (pp_c_var_read m)) g
- (pp_print_list ~pp_open_box:pp_open_vbox0
- (pp_machine_branch dependencies m self mem)) hl
- | MSpec s ->
- fprintf fmt "@[/*@@ %s */@]@ " s
- | MComment s ->
- fprintf fmt "/*%s*/@ " s
- in
- fprintf fmt "%a%a" pp_instr instr (Mod.pp_step_instr_spec m self mem) instr
-
- and pp_machine_branch dependencies m self mem fmt (t, h) =
- fprintf fmt "@[<v 2>case %a:@,%a@,break;@]"
- pp_c_tag t
- (pp_print_list ~pp_open_box:pp_open_vbox0
- (pp_machine_instr dependencies m self mem)) h
-
- (* let pp_machine_nospec_instr dependencies m self fmt instr =
- * pp_machine_instr dependencies m self fmt instr
- *
- * let pp_machine_step_instr dependencies m self mem fmt instr =
- * fprintf fmt "%a%a"
- * (pp_machine_instr dependencies m self) instr
- * (Mod.pp_step_instr_spec m self mem) instr *)
-
- (********************************************************************************************)
- (* C file Printing functions *)
- (********************************************************************************************)
-
- let print_const_def fmt tdecl =
- let cdecl = const_of_top tdecl in
- if !Options.mpfr && Types.(is_real_type (array_base_type cdecl.const_type))
- then
- fprintf fmt "%a;"
- (pp_c_type cdecl.const_id) (Types.dynamic_type cdecl.const_type)
- else
- fprintf fmt "%a = %a;"
- (pp_c_type cdecl.const_id) cdecl.const_type
- pp_c_const cdecl.const_value
-
- let print_alloc_instance fmt (i, (m, static)) =
- fprintf fmt "_alloc->%s = %a %a;"
- i
- pp_machine_alloc_name (node_name m)
- (pp_print_parenthesized Dimension.pp_dimension) static
-
- let print_dealloc_instance fmt (i, (m, _)) =
- fprintf fmt "%a (_alloc->%s);"
- pp_machine_dealloc_name (node_name m)
- i
-
- let const_locals m =
- List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals
-
- let pp_c_decl_array_mem self fmt id =
- fprintf fmt "%a = (%a) (%s->_reg.%s)"
- (pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type
- (pp_c_type "(*)") id.var_type
- self
- id.var_id
-
- let print_alloc_const fmt m =
- pp_print_list
- ~pp_sep:(pp_print_endcut ";") ~pp_eol:(pp_print_endcut ";")
- (pp_c_decl_local_var m) fmt (const_locals m)
-
- let print_alloc_array fmt vdecl =
- let base_type = Types.array_base_type vdecl.var_type in
- let size_types = Types.array_type_multi_dimension vdecl.var_type in
- let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
- fprintf fmt
- "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,\
- assert(_alloc->%s);"
- vdecl.var_id
- (pp_c_type "") base_type
- Dimension.pp_dimension size_type
- (pp_c_type "") base_type
- vdecl.var_id
-
- let print_dealloc_array fmt vdecl =
- fprintf fmt "free (_alloc->_reg.%s);"
- vdecl.var_id
-
- let array_mems m =
- List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory
-
- let print_alloc_code fmt m =
- fprintf fmt
- "%a *_alloc;@,\
- _alloc = (%a *) malloc(sizeof(%a));@,\
- assert(_alloc);@,\
- %a%areturn _alloc;"
- (pp_machine_memtype_name ~ghost:false) m.mname.node_id
- (pp_machine_memtype_name ~ghost:false) m.mname.node_id
- (pp_machine_memtype_name ~ghost:false) m.mname.node_id
- (pp_print_list ~pp_sep:pp_print_nothing print_alloc_array) (array_mems m)
- (pp_print_list ~pp_sep:pp_print_nothing print_alloc_instance) m.minstances
-
- let print_dealloc_code fmt m =
- fprintf fmt
- "%a%afree (_alloc);@,\
- return;"
- (pp_print_list ~pp_sep:pp_print_nothing print_dealloc_array) (array_mems m)
- (pp_print_list ~pp_sep:pp_print_nothing print_dealloc_instance) m.minstances
-
- (* let print_stateless_init_code fmt m self =
- * let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
- * let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
- * fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
- * (print_init_prototype self) (m.mname.node_id, m.mstatic)
- * (\* array mems *\)
- * (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
- * (Utils.pp_final_char_if_non_empty ";@," array_mems)
- * (\* memory initialization *\)
- * (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory
- * (Utils.pp_newline_if_non_empty m.mmemory)
- * (\* sub-machines initialization *\)
- * (Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit
- * (Utils.pp_newline_if_non_empty m.minit)
- *
- * let print_stateless_clear_code fmt m self =
- * let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
- * let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
- * fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
- * (print_clear_prototype self) (m.mname.node_id, m.mstatic)
- * (\* array mems *\)
- * (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
- * (Utils.pp_final_char_if_non_empty ";@," array_mems)
- * (\* memory clear *\)
- * (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory
- * (Utils.pp_newline_if_non_empty m.mmemory)
- * (\* sub-machines clear*\)
- * (Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit
- * (Utils.pp_newline_if_non_empty m.minit) *)
-
- let pp_c_check m self fmt (loc, check) =
- fprintf fmt "@[<v>%a@,assert (%a);@]"
- Location.pp_c_loc loc
- (pp_c_val m self (pp_c_var_read m)) check
-
- let pp_print_function
- ~pp_prototype ~prototype
- ?(pp_spec=pp_print_nothing)
- ?(pp_local=pp_print_nothing) ?(base_locals=[])
- ?(pp_array_mem=pp_print_nothing) ?(array_mems=[])
- ?(pp_init_mpfr_local=pp_print_nothing)
- ?(pp_clear_mpfr_local=pp_print_nothing)
- ?(mpfr_locals=[])
- ?(pp_check=pp_print_nothing) ?(checks=[])
- ?(pp_extra=pp_print_nothing)
- ?(pp_instr=fun fmt _ -> pp_print_nothing fmt ()) ?(instrs=[])
- fmt =
- fprintf fmt
- "%a@[<v 2>%a {@,\
- %a%a\
- %a%a%a%a%areturn;@]@,\
- }"
- pp_spec ()
- pp_prototype prototype
- (* locals *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_sep:pp_print_semicolon
- ~pp_eol:pp_print_semicolon
- pp_local)
- base_locals
- (* array mems *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_sep:pp_print_semicolon
- ~pp_eol:pp_print_semicolon
- pp_array_mem)
- array_mems
- (* locals initialization *)
- (pp_print_list
- ~pp_epilogue:pp_print_cut
- pp_init_mpfr_local) (mpfr_vars mpfr_locals)
- (* check assertions *)
- (pp_print_list pp_check) checks
- (* instrs *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_epilogue:pp_print_cut
- pp_instr) instrs
- (* locals clear *)
- (pp_print_list
- ~pp_epilogue:pp_print_cut
- pp_clear_mpfr_local) (mpfr_vars mpfr_locals)
- (* extra *)
- pp_extra ()
-
- let node_of_machine m = {
- top_decl_desc = Node m.mname;
- top_decl_loc = Location.dummy_loc;
- top_decl_owner = "";
- top_decl_itf = false
- }
-
- let print_stateless_code machines dependencies fmt m =
- let self = "__ERROR__" in
- if not (!Options.ansi && is_generic_node (node_of_machine m))
- then
- (* C99 code *)
+ fprintf fmt "%a = %a;" (pp_c_type cdecl.const_id) cdecl.const_type
+ pp_c_const cdecl.const_value
+
+ let print_alloc_instance fmt (i, (m, static)) =
+ fprintf fmt "_alloc->%s = %a %a;" i pp_machine_alloc_name (node_name m)
+ (pp_print_parenthesized Dimension.pp_dimension)
+ static
+
+ let print_dealloc_instance fmt (i, (m, _)) =
+ fprintf fmt "%a (_alloc->%s);" pp_machine_dealloc_name (node_name m) i
+
+ let const_locals m =
+ List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals
+
+ let pp_c_decl_array_mem self fmt id =
+ fprintf fmt "%a = (%a) (%s->_reg.%s)"
+ (pp_c_type (sprintf "(*%s)" id.var_id))
+ id.var_type (pp_c_type "(*)") id.var_type self id.var_id
+
+ let print_alloc_const fmt m =
+ pp_print_list ~pp_sep:(pp_print_endcut ";") ~pp_eol:(pp_print_endcut ";")
+ (pp_c_decl_local_var m) fmt (const_locals m)
+
+ let print_alloc_array fmt vdecl =
+ let base_type = Types.array_base_type vdecl.var_type in
+ let size_types = Types.array_type_multi_dimension vdecl.var_type in
+ let size_type =
+ Dimension.multi_dimension_product vdecl.var_loc size_types
+ in
+ fprintf fmt
+ "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);"
+ vdecl.var_id (pp_c_type "") base_type Dimension.pp_dimension size_type
+ (pp_c_type "") base_type vdecl.var_id
+
+ let print_dealloc_array fmt vdecl =
+ fprintf fmt "free (_alloc->_reg.%s);" vdecl.var_id
+
+ let array_mems m =
+ List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory
+
+ let print_alloc_code fmt m =
+ fprintf fmt
+ "%a *_alloc;@,\
+ _alloc = (%a *) malloc(sizeof(%a));@,\
+ assert(_alloc);@,\
+ %a%areturn _alloc;"
+ (pp_machine_memtype_name ~ghost:false)
+ m.mname.node_id
+ (pp_machine_memtype_name ~ghost:false)
+ m.mname.node_id
+ (pp_machine_memtype_name ~ghost:false)
+ m.mname.node_id
+ (pp_print_list ~pp_sep:pp_print_nothing print_alloc_array)
+ (array_mems m)
+ (pp_print_list ~pp_sep:pp_print_nothing print_alloc_instance)
+ m.minstances
+
+ let print_dealloc_code fmt m =
+ fprintf fmt "%a%afree (_alloc);@,return;"
+ (pp_print_list ~pp_sep:pp_print_nothing print_dealloc_array)
+ (array_mems m)
+ (pp_print_list ~pp_sep:pp_print_nothing print_dealloc_instance)
+ m.minstances
+
+ (* let print_stateless_init_code fmt m self =
+ * let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
+ * let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
+ * fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
+ * (print_init_prototype self) (m.mname.node_id, m.mstatic)
+ * (\* array mems *\)
+ * (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
+ * (Utils.pp_final_char_if_non_empty ";@," array_mems)
+ * (\* memory initialization *\)
+ * (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory
+ * (Utils.pp_newline_if_non_empty m.mmemory)
+ * (\* sub-machines initialization *\)
+ * (Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit
+ * (Utils.pp_newline_if_non_empty m.minit)
+ *
+ * let print_stateless_clear_code fmt m self =
+ * let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
+ * let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
+ * fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
+ * (print_clear_prototype self) (m.mname.node_id, m.mstatic)
+ * (\* array mems *\)
+ * (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
+ * (Utils.pp_final_char_if_non_empty ";@," array_mems)
+ * (\* memory clear *\)
+ * (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory
+ * (Utils.pp_newline_if_non_empty m.mmemory)
+ * (\* sub-machines clear*\)
+ * (Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit
+ * (Utils.pp_newline_if_non_empty m.minit) *)
+
+ let pp_c_check m self fmt (loc, check) =
+ fprintf fmt "@[<v>%a@,assert (%a);@]" Location.pp_c_loc loc
+ (pp_c_val m self (pp_c_var_read m))
+ check
+
+ let pp_print_function ~pp_prototype ~prototype ?(pp_spec = pp_print_nothing)
+ ?(pp_local = pp_print_nothing) ?(base_locals = [])
+ ?(pp_array_mem = pp_print_nothing) ?(array_mems = [])
+ ?(pp_init_mpfr_local = pp_print_nothing)
+ ?(pp_clear_mpfr_local = pp_print_nothing) ?(mpfr_locals = [])
+ ?(pp_check = pp_print_nothing) ?(checks = [])
+ ?(pp_extra = pp_print_nothing)
+ ?(pp_instr = fun fmt _ -> pp_print_nothing fmt ()) ?(instrs = []) fmt =
+ fprintf fmt "%a@[<v 2>%a {@,%a%a%a%a%a%a%areturn;@]@,}" pp_spec ()
+ pp_prototype prototype
+ (* locals *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_sep:pp_print_semicolon
+ ~pp_eol:pp_print_semicolon pp_local)
+ base_locals
+ (* array mems *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_sep:pp_print_semicolon
+ ~pp_eol:pp_print_semicolon pp_array_mem)
+ array_mems
+ (* locals initialization *)
+ (pp_print_list ~pp_epilogue:pp_print_cut pp_init_mpfr_local)
+ (mpfr_vars mpfr_locals)
+ (* check assertions *)
+ (pp_print_list pp_check)
+ checks
+ (* instrs *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
+ pp_instr)
+ instrs
+ (* locals clear *)
+ (pp_print_list ~pp_epilogue:pp_print_cut pp_clear_mpfr_local)
+ (mpfr_vars mpfr_locals) (* extra *)
+ pp_extra ()
+
+ let node_of_machine m =
+ {
+ top_decl_desc = Node m.mname;
+ top_decl_loc = Location.dummy_loc;
+ top_decl_owner = "";
+ top_decl_itf = false;
+ }
+
+ let print_stateless_code machines dependencies fmt m =
+ let self = "__ERROR__" in
+ if not (!Options.ansi && is_generic_node (node_of_machine m)) then
+ (* C99 code *)
+ pp_print_function
+ ~pp_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self self m)
+ ~pp_prototype:Protos.print_stateless_prototype
+ ~prototype:(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
+ ~pp_local:(pp_c_decl_local_var m) ~base_locals:m.mstep.step_locals
+ ~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
+ ~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
+ ~mpfr_locals:m.mstep.step_locals ~pp_check:(pp_c_check m self)
+ ~checks:m.mstep.step_checks
+ ~pp_instr:(pp_machine_instr dependencies m self self)
+ ~instrs:m.mstep.step_instrs fmt
+ else
+ (* C90 code *)
+ let gen_locals, base_locals =
+ List.partition
+ (fun v -> Types.is_generic_type v.var_type)
+ m.mstep.step_locals
+ in
+ let gen_calls =
+ List.map
+ (fun e ->
+ let id, _, _ = call_of_expr e in
+ mk_call_var_decl e.expr_loc id)
+ m.mname.node_gencalls
+ in
+ pp_print_function ~pp_prototype:Protos.print_stateless_prototype
+ ~prototype:
+ ( m.mname.node_id,
+ m.mstep.step_inputs @ gen_locals @ gen_calls,
+ m.mstep.step_outputs )
+ ~pp_local:(pp_c_decl_local_var m) ~base_locals
+ ~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
+ ~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
+ ~mpfr_locals:m.mstep.step_locals ~pp_check:(pp_c_check m self)
+ ~checks:m.mstep.step_checks
+ ~pp_instr:(pp_machine_instr dependencies m self self)
+ ~instrs:m.mstep.step_instrs fmt
+
+ let print_clear_reset_code dependencies self mem fmt m =
pp_print_function
- ~pp_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self self m)
- ~pp_prototype:Protos.print_stateless_prototype
- ~prototype:(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
- ~pp_local:(pp_c_decl_local_var m)
- ~base_locals:m.mstep.step_locals
- ~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
- ~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
- ~mpfr_locals:m.mstep.step_locals
- ~pp_check:(pp_c_check m self)
- ~checks:m.mstep.step_checks
- ~pp_instr:(pp_machine_instr dependencies m self self)
- ~instrs:m.mstep.step_instrs
+ ~pp_spec:(fun fmt () -> Mod.pp_clear_reset_spec fmt self mem m)
+ ~pp_prototype:(Protos.print_clear_reset_prototype self mem)
+ ~prototype:(m.mname.node_id, m.mstatic)
+ ~pp_local:(pp_c_decl_local_var m) ~base_locals:(const_locals m)
+ ~pp_instr:(pp_machine_instr dependencies m self mem)
+ ~instrs:
+ [
+ mk_branch
+ (mk_val ResetFlag Type_predef.type_bool)
+ [ "true", mkinstr (MResetAssign false) :: m.minit ];
+ ]
fmt
- else
- (* C90 code *)
- let gen_locals, base_locals = List.partition (fun v ->
- Types.is_generic_type v.var_type) m.mstep.step_locals in
- let gen_calls = List.map (fun e ->
- let (id, _, _) = call_of_expr e
- in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in
+
+ let print_set_reset_code dependencies self mem fmt m =
pp_print_function
- ~pp_prototype:Protos.print_stateless_prototype
- ~prototype:(m.mname.node_id,
- m.mstep.step_inputs @ gen_locals @ gen_calls,
- m.mstep.step_outputs)
- ~pp_local:(pp_c_decl_local_var m)
- ~base_locals
- ~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
- ~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
- ~mpfr_locals:m.mstep.step_locals
- ~pp_check:(pp_c_check m self)
- ~checks:m.mstep.step_checks
- ~pp_instr:(pp_machine_instr dependencies m self self)
- ~instrs:m.mstep.step_instrs
+ ~pp_spec:(fun fmt () -> Mod.pp_set_reset_spec fmt self mem m)
+ ~pp_prototype:(Protos.print_set_reset_prototype self mem)
+ ~prototype:(m.mname.node_id, m.mstatic)
+ ~pp_instr:(pp_machine_instr dependencies m self mem)
+ ~instrs:[ mkinstr (MResetAssign true) ]
fmt
- let print_clear_reset_code dependencies self mem fmt m =
- pp_print_function
- ~pp_spec:(fun fmt () -> Mod.pp_clear_reset_spec fmt self mem m)
- ~pp_prototype:(Protos.print_clear_reset_prototype self mem)
- ~prototype:(m.mname.node_id, m.mstatic)
- ~pp_local:(pp_c_decl_local_var m)
- ~base_locals:(const_locals m)
- ~pp_instr:(pp_machine_instr dependencies m self mem)
- ~instrs:[mk_branch
- (mk_val ResetFlag Type_predef.type_bool)
- ["true", mkinstr (MResetAssign false) :: m.minit]]
- fmt
-
- let print_set_reset_code dependencies self mem fmt m =
- pp_print_function
- ~pp_spec:(fun fmt () -> Mod.pp_set_reset_spec fmt self mem m)
- ~pp_prototype:(Protos.print_set_reset_prototype self mem)
- ~prototype:(m.mname.node_id, m.mstatic)
- ~pp_instr:(pp_machine_instr dependencies m self mem)
- ~instrs:[mkinstr (MResetAssign true)]
- fmt
-
- let print_init_code self fmt m =
- let minit = List.map (fun i ->
- match get_instr_desc i with
- | MSetReset i -> i
- | _ -> assert false)
- m.minit in
- pp_print_function
- ~pp_prototype:(Protos.print_init_prototype self)
- ~prototype:(m.mname.node_id, m.mstatic)
- ~pp_array_mem:(pp_c_decl_array_mem self)
- ~array_mems:(array_mems m)
- ~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
- ~mpfr_locals:m.mmemory
- ~pp_extra:(fun fmt () ->
- pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_epilogue:pp_print_cut
- (pp_machine_init m self self)
- fmt minit)
- fmt
-
- let print_clear_code self fmt m =
- let minit = List.map (fun i ->
- match get_instr_desc i with
- | MSetReset i -> i
- | _ -> assert false) m.minit in
- pp_print_function
- ~pp_prototype:(Protos.print_clear_prototype self)
- ~prototype:(m.mname.node_id, m.mstatic)
- ~pp_array_mem:(pp_c_decl_array_mem self)
- ~array_mems:(array_mems m)
- ~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
- ~mpfr_locals:m.mmemory
- ~pp_extra:(fun fmt () ->
- pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_epilogue:pp_print_cut
- (pp_machine_clear m self self)
- fmt minit)
- fmt
-
- let print_step_code machines dependencies self mem fmt m =
- if not (!Options.ansi && is_generic_node (node_of_machine m))
- then
- (* C99 code *)
+ let print_init_code self fmt m =
+ let minit =
+ List.map
+ (fun i ->
+ match get_instr_desc i with MSetReset i -> i | _ -> assert false)
+ m.minit
+ in
pp_print_function
- ~pp_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self mem m)
- ~pp_prototype:(Protos.print_step_prototype self mem)
- ~prototype:(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
- ~pp_local:(pp_c_decl_local_var m)
- ~base_locals:m.mstep.step_locals
- ~pp_array_mem:(pp_c_decl_array_mem self)
- ~array_mems:(array_mems m)
+ ~pp_prototype:(Protos.print_init_prototype self)
+ ~prototype:(m.mname.node_id, m.mstatic)
+ ~pp_array_mem:(pp_c_decl_array_mem self) ~array_mems:(array_mems m)
~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
- ~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
- ~mpfr_locals:m.mstep.step_locals
- ~pp_check:(pp_c_check m self)
- ~checks:m.mstep.step_checks
- ~pp_instr:(pp_machine_instr dependencies m self mem)
- ~instrs:m.mstep.step_instrs
+ ~mpfr_locals:m.mmemory
+ ~pp_extra:(fun fmt () ->
+ pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
+ (pp_machine_init m self self)
+ fmt minit)
fmt
- else
- (* C90 code *)
- let gen_locals, base_locals = List.partition (fun v ->
- Types.is_generic_type v.var_type) m.mstep.step_locals in
- let gen_calls = List.map (fun e ->
- let id, _, _ = call_of_expr e in
- mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in
+
+ let print_clear_code self fmt m =
+ let minit =
+ List.map
+ (fun i ->
+ match get_instr_desc i with MSetReset i -> i | _ -> assert false)
+ m.minit
+ in
pp_print_function
- ~pp_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self mem m)
- ~pp_prototype:(Protos.print_step_prototype self mem)
- ~prototype:(m.mname.node_id,
- m.mstep.step_inputs @ gen_locals @ gen_calls,
- m.mstep.step_outputs)
- ~pp_local:(pp_c_decl_local_var m)
- ~base_locals
- ~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
+ ~pp_prototype:(Protos.print_clear_prototype self)
+ ~prototype:(m.mname.node_id, m.mstatic)
+ ~pp_array_mem:(pp_c_decl_array_mem self) ~array_mems:(array_mems m)
~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
- ~mpfr_locals:m.mstep.step_locals
- ~pp_check:(pp_c_check m self)
- ~checks:m.mstep.step_checks
- ~pp_instr:(pp_machine_instr dependencies m self mem)
- ~instrs:m.mstep.step_instrs
+ ~mpfr_locals:m.mmemory
+ ~pp_extra:(fun fmt () ->
+ pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
+ (pp_machine_clear m self self)
+ fmt minit)
fmt
- (********************************************************************************************)
- (* MAIN C file Printing functions *)
- (********************************************************************************************)
-
- let pp_const_initialize m pp_var fmt const =
- let var = Machine_code_common.mk_val
- (Var (Corelang.var_decl_of_const const)) const.const_type in
- let rec aux indices value fmt typ =
- if Types.is_array_type typ
- then
- let dim = Types.array_type_dimension typ in
- let szl = Utils.enumerate (Dimension.size_const_dimension dim) in
- let typ' = Types.array_element_type typ in
- let value = match value with
- | Const_array ca -> List.nth ca
- | _ -> assert false in
- pp_print_list
- (fun fmt i -> aux (string_of_int i :: indices) (value i) fmt typ') fmt szl
+ let print_step_code machines dependencies self mem fmt m =
+ if not (!Options.ansi && is_generic_node (node_of_machine m)) then
+ (* C99 code *)
+ pp_print_function
+ ~pp_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self mem m)
+ ~pp_prototype:(Protos.print_step_prototype self mem)
+ ~prototype:(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
+ ~pp_local:(pp_c_decl_local_var m) ~base_locals:m.mstep.step_locals
+ ~pp_array_mem:(pp_c_decl_array_mem self) ~array_mems:(array_mems m)
+ ~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
+ ~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
+ ~mpfr_locals:m.mstep.step_locals ~pp_check:(pp_c_check m self)
+ ~checks:m.mstep.step_checks
+ ~pp_instr:(pp_machine_instr dependencies m self mem)
+ ~instrs:m.mstep.step_instrs fmt
else
- let indices = List.rev indices in
- let pp_var_suffix fmt var =
- fprintf fmt "%a%a" (pp_c_val m "" pp_var) var pp_array_suffix indices in
- fprintf fmt "%a@,%a"
- (Mpfr.pp_inject_init pp_var_suffix) var
- (Mpfr.pp_inject_real pp_var_suffix pp_c_const) (var, value)
- in
- reset_loop_counter ();
- aux [] const.const_value fmt const.const_type
-
- let pp_const_clear pp_var fmt const =
- let m = Machine_code_common.empty_machine in
- let var = Corelang.var_decl_of_const const in
- let rec aux indices fmt typ =
- if Types.is_array_type typ
- then
- let dim = Types.array_type_dimension typ in
- let idx = mk_loop_var m () in
- fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
- idx idx idx pp_c_dimension dim idx
- (aux (idx::indices)) (Types.array_element_type typ)
- else
- let indices = List.rev indices in
- let pp_var_suffix fmt var =
- fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix indices in
- Mpfr.pp_inject_clear pp_var_suffix fmt var
- in
- reset_loop_counter ();
- aux [] fmt var.var_type
-
- let print_import_init fmt dep =
- let baseNAME = file_to_module_name dep.name in
- fprintf fmt "%a();" pp_global_init_name baseNAME
-
- let print_import_clear fmt dep =
- let baseNAME = file_to_module_name dep.name in
- fprintf fmt "%a();" pp_global_clear_name baseNAME
-
- let print_global_init_code fmt (basename, prog, dependencies) =
- let baseNAME = file_to_module_name basename in
- let constants = List.map const_of_top (get_consts prog) in
- fprintf fmt
- "@[<v 2>%a {@,\
- static %s init = 0;@,\
- @[<v 2>if (!init) { @,\
- init = 1;%a%a@]@,\
- }@,\
- return;@]@,\
- }"
- print_global_init_prototype baseNAME
- (pp_c_basic_type_desc Type_predef.type_bool)
- (* constants *)
- (pp_print_list
- ~pp_prologue:pp_print_cut
- (pp_const_initialize empty_machine (pp_c_var_read empty_machine)))
- (mpfr_consts constants)
- (* dependencies initialization *)
- (pp_print_list
- ~pp_prologue:pp_print_cut
- print_import_init) (List.filter (fun dep -> dep.local) dependencies)
-
- let print_global_clear_code fmt (basename, prog, dependencies) =
- let baseNAME = file_to_module_name basename in
- let constants = List.map const_of_top (get_consts prog) in
- fprintf fmt
- "@[<v 2>%a {@,\
- static %s clear = 0;@,\
- @[<v 2>if (!clear) { @,\
- clear = 1;%a%a@]@,\
- }@,\
- return;@]@,\
- }"
- print_global_clear_prototype baseNAME
- (pp_c_basic_type_desc Type_predef.type_bool)
- (* constants *)
- (pp_print_list
- ~pp_prologue:pp_print_cut
- (pp_const_clear (pp_c_var_read empty_machine))) (mpfr_consts constants)
- (* dependencies initialization *)
- (pp_print_list
- ~pp_prologue:pp_print_cut
- print_import_clear) (List.filter (fun dep -> dep.local) dependencies)
-
- let print_alloc_function fmt m =
- if (not !Options.static_mem) then
- (* Alloc functions, only if non static mode *)
+ (* C90 code *)
+ let gen_locals, base_locals =
+ List.partition
+ (fun v -> Types.is_generic_type v.var_type)
+ m.mstep.step_locals
+ in
+ let gen_calls =
+ List.map
+ (fun e ->
+ let id, _, _ = call_of_expr e in
+ mk_call_var_decl e.expr_loc id)
+ m.mname.node_gencalls
+ in
+ pp_print_function
+ ~pp_spec:(fun fmt () -> Mod.pp_step_spec fmt machines self mem m)
+ ~pp_prototype:(Protos.print_step_prototype self mem)
+ ~prototype:
+ ( m.mname.node_id,
+ m.mstep.step_inputs @ gen_locals @ gen_calls,
+ m.mstep.step_outputs )
+ ~pp_local:(pp_c_decl_local_var m) ~base_locals
+ ~pp_init_mpfr_local:(pp_initialize m self (pp_c_var_read m))
+ ~pp_clear_mpfr_local:(pp_clear m self (pp_c_var_read m))
+ ~mpfr_locals:m.mstep.step_locals ~pp_check:(pp_c_check m self)
+ ~checks:m.mstep.step_checks
+ ~pp_instr:(pp_machine_instr dependencies m self mem)
+ ~instrs:m.mstep.step_instrs fmt
+
+ (********************************************************************************************)
+ (* MAIN C file Printing functions *)
+ (********************************************************************************************)
+
+ let pp_const_initialize m pp_var fmt const =
+ let var =
+ Machine_code_common.mk_val
+ (Var (Corelang.var_decl_of_const const))
+ const.const_type
+ in
+ let rec aux indices value fmt typ =
+ if Types.is_array_type typ then
+ let dim = Types.array_type_dimension typ in
+ let szl = Utils.enumerate (Dimension.size_const_dimension dim) in
+ let typ' = Types.array_element_type typ in
+ let value =
+ match value with Const_array ca -> List.nth ca | _ -> assert false
+ in
+ pp_print_list
+ (fun fmt i -> aux (string_of_int i :: indices) (value i) fmt typ')
+ fmt szl
+ else
+ let indices = List.rev indices in
+ let pp_var_suffix fmt var =
+ fprintf fmt "%a%a" (pp_c_val m "" pp_var) var pp_array_suffix
+ indices
+ in
+ fprintf fmt "%a@,%a"
+ (Mpfr.pp_inject_init pp_var_suffix)
+ var
+ (Mpfr.pp_inject_real pp_var_suffix pp_c_const)
+ (var, value)
+ in
+ reset_loop_counter ();
+ aux [] const.const_value fmt const.const_type
+
+ let pp_const_clear pp_var fmt const =
+ let m = Machine_code_common.empty_machine in
+ let var = Corelang.var_decl_of_const const in
+ let rec aux indices fmt typ =
+ if Types.is_array_type typ then
+ let dim = Types.array_type_dimension typ in
+ let idx = mk_loop_var m () in
+ fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}" idx
+ idx idx pp_c_dimension dim idx
+ (aux (idx :: indices))
+ (Types.array_element_type typ)
+ else
+ let indices = List.rev indices in
+ let pp_var_suffix fmt var =
+ fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix
+ indices
+ in
+ Mpfr.pp_inject_clear pp_var_suffix fmt var
+ in
+ reset_loop_counter ();
+ aux [] fmt var.var_type
+
+ let print_import_init fmt dep =
+ let baseNAME = file_to_module_name dep.name in
+ fprintf fmt "%a();" pp_global_init_name baseNAME
+
+ let print_import_clear fmt dep =
+ let baseNAME = file_to_module_name dep.name in
+ fprintf fmt "%a();" pp_global_clear_name baseNAME
+
+ let print_global_init_code fmt (basename, prog, dependencies) =
+ let baseNAME = file_to_module_name basename in
+ let constants = List.map const_of_top (get_consts prog) in
fprintf fmt
"@[<v 2>%a {@,\
- %a%a@]@,\
+ static %s init = 0;@,\
+ @[<v 2>if (!init) { @,\
+ init = 1;%a%a@]@,\
}@,\
- @[<v 2>%a {@,\
- %a%a@]@,\
- @,"
- print_alloc_prototype (m.mname.node_id, m.mstatic)
- print_alloc_const m
- print_alloc_code m
- print_dealloc_prototype m.mname.node_id
- print_alloc_const m
- print_dealloc_code m
-
- let print_mpfr_code self fmt m =
- if !Options.mpfr then
- fprintf fmt "@,@[<v>%a@,%a@]"
- (* Init function *)
- (print_init_code self) m
- (* Clear function *)
- (print_clear_code self) m
-
- (* TODO: ACSL
- - a contract machine shall not be directly printed in the C source
- - but a regular machine associated to a contract machine shall integrate
- the associated statements, updating its memories, at the end of the
- function body.
- - last one may print intermediate comment/acsl if/when they are present in
- the sequence of instruction
- *)
- let print_machine machines dependencies fmt m =
- if fst (get_stateless_status m) then
- (* Step function *)
- print_stateless_code machines dependencies fmt m
- else
- let self = mk_self m in
- let mem = mk_mem m in
- fprintf fmt "@[<v>%a%a@,@,%a@,@,%a%a@]"
- print_alloc_function m
- (* Reset functions *)
- (print_clear_reset_code dependencies self mem) m
- (print_set_reset_code dependencies self mem) m
+ return;@]@,\
+ }"
+ print_global_init_prototype baseNAME
+ (pp_c_basic_type_desc Type_predef.type_bool)
+ (* constants *)
+ (pp_print_list ~pp_prologue:pp_print_cut
+ (pp_const_initialize empty_machine (pp_c_var_read empty_machine)))
+ (mpfr_consts constants)
+ (* dependencies initialization *)
+ (pp_print_list ~pp_prologue:pp_print_cut print_import_init)
+ (List.filter (fun dep -> dep.local) dependencies)
+
+ let print_global_clear_code fmt (basename, prog, dependencies) =
+ let baseNAME = file_to_module_name basename in
+ let constants = List.map const_of_top (get_consts prog) in
+ fprintf fmt
+ "@[<v 2>%a {@,\
+ static %s clear = 0;@,\
+ @[<v 2>if (!clear) { @,\
+ clear = 1;%a%a@]@,\
+ }@,\
+ return;@]@,\
+ }"
+ print_global_clear_prototype baseNAME
+ (pp_c_basic_type_desc Type_predef.type_bool)
+ (* constants *)
+ (pp_print_list ~pp_prologue:pp_print_cut
+ (pp_const_clear (pp_c_var_read empty_machine)))
+ (mpfr_consts constants)
+ (* dependencies initialization *)
+ (pp_print_list ~pp_prologue:pp_print_cut print_import_clear)
+ (List.filter (fun dep -> dep.local) dependencies)
+
+ let print_alloc_function fmt m =
+ if not !Options.static_mem then
+ (* Alloc functions, only if non static mode *)
+ fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@,@[<v 2>%a {@,%a%a@]@,@,"
+ print_alloc_prototype
+ (m.mname.node_id, m.mstatic)
+ print_alloc_const m print_alloc_code m print_dealloc_prototype
+ m.mname.node_id print_alloc_const m print_dealloc_code m
+
+ let print_mpfr_code self fmt m =
+ if !Options.mpfr then
+ fprintf fmt "@,@[<v>%a@,%a@]"
+ (* Init function *)
+ (print_init_code self)
+ m
+ (* Clear function *)
+ (print_clear_code self)
+ m
+
+ (* TODO: ACSL - a contract machine shall not be directly printed in the C
+ source - but a regular machine associated to a contract machine shall
+ integrate the associated statements, updating its memories, at the end of
+ the function body. - last one may print intermediate comment/acsl if/when
+ they are present in the sequence of instruction *)
+ let print_machine machines dependencies fmt m =
+ if fst (get_stateless_status m) then
(* Step function *)
- (print_step_code machines dependencies self mem) m
- (print_mpfr_code self) m
-
- let print_import_standard source_fmt () =
- fprintf source_fmt
- "@[<v>#include <assert.h>@,%a%a%a@]"
- (if Machine_types.has_machine_type ()
- then pp_print_endcut "#include <stdint.h>"
- else pp_print_nothing) ()
- (if not !Options.static_mem
- then pp_print_endcut "#include <stdlib.h>"
- else pp_print_nothing) ()
- (if !Options.mpfr
- then pp_print_endcut "#include <mpfr.h>"
- else pp_print_nothing) ()
-
- let print_extern_alloc_prototype fmt ind =
- let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs in
- fprintf fmt "extern %a;@,extern %a;"
- print_alloc_prototype (ind.nodei_id, static)
- print_dealloc_prototype ind.nodei_id
-
- let print_lib_c source_fmt basename prog machines dependencies =
- fprintf source_fmt
- "@[<v>\
- %a\
- %a@,\
- @,\
- %a@,\
- %a\
- %a\
- %a\
- %a\
- %a\
- %a\
- %a\
- @]@."
- print_import_standard ()
- print_import_prototype
- {
- local = true;
- name = basename;
- content = [];
- is_stateful=true (* assuming it is stateful *);
- }
-
- (* Print the svn version number and the supported C standard (C90 or C99) *)
- pp_print_version ()
-
- (* Print dependencies *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut "/* Import dependencies */")
- print_import_prototype
- ~pp_epilogue:pp_print_cutcut) dependencies
-
- (* Print consts *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut "/* Global constants (definitions) */")
- print_const_def
- ~pp_epilogue:pp_print_cutcut) (get_consts prog)
-
- (* MPFR *)
- (if !Options.mpfr then
- fun fmt () ->
- fprintf fmt
- "@[<v>/* Global constants initialization */@,\
- %a@,\
- @,\
- /* Global constants clearing */@,\
- %a@]@,@,"
- print_global_init_code (basename, prog, dependencies)
- print_global_clear_code (basename, prog, dependencies)
- else pp_print_nothing) ()
-
- (if not !Options.static_mem then
- fun fmt () ->
- fprintf fmt
- "@[<v>%a%a@]@,@,"
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_epilogue:pp_print_cut
- ~pp_prologue:(pp_print_endcut
- "/* External allocation function prototypes */")
- (fun fmt dep ->
- pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_epilogue:pp_print_cut
- print_extern_alloc_prototype
- fmt
- (List.filter_map (fun decl -> match decl.top_decl_desc with
- | ImportedNode ind when not ind.nodei_stateless ->
- Some ind
- | _ -> None) dep.content))) dependencies
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut
- "/* Node allocation function prototypes */")
- ~pp_sep:pp_print_cutcut
- (fun fmt m ->
- fprintf fmt "%a;@,%a;"
- print_alloc_prototype (m.mname.node_id, m.mstatic)
- print_dealloc_prototype m.mname.node_id)) machines
- else pp_print_nothing) ()
-
- (* Print the struct definitions of all machines. *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:(pp_print_endcut "/* Struct definitions */")
- ~pp_sep:pp_print_cutcut
- print_machine_struct
- ~pp_epilogue:pp_print_cutcut) machines
-
- (* Print the spec predicates *)
- Mod.pp_predicates machines
-
- (* Print nodes one by one (in the previous order) *)
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_sep:pp_print_cutcut
- (print_machine machines dependencies)) machines
-
-end
+ print_stateless_code machines dependencies fmt m
+ else
+ let self = mk_self m in
+ let mem = mk_mem m in
+ fprintf fmt "@[<v>%a%a@,@,%a@,@,%a%a@]" print_alloc_function m
+ (* Reset functions *)
+ (print_clear_reset_code dependencies self mem)
+ m
+ (print_set_reset_code dependencies self mem)
+ m
+ (* Step function *)
+ (print_step_code machines dependencies self mem)
+ m (print_mpfr_code self) m
+
+ let print_import_standard source_fmt () =
+ fprintf source_fmt "@[<v>#include <assert.h>@,%a%a%a@]"
+ (if Machine_types.has_machine_type () then
+ pp_print_endcut "#include <stdint.h>"
+ else pp_print_nothing)
+ ()
+ (if not !Options.static_mem then pp_print_endcut "#include <stdlib.h>"
+ else pp_print_nothing)
+ ()
+ (if !Options.mpfr then pp_print_endcut "#include <mpfr.h>"
+ else pp_print_nothing)
+ ()
+
+ let print_extern_alloc_prototype fmt ind =
+ let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs in
+ fprintf fmt "extern %a;@,extern %a;" print_alloc_prototype
+ (ind.nodei_id, static) print_dealloc_prototype ind.nodei_id
+
+ let print_lib_c source_fmt basename prog machines dependencies =
+ fprintf source_fmt "@[<v>%a%a@,@,%a@,%a%a%a%a%a%a%a@]@."
+ print_import_standard () print_import_prototype
+ {
+ local = true;
+ name = basename;
+ content = [];
+ is_stateful = true (* assuming it is stateful *);
+ }
+ (* Print the svn version number and the supported C standard (C90 or
+ C99) *)
+ pp_print_version ()
+ (* Print dependencies *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut "/* Import dependencies */")
+ print_import_prototype ~pp_epilogue:pp_print_cutcut)
+ dependencies
+ (* Print consts *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut "/* Global constants (definitions) */")
+ print_const_def ~pp_epilogue:pp_print_cutcut)
+ (get_consts prog)
+ (* MPFR *)
+ (if !Options.mpfr then fun fmt () ->
+ fprintf fmt
+ "@[<v>/* Global constants initialization */@,\
+ %a@,\
+ @,\
+ /* Global constants clearing */@,\
+ %a@]@,\
+ @,"
+ print_global_init_code
+ (basename, prog, dependencies)
+ print_global_clear_code
+ (basename, prog, dependencies)
+ else pp_print_nothing)
+ ()
+ (if not !Options.static_mem then fun fmt () ->
+ fprintf fmt "@[<v>%a%a@]@,@,"
+ (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_epilogue:pp_print_cut
+ ~pp_prologue:
+ (pp_print_endcut "/* External allocation function prototypes */")
+ (fun fmt dep ->
+ pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_epilogue:pp_print_cut print_extern_alloc_prototype fmt
+ (List.filter_map
+ (fun decl ->
+ match decl.top_decl_desc with
+ | ImportedNode ind when not ind.nodei_stateless ->
+ Some ind
+ | _ ->
+ None)
+ dep.content)))
+ dependencies
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:
+ (pp_print_endcut "/* Node allocation function prototypes */")
+ ~pp_sep:pp_print_cutcut (fun fmt m ->
+ fprintf fmt "%a;@,%a;" print_alloc_prototype
+ (m.mname.node_id, m.mstatic)
+ print_dealloc_prototype m.mname.node_id))
+ machines
+ else pp_print_nothing)
+ ()
+ (* Print the struct definitions of all machines. *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0
+ ~pp_prologue:(pp_print_endcut "/* Struct definitions */")
+ ~pp_sep:pp_print_cutcut print_machine_struct
+ ~pp_epilogue:pp_print_cutcut)
+ machines (* Print the spec predicates *) Mod.pp_predicates machines
+ (* Print nodes one by one (in the previous order) *)
+ (pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_sep:pp_print_cutcut
+ (print_machine machines dependencies))
+ machines
+ end
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
diff --git a/src/backends/EMF/EMF_backend.ml b/src/backends/EMF/EMF_backend.ml
index a211c33f2d396d68b40e7ecde96fac5dd6df448b..27440e16fc3819c2c9194fdf1e46a2ac870d578e 100644
--- a/src/backends/EMF/EMF_backend.ml
+++ b/src/backends/EMF/EMF_backend.ml
@@ -101,14 +101,14 @@
open Lustre_types
open Machine_code_types
open Machine_code_common
-open Format
+open Format
open EMF_common
+
exception Unhandled of string
module ISet = Utils.ISet
-let fprintf_list = Utils.fprintf_list
-
+let fprintf_list = Utils.fprintf_list
(**********************************************)
(* Utility functions: arrow and lustre expr *)
@@ -118,71 +118,74 @@ let fprintf_list = Utils.fprintf_list
-> false *)
let is_arrow_fun m i =
match Corelang.get_instr_desc i with
- | MStep ([_], i, vl) ->
- (
- try
- let name = (get_node_def i m).node_id in
- match name, vl with
- | "_arrow", [v1; v2] -> (
- match v1.value_desc, v2.value_desc with
- | Cst c1, Cst c2 ->
- if c1 = Corelang.const_of_bool true && c2 = Corelang.const_of_bool false then
- true
- else
- assert false (* only handle true -> false *)
- | _ -> assert false
- )
-
- | _ -> false
- with
- | Not_found -> false (* Not declared (should have been detected now, or
- imported node) *)
- )
+ | MStep ([ _ ], i, vl) -> (
+ try
+ let name = (get_node_def i m).node_id in
+ match name, vl with
+ | "_arrow", [ v1; v2 ] -> (
+ match v1.value_desc, v2.value_desc with
+ | Cst c1, Cst c2 ->
+ if
+ c1 = Corelang.const_of_bool true
+ && c2 = Corelang.const_of_bool false
+ then true
+ else assert false
+ (* only handle true -> false *)
+ | _ -> assert false)
+ | _ -> false
+ with Not_found ->
+ false
+ (* Not declared (should have been detected now, or
+ imported node) *))
| _ -> false
-
-
-
+
let is_resetable_fun lustre_eq =
(* We extract the clock if it exist from the original lustre equation *)
match lustre_eq with
| Some eq -> (
- match eq.eq_rhs.expr_desc with
- | Expr_appl(_,_,reset) -> (
- match reset with None -> false | Some _ -> true
- )
- | Expr_arrow _ -> true
- | _ -> Format.eprintf "reseting expr %a@.@?" Printers.pp_expr eq.eq_rhs; assert false
- )
- | None -> assert false (* should have been assigned to an original lustre equation *)
+ match eq.eq_rhs.expr_desc with
+ | Expr_appl (_, _, reset) -> (
+ match reset with None -> false | Some _ -> true)
+ | Expr_arrow _ -> true
+ | _ ->
+ Format.eprintf "reseting expr %a@.@?" Printers.pp_expr eq.eq_rhs;
+ assert false)
+ | None -> assert false
+(* should have been assigned to an original lustre equation *)
(**********************************************)
(* Printing machine code as EMF *)
(**********************************************)
-
-
let branch_cpt = ref 0
+
let get_instr_id fmt i =
match Corelang.get_instr_desc i with
- | MLocalAssign(lhs,_) | MStateAssign (lhs, _) -> pp_var_name fmt lhs
+ | MLocalAssign (lhs, _) | MStateAssign (lhs, _) -> pp_var_name fmt lhs
| MSetReset i | MNoReset i -> fprintf fmt "%s" (reset_name i)
(* TODO: handle clear_reset *)
| MClearReset -> ()
- | MBranch _ -> incr branch_cpt; fprintf fmt "branch_%i" !branch_cpt
+ | MBranch _ ->
+ incr branch_cpt;
+ fprintf fmt "branch_%i" !branch_cpt
| MStep (outs, id, _) ->
- print_protect fmt
- (fun fmt -> fprintf fmt "%a_%s" (fprintf_list ~sep:"_" pp_var_name) outs id)
- | _ -> () (* No name *)
+ print_protect fmt (fun fmt ->
+ fprintf fmt "%a_%s" (fprintf_list ~sep:"_" pp_var_name) outs id)
+ | _ -> ()
+(* No name *)
let rec branch_block_vars m il =
List.fold_left
(fun (accu_all_def, accu_def, accu_read) i ->
- let all_defined_vars, common_def_vars, read_vars = branch_instr_vars m i in
- ISet.union accu_all_def all_defined_vars,
- ISet.union accu_def common_def_vars,
- VSet.union accu_read read_vars)
- (ISet.empty, ISet.empty, VSet.empty) il
-
+ let all_defined_vars, common_def_vars, read_vars =
+ branch_instr_vars m i
+ in
+ ( ISet.union accu_all_def all_defined_vars,
+ ISet.union accu_def common_def_vars,
+ VSet.union accu_read read_vars ))
+ (ISet.empty, ISet.empty, VSet.empty)
+ il
+
and branch_instr_vars m i =
(* Returns all_outputs, outputs, inputs of the instruction. It is
only called on MBranch instructions but evaluate recursively
@@ -193,131 +196,123 @@ and branch_instr_vars m i =
The set "All outputs" is used to filter out input variables
belong to that set. *)
-
match Corelang.get_instr_desc i with
- | MLocalAssign (var,expr)
- | MStateAssign (var,expr) -> ISet.singleton var.var_id, ISet.singleton var.var_id, get_expr_vars expr
- | MStep (vars, f, args) ->
- let is_stateful = List.mem_assoc f m.minstances in
- let lhs = ISet.of_list (List.map (fun v -> v.var_id) vars) in
- let args_vars =
- List.fold_left (fun accu v -> VSet.union accu (get_expr_vars v)) VSet.empty args in
-
- lhs, lhs,
- (
- if is_stateful && is_resetable_fun i.lustre_eq then
- let reset_var =
- let loc = Location.dummy_loc in
- Corelang.mkvar_decl loc
- (reset_name f,
- Corelang.mktyp loc Tydec_bool, Corelang.mkclock loc Ckdec_any,
- false,
- None,
- None)
- in
- VSet.add reset_var args_vars
- else
- args_vars
- )
- | MBranch (g,(_,hd_il)::tl) -> (* We focus on variables defined in all branches *)
- let read_guard = get_expr_vars g in
- (* Bootstrapping with first item *)
- let all_def_vars_hd, def_vars_hd, read_vars_hd = branch_block_vars m hd_il in
- let all_def_vars, def_vars, read_vars =
- List.fold_left
- (fun (all_def_vars, def_vars, read_vars) (_, il) ->
- (* We accumulate reads but intersect writes *)
- let all_writes_il, writes_il, reads_il = branch_block_vars m il in
- ISet.union all_def_vars all_writes_il,
- ISet.inter def_vars writes_il,
- VSet.union read_vars reads_il
- )
- (all_def_vars_hd, def_vars_hd, read_vars_hd)
- tl
- in
- (* all_def_vars correspond to variables written or defined in one
- of the branch. It may happen that a variable is defined in one
- but not in the other, because of reset for example.
-
- def_vars are variables defined in all branches. *)
-
-
- all_def_vars, def_vars, VSet.union read_guard read_vars
- | MBranch _ -> assert false (* branch instruction should admit at least one case *)
- | MSetReset ni
- | MNoReset ni ->
- let write = ISet.singleton (reset_name ni) in
- write, write, VSet.empty
+ | MLocalAssign (var, expr) | MStateAssign (var, expr) ->
+ ISet.singleton var.var_id, ISet.singleton var.var_id, get_expr_vars expr
+ | MStep (vars, f, args) ->
+ let is_stateful = List.mem_assoc f m.minstances in
+ let lhs = ISet.of_list (List.map (fun v -> v.var_id) vars) in
+ let args_vars =
+ List.fold_left
+ (fun accu v -> VSet.union accu (get_expr_vars v))
+ VSet.empty args
+ in
+
+ ( lhs,
+ lhs,
+ if is_stateful && is_resetable_fun i.lustre_eq then
+ let reset_var =
+ let loc = Location.dummy_loc in
+ Corelang.mkvar_decl loc
+ ( reset_name f,
+ Corelang.mktyp loc Tydec_bool,
+ Corelang.mkclock loc Ckdec_any,
+ false,
+ None,
+ None )
+ in
+ VSet.add reset_var args_vars
+ else args_vars )
+ | MBranch (g, (_, hd_il) :: tl) ->
+ (* We focus on variables defined in all branches *)
+ let read_guard = get_expr_vars g in
+ (* Bootstrapping with first item *)
+ let all_def_vars_hd, def_vars_hd, read_vars_hd =
+ branch_block_vars m hd_il
+ in
+ let all_def_vars, def_vars, read_vars =
+ List.fold_left
+ (fun (all_def_vars, def_vars, read_vars) (_, il) ->
+ (* We accumulate reads but intersect writes *)
+ let all_writes_il, writes_il, reads_il = branch_block_vars m il in
+ ( ISet.union all_def_vars all_writes_il,
+ ISet.inter def_vars writes_il,
+ VSet.union read_vars reads_il ))
+ (all_def_vars_hd, def_vars_hd, read_vars_hd)
+ tl
+ in
+
+ (* all_def_vars correspond to variables written or defined in one
+ of the branch. It may happen that a variable is defined in one
+ but not in the other, because of reset for example.
+
+ def_vars are variables defined in all branches. *)
+ all_def_vars, def_vars, VSet.union read_guard read_vars
+ | MBranch _ ->
+ assert false (* branch instruction should admit at least one case *)
+ | MSetReset ni | MNoReset ni ->
+ let write = ISet.singleton (reset_name ni) in
+ write, write, VSet.empty
(* TODO: handle clear_reset and reset flag *)
| MClearReset | MResetAssign _ -> ISet.empty, ISet.empty, VSet.empty
- | MSpec _ | MComment _ -> assert false (* not available for EMF output *)
-
+ | MSpec _ | MComment _ -> assert false
+(* not available for EMF output *)
+
(* A kind of super join_guards: all MBranch are postponed and sorted by
guards so they can be easier merged *)
let merge_branches instrs =
let instrs, branches =
- List.fold_right (fun i (il, branches) ->
- match Corelang.get_instr_desc i with
- MBranch _ -> il, i::branches
- | _ -> i::il, branches
- ) instrs ([],[])
+ List.fold_right
+ (fun i (il, branches) ->
+ match Corelang.get_instr_desc i with
+ | MBranch _ -> il, i :: branches
+ | _ -> i :: il, branches)
+ instrs ([], [])
in
let sorting_branches b1 b2 =
match Corelang.get_instr_desc b1, Corelang.get_instr_desc b2 with
- | MBranch(g1, _), MBranch(g2, _) ->
- compare g1 g2
+ | MBranch (g1, _), MBranch (g2, _) -> compare g1 g2
| _ -> assert false
in
let sorted_branches = List.sort sorting_branches branches in
- instrs @ (join_guards_list sorted_branches)
-
+ instrs @ join_guards_list sorted_branches
+
let rec pp_emf_instr m fmt i =
let pp_content fmt i =
match Corelang.get_instr_desc i with
- | MLocalAssign(lhs, expr) ->
- begin match expr.value_desc with
+ | MLocalAssign (lhs, expr) -> (
+ match expr.value_desc with
| Fun (fun_id, vl) ->
- (* Thanks to normalization, vl shall only contain constant or
- local/state vars but not calls to other functions *)
- fprintf fmt "\"kind\": \"operator\",@ ";
- fprintf fmt "\"lhs\": \"%a\",@ " pp_var_name lhs;
- fprintf fmt "\"name\": \"%s\",@ \"args\": [@[%a@]]"
- fun_id
- (pp_emf_cst_or_var_list m) vl
- | Array _ | Access _ | Power _
- | Cst _
- | Var _ ->
- fprintf fmt "\"kind\": \"local_assign\",@ \"lhs\": \"%a\",@ \"rhs\": %a"
- pp_var_name lhs
- (pp_emf_cst_or_var m) expr
+ (*
+ Thanks to normalization, vl shall only contain constant or
+ local/state vars but not calls to other functions *)
+ fprintf fmt "\"kind\": \"operator\",@ ";
+ fprintf fmt "\"lhs\": \"%a\",@ " pp_var_name lhs;
+ fprintf fmt "\"name\": \"%s\",@ \"args\": [@[%a@]]" fun_id
+ (pp_emf_cst_or_var_list m) vl
+ | Array _ | Access _ | Power _ | Cst _ | Var _ ->
+ fprintf fmt
+ "\"kind\": \"local_assign\",@ \"lhs\": \"%a\",@ \"rhs\": %a"
+ pp_var_name lhs (pp_emf_cst_or_var m) expr
| ResetFlag ->
- (* TODO: handle reset flag *)
- assert false
- end
-
- | MStateAssign(lhs, expr) (* a Pre construct Shall only be defined by a
- variable or a constant, no function anymore! *)
- -> (
- fprintf fmt "\"kind\": \"pre\",@ \"lhs\": \"%a\",@ \"rhs\": %a"
- pp_var_name lhs
- (pp_emf_cst_or_var m) expr
- )
-
- | MSetReset id
- -> (
- fprintf fmt "\"kind\": \"reset\",@ \"lhs\": \"%s\",@ \"rhs\": \"true\""
- (reset_name id)
- )
- | MNoReset id
- -> (
- fprintf fmt "\"kind\": \"reset\",@ \"lhs\": \"%s\",@ \"rhs\": \"false\""
- (reset_name id)
- )
+ (* TODO: handle reset flag *)
+ assert false)
+ | MStateAssign (lhs, expr)
+ (* a Pre construct Shall only be defined by a
+ variable or a constant, no function anymore! *) ->
+ fprintf fmt "\"kind\": \"pre\",@ \"lhs\": \"%a\",@ \"rhs\": %a"
+ pp_var_name lhs (pp_emf_cst_or_var m) expr
+ | MSetReset id ->
+ fprintf fmt "\"kind\": \"reset\",@ \"lhs\": \"%s\",@ \"rhs\": \"true\""
+ (reset_name id)
+ | MNoReset id ->
+ fprintf fmt "\"kind\": \"reset\",@ \"lhs\": \"%s\",@ \"rhs\": \"false\""
+ (reset_name id)
(* TODO: handle clear_reset and reset flag *)
| MClearReset | MResetAssign _ -> ()
-
- | MBranch (g, hl) -> (
+ | MBranch (g, hl) ->
let all_outputs, outputs, inputs = branch_instr_vars m i in
+
(* Format.eprintf "Mbranch %a@.vars: all_out: %a, out:%a, in:%a@.@." *)
(* Machine_code.pp_instr i *)
(* (fprintf_list ~sep:", " pp_var_string) (ISet.elements all_outputs) *)
@@ -326,105 +321,109 @@ let rec pp_emf_instr m fmt i =
(* (VSet.elements inputs) *)
(* ; *)
- let inputs = VSet.filter (fun v -> not (ISet.mem v.var_id all_outputs)) inputs in
- (* Format.eprintf "Filtering in: %a@.@." *)
- (* pp_emf_vars_decl *)
- (* (VSet.elements inputs) *)
-
- (* ; *)
- fprintf fmt "\"kind\": \"branch\",@ ";
- fprintf fmt "\"guard\": %a,@ " (pp_emf_cst_or_var m) g; (* it has to be a variable or a constant *)
- fprintf fmt "\"outputs\": [%a],@ " (fprintf_list ~sep:", " pp_var_string) (ISet.elements outputs);
- fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl
- (* (let guard_inputs = get_expr_vars g in
- VSet.elements (VSet.diff inputs guard_inputs)) -- previous version to
- remove guard's variable from inputs *)
- (VSet.elements inputs)
- ;
- fprintf fmt "@[<v 2>\"branches\": {@ @[<v 0>%a@]@]@ }"
- (fprintf_list ~sep:",@ "
- (fun fmt (tag, instrs_tag) ->
- let branch_all_lhs, _, branch_inputs = branch_block_vars m instrs_tag in
- let branch_inputs = VSet.filter (fun v -> not (ISet.mem v.var_id branch_all_lhs)) branch_inputs in
- fprintf fmt "@[<v 2>\"%a\": {@ " print_protect (fun fmt -> Format.pp_print_string fmt tag);
- fprintf fmt "\"guard_value\": \"%a\",@ " pp_tag_id tag;
- fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl (VSet.elements branch_inputs);
- fprintf fmt "@[<v 2>\"instrs\": {@ ";
- (pp_emf_instrs m) fmt instrs_tag;
- fprintf fmt "@]@ }";
- fprintf fmt "@]@ }"
- )
- )
- hl
- )
-
- | MStep ([var], f, _) when is_arrow_fun m i -> (* Arrow case *) (
- fprintf fmt "\"kind\": \"arrow\",@ \"name\": \"%s\",@ \"lhs\": \"%a\",@ \"rhs\": \"%s\""
- f
- pp_var_name var
- (reset_name f)
- )
-
- | MStep (outputs, f, inputs) when not (is_imported_node f m) -> (
- let node_f = get_node_def f m in
- let is_stateful = List.mem_assoc f m.minstances in
- fprintf fmt "\"kind\": \"%s\",@ \"name\": \"%a\",@ \"id\": \"%s\",@ "
- (if is_stateful then "statefulcall" else "statelesscall")
- print_protect (fun fmt -> pp_print_string fmt (node_f.node_id))
- f;
- fprintf fmt "\"lhs\": [@[%a@]],@ \"args\": [@[%a@]]"
- (fprintf_list ~sep:",@ " (fun fmt v -> fprintf fmt "\"%a\"" pp_var_name v)) outputs
- (pp_emf_cst_or_var_list m) inputs;
- if is_stateful then
- fprintf fmt ",@ \"reset\": { \"name\": \"%s\", \"resetable\": \"%b\"}"
- (reset_name f)
- (is_resetable_fun i.lustre_eq)
- else fprintf fmt "@ "
- )
-
- | MStep(outputs, f, inputs ) -> (* This is an imported node *)
- EMF_library_calls.pp_call fmt m f outputs inputs
-
- | MSpec _ | MComment _
- -> Format.eprintf "unhandled comment in EMF@.@?"; assert false
- (* not available for EMF output *)
+ let inputs =
+ VSet.filter (fun v -> not (ISet.mem v.var_id all_outputs)) inputs
+ in
+
+ (* Format.eprintf "Filtering in: %a@.@." *)
+ (* pp_emf_vars_decl *)
+ (* (VSet.elements inputs) *)
+
+ (* ; *)
+ fprintf fmt "\"kind\": \"branch\",@ ";
+ fprintf fmt "\"guard\": %a,@ " (pp_emf_cst_or_var m) g;
+ (* it has to be a variable or a constant *)
+ fprintf fmt "\"outputs\": [%a],@ "
+ (fprintf_list ~sep:", " pp_var_string)
+ (ISet.elements outputs);
+ fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl
+ (*
+ (let guard_inputs = get_expr_vars g in
+ VSet.elements (VSet.diff inputs guard_inputs)) -- previous version to
+ remove guard's variable from inputs *)
+ (VSet.elements inputs);
+ fprintf fmt "@[<v 2>\"branches\": {@ @[<v 0>%a@]@]@ }"
+ (fprintf_list ~sep:",@ " (fun fmt (tag, instrs_tag) ->
+ let branch_all_lhs, _, branch_inputs =
+ branch_block_vars m instrs_tag
+ in
+ let branch_inputs =
+ VSet.filter
+ (fun v -> not (ISet.mem v.var_id branch_all_lhs))
+ branch_inputs
+ in
+ fprintf fmt "@[<v 2>\"%a\": {@ " print_protect (fun fmt ->
+ Format.pp_print_string fmt tag);
+ fprintf fmt "\"guard_value\": \"%a\",@ " pp_tag_id tag;
+ fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl
+ (VSet.elements branch_inputs);
+ fprintf fmt "@[<v 2>\"instrs\": {@ ";
+ (pp_emf_instrs m) fmt instrs_tag;
+ fprintf fmt "@]@ }";
+ fprintf fmt "@]@ }"))
+ hl
+ | MStep ([ var ], f, _) when is_arrow_fun m i ->
+ (* Arrow case *)
+ fprintf fmt
+ "\"kind\": \"arrow\",@ \"name\": \"%s\",@ \"lhs\": \"%a\",@ \"rhs\": \
+ \"%s\""
+ f pp_var_name var (reset_name f)
+ | MStep (outputs, f, inputs) when not (is_imported_node f m) ->
+ let node_f = get_node_def f m in
+ let is_stateful = List.mem_assoc f m.minstances in
+ fprintf fmt "\"kind\": \"%s\",@ \"name\": \"%a\",@ \"id\": \"%s\",@ "
+ (if is_stateful then "statefulcall" else "statelesscall")
+ print_protect
+ (fun fmt -> pp_print_string fmt node_f.node_id)
+ f;
+ fprintf fmt "\"lhs\": [@[%a@]],@ \"args\": [@[%a@]]"
+ (fprintf_list ~sep:",@ " (fun fmt v ->
+ fprintf fmt "\"%a\"" pp_var_name v))
+ outputs (pp_emf_cst_or_var_list m) inputs;
+ if is_stateful then
+ fprintf fmt ",@ \"reset\": { \"name\": \"%s\", \"resetable\": \"%b\"}"
+ (reset_name f)
+ (is_resetable_fun i.lustre_eq)
+ else fprintf fmt "@ "
+ | MStep (outputs, f, inputs) ->
+ (* This is an imported node *)
+ EMF_library_calls.pp_call fmt m f outputs inputs
+ | MSpec _ | MComment _ ->
+ Format.eprintf "unhandled comment in EMF@.@?";
+ assert false
+ (* not available for EMF output *)
in
- fprintf fmt "@[ @[<v 2>\"%a\": {@ " get_instr_id i;
- fprintf fmt "%a" pp_content i;
- fprintf fmt "@]@]@ }"
-and pp_emf_instrs m fmt instrs = fprintf_list ~sep:",@ " (pp_emf_instr m) fmt instrs
+ fprintf fmt "@[ @[<v 2>\"%a\": {@ " get_instr_id i;
+ fprintf fmt "%a" pp_content i;
+ fprintf fmt "@]@]@ }"
+
+and pp_emf_instrs m fmt instrs =
+ fprintf_list ~sep:",@ " (pp_emf_instr m) fmt instrs
let pp_emf_annot cpt fmt (key, ee) =
let _ =
- fprintf fmt "\"ann%i\": { @[<hov 0>\"key\": [%a],@ \"eexpr\": %a@] }"
- !cpt
- (fprintf_list ~sep:"," (fun fmt s -> fprintf fmt "\"%s\"" s)) key
- pp_emf_eexpr ee
+ fprintf fmt "\"ann%i\": { @[<hov 0>\"key\": [%a],@ \"eexpr\": %a@] }" !cpt
+ (fprintf_list ~sep:"," (fun fmt s -> fprintf fmt "\"%s\"" s))
+ key pp_emf_eexpr ee
in
incr cpt
let pp_emf_spec_mode fmt m =
fprintf fmt "{@[";
- fprintf fmt "\"mode_id\": \"%s\",@ "
- m.mode_id;
- fprintf fmt "\"ensure\": [%a],@ "
- pp_emf_eexprs m.ensure;
- fprintf fmt "\"require\": [%a]@ "
- pp_emf_eexprs m.require;
+ fprintf fmt "\"mode_id\": \"%s\",@ " m.mode_id;
+ fprintf fmt "\"ensure\": [%a],@ " pp_emf_eexprs m.ensure;
+ fprintf fmt "\"require\": [%a]@ " pp_emf_eexprs m.require;
fprintf fmt "@]}"
-
+
let pp_emf_spec_modes = pp_emf_list pp_emf_spec_mode
let pp_emf_spec_import fmt i =
fprintf fmt "{@[";
- fprintf fmt "\"contract\": \"%s\",@ "
- i.import_nodeid;
- fprintf fmt "\"inputs\": [%a],@ "
- pp_emf_expr i.inputs;
- fprintf fmt "\"outputs\": [%a],@ "
- pp_emf_expr i.outputs;
+ fprintf fmt "\"contract\": \"%s\",@ " i.import_nodeid;
+ fprintf fmt "\"inputs\": [%a],@ " pp_emf_expr i.inputs;
+ fprintf fmt "\"outputs\": [%a],@ " pp_emf_expr i.outputs;
fprintf fmt "@]}"
-
+
let pp_emf_spec_imports = pp_emf_list pp_emf_spec_import
let pp_emf_spec fmt spec =
@@ -435,18 +434,18 @@ let pp_emf_spec fmt spec =
* pp_emf_vars_decl spec.locals;
* fprintf fmt "\"stmts\": [%a],@ "
* pp_emf_stmts spec.stmts; *)
- fprintf fmt "\"assume\": [%a],@ "
- pp_emf_eexprs spec.assume;
- fprintf fmt "\"guarantees\": [%a],@ "
- pp_emf_eexprs spec.guarantees;
- fprintf fmt "\"modes\": [%a]@ "
- pp_emf_spec_modes spec.modes;
+ fprintf fmt "\"assume\": [%a],@ " pp_emf_eexprs spec.assume;
+ fprintf fmt "\"guarantees\": [%a],@ " pp_emf_eexprs spec.guarantees;
+ fprintf fmt "\"modes\": [%a]@ " pp_emf_spec_modes spec.modes;
(* fprintf fmt "\"imports\": [%a]@ "
- * pp_emf_spec_imports spec.imports; *)
+ * pp_emf_spec_imports spec.imports; *)
fprintf fmt "@] }"
-
-let pp_emf_annots cpt fmt annots = fprintf_list ~sep:",@ " (pp_emf_annot cpt) fmt annots.annots
-let pp_emf_annots_list cpt fmt annots_list = fprintf_list ~sep:",@ " (pp_emf_annots cpt) fmt annots_list
+
+let pp_emf_annots cpt fmt annots =
+ fprintf_list ~sep:",@ " (pp_emf_annot cpt) fmt annots.annots
+
+let pp_emf_annots_list cpt fmt annots_list =
+ fprintf_list ~sep:",@ " (pp_emf_annots cpt) fmt annots_list
(* let pp_emf_contract fmt nd =
* let c = Printers.node_as_contract nd in
@@ -455,76 +454,70 @@ let pp_emf_annots_list cpt fmt annots_list = fprintf_list ~sep:",@ " (pp_emf_ann
* fprintf fmt "\"contract\": %a@ "
* pp_emf_spec c;
* fprintf fmt "@]@ }" *)
-
+
let pp_machine fmt m =
- let instrs = (*merge_branches*) m.mstep.step_instrs in
+ let instrs =
+ (*merge_branches*)
+ m.mstep.step_instrs
+ in
try
- fprintf fmt "@[<v 2>\"%a\": {@ "
- print_protect (fun fmt -> pp_print_string fmt m.mname.node_id);
+ fprintf fmt "@[<v 2>\"%a\": {@ " print_protect (fun fmt ->
+ pp_print_string fmt m.mname.node_id);
(match m.mspec.mnode_spec with
- | Some (Contract _) -> fprintf fmt "\"contract\": \"true\",@ "
- | _ -> ());
+ | Some (Contract _) -> fprintf fmt "\"contract\": \"true\",@ "
+ | _ -> ());
fprintf fmt "\"imported\": \"false\",@ ";
- fprintf fmt "\"kind\": %t,@ "
- (fun fmt -> if not ( snd (get_stateless_status m) )
- then fprintf fmt "\"stateful\""
- else fprintf fmt "\"stateless\"");
- fprintf fmt "\"inputs\": [%a],@ "
- pp_emf_vars_decl m.mstep.step_inputs;
- fprintf fmt "\"outputs\": [%a],@ "
- pp_emf_vars_decl m.mstep.step_outputs;
- fprintf fmt "\"locals\": [%a],@ "
- pp_emf_vars_decl m.mstep.step_locals;
- fprintf fmt "\"mems\": [%a],@ "
- pp_emf_vars_decl m.mmemory;
+ fprintf fmt "\"kind\": %t,@ " (fun fmt ->
+ if not (snd (get_stateless_status m)) then fprintf fmt "\"stateful\""
+ else fprintf fmt "\"stateless\"");
+ fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl m.mstep.step_inputs;
+ fprintf fmt "\"outputs\": [%a],@ " pp_emf_vars_decl m.mstep.step_outputs;
+ fprintf fmt "\"locals\": [%a],@ " pp_emf_vars_decl m.mstep.step_locals;
+ fprintf fmt "\"mems\": [%a],@ " pp_emf_vars_decl m.mmemory;
fprintf fmt "\"original_name\": \"%s\",@ " m.mname.node_id;
- fprintf fmt "\"instrs\": {@[<v 0> %a@]@ },@ "
- (pp_emf_instrs m) instrs;
+ fprintf fmt "\"instrs\": {@[<v 0> %a@]@ },@ " (pp_emf_instrs m) instrs;
(match m.mspec.mnode_spec with
- | None -> ()
- | Some (Contract c) -> (
- assert (c.locals = [] && c.consts = [] && c.stmts = [] && c.imports = []);
- fprintf fmt "\"spec\": %a,@ " pp_emf_spec c
- )
- | Some (NodeSpec id) -> fprintf fmt "\"contract\": \"%s\",@ " id
- );
- fprintf fmt "\"annots\": {@[<v 0> %a@]@ }" (pp_emf_annots_list (ref 0)) m.mannot;
+ | None -> ()
+ | Some (Contract c) ->
+ assert (c.locals = [] && c.consts = [] && c.stmts = [] && c.imports = []);
+ fprintf fmt "\"spec\": %a,@ " pp_emf_spec c
+ | Some (NodeSpec id) -> fprintf fmt "\"contract\": \"%s\",@ " id);
+ fprintf fmt "\"annots\": {@[<v 0> %a@]@ }"
+ (pp_emf_annots_list (ref 0))
+ m.mannot;
fprintf fmt "@]@ }"
- with Unhandled msg -> (
+ with Unhandled msg ->
eprintf "[Error] @[<v 0>EMF backend@ Issues while translating node %s@ "
m.mname.node_id;
eprintf "%s@ " msg;
eprintf "node skipped - no output generated@ @]@."
- )
(*let pp_machine fmt m =
match m.mspec with
| None | Some (NodeSpec _) -> pp_machine fmt m
| Some (Contract _) -> pp_emf_contract fmt m
*)
-
+
let pp_emf_imported_node fmt top =
let ind = Corelang.imported_node_of_top top in
try
- fprintf fmt "@[<v 2>\"%a\": {@ "
- print_protect (fun fmt -> pp_print_string fmt ind.nodei_id);
+ fprintf fmt "@[<v 2>\"%a\": {@ " print_protect (fun fmt ->
+ pp_print_string fmt ind.nodei_id);
fprintf fmt "\"imported\": \"true\",@ ";
- fprintf fmt "\"inputs\": [%a],@ "
- pp_emf_vars_decl ind.nodei_inputs;
- fprintf fmt "\"outputs\": [%a],@ "
- pp_emf_vars_decl ind.nodei_outputs;
+ fprintf fmt "\"inputs\": [%a],@ " pp_emf_vars_decl ind.nodei_inputs;
+ fprintf fmt "\"outputs\": [%a],@ " pp_emf_vars_decl ind.nodei_outputs;
fprintf fmt "\"original_name\": \"%s\"" ind.nodei_id;
- (match ind.nodei_spec with None -> fprintf fmt "@ "
- | Some (Contract _) -> assert false (* should have been processed *)
- | Some (NodeSpec id) -> fprintf fmt ",@ \"coco_contract\": %s" id
- );
+ (match ind.nodei_spec with
+ | None -> fprintf fmt "@ "
+ | Some (Contract _) -> assert false (* should have been processed *)
+ | Some (NodeSpec id) -> fprintf fmt ",@ \"coco_contract\": %s" id);
fprintf fmt "@]@ }"
- with Unhandled msg -> (
+ with Unhandled msg ->
eprintf "[Error] @[<v 0>EMF backend@ Issues while translating node %s@ "
ind.nodei_id;
eprintf "%s@ " msg;
eprintf "node skipped - no output generated@ @]@."
- )
+
(****************************************************)
(* Main function: iterates over node and print them *)
(****************************************************)
@@ -533,28 +526,30 @@ let pp_meta fmt basename =
Utils.fprintf_list ~sep:",@ "
(fun fmt (k, v) -> fprintf fmt "\"%s\": \"%s\"" k v)
fmt
- ["compiler-name", (Filename.basename Sys.executable_name);
- "compiler-version", Version.number;
- "command", (String.concat " " (Array.to_list Sys.argv));
- "source_file", basename
- ]
- ;
+ [
+ "compiler-name", Filename.basename Sys.executable_name;
+ "compiler-version", Version.number;
+ "command", String.concat " " (Array.to_list Sys.argv);
+ "source_file", basename;
+ ];
fprintf fmt "@ @]},@ "
-
+
let translate fmt basename prog machines =
(* record_types prog; *)
fprintf fmt "@[<v 0>{@ ";
pp_meta fmt basename;
(* Typedef *)
fprintf fmt "\"typedef\": [@[<v 0>%a@]],@ "
- (pp_emf_list pp_emf_typedef) (Corelang.get_typedefs prog);
+ (pp_emf_list pp_emf_typedef)
+ (Corelang.get_typedefs prog);
fprintf fmt "\"consts\": [@[<v 0>%a@]],@ "
- (pp_emf_list pp_emf_top_const) (Corelang.get_consts prog);
+ (pp_emf_list pp_emf_top_const)
+ (Corelang.get_consts prog);
fprintf fmt "\"imported_nodes\": @[<v 0>{@ ";
pp_emf_list pp_emf_imported_node fmt (Corelang.get_imported_nodes prog);
fprintf fmt "}@],@ ";
fprintf fmt "\"nodes\": @[<v 0>{@ ";
- (* Previous alternative: mapping normalized lustre to EMF:
+ (* Previous alternative: mapping normalized lustre to EMF:
fprintf_list ~sep:",@ " pp_decl fmt prog; *)
pp_emf_list pp_machine fmt machines;
fprintf fmt "}@]@ }";
diff --git a/src/backends/EMF/EMF_common.ml b/src/backends/EMF/EMF_common.ml
index d93bc214188292753abd439bd9dbadaf93707acd..c820d6b209922d4da4b0b8b50a57488042ded565 100644
--- a/src/backends/EMF/EMF_common.ml
+++ b/src/backends/EMF/EMF_common.ml
@@ -4,318 +4,327 @@ module VSet = Corelang.VSet
open Format
open Machine_code_common
-(* Matlab starting counting from 1.
- simple function to extract the element id in the list. Starts from 1. *)
+(* Matlab starting counting from 1. simple function to extract the element id in
+ the list. Starts from 1. *)
let rec get_idx x l =
match l with
- | hd::tl -> if hd = x then 1 else 1+(get_idx x tl)
- | [] -> assert false
+ | hd :: tl ->
+ if hd = x then 1 else 1 + get_idx x tl
+ | [] ->
+ assert false
let rec get_expr_vars v =
match v.value_desc with
- | Cst _ -> VSet.empty
- | Var v -> VSet.singleton v
- | Fun (_, args) -> List.fold_left (fun accu v -> VSet.union accu (get_expr_vars v)) VSet.empty args
- | _ -> assert false (* Invalid argument *)
+ | Cst _ ->
+ VSet.empty
+ | Var v ->
+ VSet.singleton v
+ | Fun (_, args) ->
+ List.fold_left
+ (fun accu v -> VSet.union accu (get_expr_vars v))
+ VSet.empty args
+ | _ ->
+ assert false
+(* Invalid argument *)
let is_imported_node f m =
- let (decl, _) = List.assoc f m.mcalls in
+ let decl, _ = List.assoc f m.mcalls in
Corelang.is_imported_node decl
(* Handling of enumerated types: for the moment each of such type is transformed
into an int: the idx number of the constant in the typedef. This is not so
nice but is compatible with basic Simulink types: int, real, bools) *)
-(*
-let recorded_enums = ref []
-let record_types prog =
- let typedefs = Corelang.get_typedefs prog in
- List.iter (fun top ->
- let consts = consts_of_enum_type top in
- ) prog
-*)
-
+(* let recorded_enums = ref [] let record_types prog = let typedefs =
+ Corelang.get_typedefs prog in List.iter (fun top -> let consts =
+ consts_of_enum_type top in ) prog *)
+
(* Basic printing functions *)
let hash_map = Hashtbl.create 13
-
+
(* If string length of f is longer than 50 chars, we select the 10 first and
last and put a hash in the middle *)
let print_protect fmt f =
fprintf str_formatter "%t" f;
let s = flush_str_formatter () in
let l = String.length s in
- if l > 30 then
- (* let _ = Format.eprintf "Looking for variable %s in hash @[<v 0>%t@]@." *)
- (* s *)
- (* (fun fmt -> Hashtbl.iter (fun s new_s -> fprintf fmt "%s -> %s@ " s new_s) hash_map) *)
- (* in *)
- if Hashtbl.mem hash_map s then
- fprintf fmt "%s" (Hashtbl.find hash_map s)
+ if l > 30 then (
+ if
+ (* let _ = Format.eprintf "Looking for variable %s in hash @[<v 0>%t@]@." *)
+ (* s *)
+ (* (fun fmt -> Hashtbl.iter (fun s new_s -> fprintf fmt "%s -> %s@ " s
+ new_s) hash_map) *)
+ (* in *)
+ Hashtbl.mem hash_map s
+ then fprintf fmt "%s" (Hashtbl.find hash_map s)
else
- let prefix = String.sub s 0 10 and
- suffix = String.sub s (l-10) 10 in
+ let prefix = String.sub s 0 10 and suffix = String.sub s (l - 10) 10 in
let hash = Hashtbl.hash s in
fprintf str_formatter "%s_%i_%s" prefix hash suffix;
let new_s = flush_str_formatter () in
Hashtbl.add hash_map s new_s;
- fprintf fmt "%s" new_s
- else
- fprintf fmt "%s" s
-
-let pp_var_string fmt v =fprintf fmt "\"%t\"" (fun fmt -> print_protect fmt (fun fmt -> fprintf fmt "%s" v))
-let pp_var_name fmt v = print_protect fmt (fun fmt -> Printers.pp_var_name fmt v)
+ fprintf fmt "%s" new_s)
+ else fprintf fmt "%s" s
+
+let pp_var_string fmt v =
+ fprintf fmt "\"%t\"" (fun fmt ->
+ print_protect fmt (fun fmt -> fprintf fmt "%s" v))
+
+let pp_var_name fmt v =
+ print_protect fmt (fun fmt -> Printers.pp_var_name fmt v)
(*let pp_node_args = fprintf_list ~sep:", " pp_var_name*)
(********* Printing types ***********)
-(* Two cases:
- - printing a variable definition:
- - we look at the declared type if available
- - if not, we print the inferred type
+(* Two cases: - printing a variable definition: - we look at the declared type
+ if available - if not, we print the inferred type
- - printing a constant definion
-*)
-
-
+ - printing a constant definion *)
let rec pp_emf_dim fmt dim_expr =
fprintf fmt "{";
(let open Dimension in
- match dim_expr.dim_desc with
- | Dbool b -> fprintf fmt "\"kind\": \"bool\",@ \"value\": \"%b\"" b
- | Dint i -> fprintf fmt "\"kind\": \"int\",@ \"value\": \"%i\"" i
- | Dident s -> fprintf fmt "\"kind\": \"ident\",@ \"value\": \"%s\"" s
- | Dappl(f, args) -> fprintf fmt "\"kind\": \"fun\",@ \"id\": \"%s\",@ \"args\": [@[%a@]]"
- f (Utils.fprintf_list ~sep:",@ " pp_emf_dim) args
- | Dite(i,t,e) -> fprintf fmt "\"kind\": \"ite\",@ \"guard\": \"%a\",@ \"then\": %a,@ \"else\": %a"
- pp_emf_dim i pp_emf_dim t pp_emf_dim e
- | Dlink e -> pp_emf_dim fmt e
- | Dvar
- | Dunivar -> assert false (* unresolved *)
- );
+ match dim_expr.dim_desc with
+ | Dbool b ->
+ fprintf fmt "\"kind\": \"bool\",@ \"value\": \"%b\"" b
+ | Dint i ->
+ fprintf fmt "\"kind\": \"int\",@ \"value\": \"%i\"" i
+ | Dident s ->
+ fprintf fmt "\"kind\": \"ident\",@ \"value\": \"%s\"" s
+ | Dappl (f, args) ->
+ fprintf fmt "\"kind\": \"fun\",@ \"id\": \"%s\",@ \"args\": [@[%a@]]" f
+ (Utils.fprintf_list ~sep:",@ " pp_emf_dim)
+ args
+ | Dite (i, t, e) ->
+ fprintf fmt
+ "\"kind\": \"ite\",@ \"guard\": \"%a\",@ \"then\": %a,@ \"else\": %a"
+ pp_emf_dim i pp_emf_dim t pp_emf_dim e
+ | Dlink e ->
+ pp_emf_dim fmt e
+ | Dvar | Dunivar ->
+ assert false
+ (* unresolved *));
fprintf fmt "}"
-
-
-
(* First try to print the declared one *)
let rec pp_concrete_type dec_t infered_t fmt =
match dec_t with
- | Tydec_any -> (* Dynamical built variable. No declared type. Shall
- use the infered one. *)
- pp_infered_type fmt infered_t
- | Tydec_int -> fprintf fmt "{ \"kind\": \"int\" }" (* !Options.int_type *)
- | Tydec_real -> fprintf fmt "{ \"kind\": \"real\" }" (* !Options.real_type *)
- (* TODO we could add more concrete types here if they were available in
- dec_t *)
- | Tydec_bool -> fprintf fmt "{ \"kind\": \"bool\" }"
- | Tydec_clock t -> pp_concrete_type t infered_t fmt
- | Tydec_const id -> (
+ | Tydec_any ->
+ (* Dynamical built variable. No declared type. Shall use the infered one. *)
+ pp_infered_type fmt infered_t
+ | Tydec_int ->
+ fprintf fmt "{ \"kind\": \"int\" }" (* !Options.int_type *)
+ | Tydec_real ->
+ fprintf fmt "{ \"kind\": \"real\" }"
+ (* !Options.real_type *)
+ (* TODO we could add more concrete types here if they were available in dec_t *)
+ | Tydec_bool ->
+ fprintf fmt "{ \"kind\": \"bool\" }"
+ | Tydec_clock t ->
+ pp_concrete_type t infered_t fmt
+ | Tydec_const id ->
(* This is an alias type *)
(* id for a enumerated type, eg. introduced by automata *)
- let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.type_table dec_t)) in
- (* Print the type name associated to this enumerated type. This is
- basically an integer *)
+ let typ =
+ Corelang.typedef_of_top (Hashtbl.find Corelang.type_table dec_t)
+ in
+ (* Print the type name associated to this enumerated type. This is basically
+ an integer *)
pp_tag_type id typ infered_t fmt
- )
-
| Tydec_struct _ | Tydec_enum _ ->
- assert false (* should not happen. These type are only built when
- declaring a type in the prefix of the lustre
- file. They shall not be associated to variables
- *)
-
- | Tydec_array (dim, e) -> (
- let inf_base = match infered_t.Typing.tdesc with
- | Typing.Tarray(_,t) -> t
- | _ -> (* returing something useless, hoping that the concrete
- datatype will return something usefull *)
- Typing.new_var ()
+ assert false
+ (* should not happen. These type are only built when declaring a type in the
+ prefix of the lustre file. They shall not be associated to variables *)
+ | Tydec_array (dim, e) ->
+ let inf_base =
+ match infered_t.Typing.tdesc with
+ | Typing.Tarray (_, t) ->
+ t
+ | _ ->
+ (* returing something useless, hoping that the concrete datatype will
+ return something usefull *)
+ Typing.new_var ()
in
fprintf fmt "{ \"kind\": \"array\", \"base_type\": %t, \"dim\": %a }"
(pp_concrete_type e inf_base)
pp_emf_dim dim
- )
-
+
(* | _ -> eprintf
* "unhandled construct in type printing for EMF backend: %a@."
* Printers.pp_var_type_dec_desc dec_t; raise (Failure "var") *)
and pp_tag_type id typ inf fmt =
- (* We ought to represent these types as values: enum will become int, we keep the name for structs *)
+ (* We ought to represent these types as values: enum will become int, we keep
+ the name for structs *)
let rec aux tydec_desc =
- match tydec_desc with
- | Tydec_int
- | Tydec_real
- | Tydec_bool
- | Tydec_array _ -> pp_concrete_type tydec_desc inf fmt
+ match tydec_desc with
+ | Tydec_int | Tydec_real | Tydec_bool | Tydec_array _ ->
+ pp_concrete_type tydec_desc inf fmt
| Tydec_const id ->
- (* Alias of an alias: unrolling definitions *)
- let typ = (Corelang.typedef_of_top
- (Hashtbl.find Corelang.type_table tydec_desc))
- in
- pp_tag_type id typ inf fmt
-
- | Tydec_clock ty -> aux ty
- | Tydec_enum const_list -> ( (* enum can be mapped to int *)
+ (* Alias of an alias: unrolling definitions *)
+ let typ =
+ Corelang.typedef_of_top (Hashtbl.find Corelang.type_table tydec_desc)
+ in
+ pp_tag_type id typ inf fmt
+ | Tydec_clock ty ->
+ aux ty
+ | Tydec_enum const_list ->
+ (* enum can be mapped to int *)
let size = List.length const_list in
- fprintf fmt "{ \"name\": \"%s\", \"kind\": \"enum\", \"size\": \"%i\" }" id size
- )
+ fprintf fmt "{ \"name\": \"%s\", \"kind\": \"enum\", \"size\": \"%i\" }"
+ id size
| Tydec_struct _ ->
- fprintf fmt "{ \"name\": \"%s\", \"kind\": \"struct\" }" id
- | Tydec_any -> (* shall not happen: a declared type cannot be
- bound to type any *)
- assert false
+ fprintf fmt "{ \"name\": \"%s\", \"kind\": \"struct\" }" id
+ | Tydec_any ->
+ (* shall not happen: a declared type cannot be bound to type any *)
+ assert false
in
aux typ.tydef_desc
+
and pp_infered_type fmt t =
- (* Shall only be used for variable types that were not properly declared. Ie generated at compile time. *)
+ (* Shall only be used for variable types that were not properly declared. Ie
+ generated at compile time. *)
let open Types in
- if is_bool_type t then fprintf fmt "{ \"kind\": \"bool\" }" else
- if is_int_type t then fprintf fmt "{ \"kind\": \"int\" }" else (* !Options.int_type *)
- if is_real_type t then fprintf fmt "{ \"kind\": \"real\" }" else (* !Options.real_type *)
- match t.tdesc with
- | Tclock t ->
- pp_infered_type fmt t
- | Tstatic (_, t) ->
- fprintf fmt "%a" pp_infered_type t
- | Tconst id ->
- (* This is a type id for a enumerated type, eg. introduced by automata *)
- let typ =
- (Corelang.typedef_of_top
- (Hashtbl.find Corelang.type_table (Tydec_const id)))
- in
- pp_tag_type id typ t fmt
- | Tlink ty ->
- pp_infered_type fmt ty
- | Tarray (dim, base_t) ->
- fprintf fmt "{ \"kind\": \"array\", \"base_type\": %a, \"dim\": %a }"
- pp_infered_type base_t
- pp_emf_dim dim
- | _ -> eprintf "unhandled type: %a@." Types.print_node_ty t; assert false
-
-(*let pp_cst_type fmt v =
- match v.value_desc with
- | Cst c-> pp_cst_type c v.value_type fmt (* constants do not have declared type (yet) *)
- | _ -> assert false
-*)
+ if is_bool_type t then fprintf fmt "{ \"kind\": \"bool\" }"
+ else if is_int_type t then fprintf fmt "{ \"kind\": \"int\" }"
+ else if (* !Options.int_type *)
+ is_real_type t then fprintf fmt "{ \"kind\": \"real\" }"
+ else
+ (* !Options.real_type *)
+ match t.tdesc with
+ | Tclock t ->
+ pp_infered_type fmt t
+ | Tstatic (_, t) ->
+ fprintf fmt "%a" pp_infered_type t
+ | Tconst id ->
+ (* This is a type id for a enumerated type, eg. introduced by automata *)
+ let typ =
+ Corelang.typedef_of_top
+ (Hashtbl.find Corelang.type_table (Tydec_const id))
+ in
+ pp_tag_type id typ t fmt
+ | Tlink ty ->
+ pp_infered_type fmt ty
+ | Tarray (dim, base_t) ->
+ fprintf fmt "{ \"kind\": \"array\", \"base_type\": %a, \"dim\": %a }"
+ pp_infered_type base_t pp_emf_dim dim
+ | _ ->
+ eprintf "unhandled type: %a@." Types.print_node_ty t;
+ assert false
+
+(*let pp_cst_type fmt v = match v.value_desc with | Cst c-> pp_cst_type c
+ v.value_type fmt (* constants do not have declared type (yet) *) | _ -> assert
+ false *)
(* Provide both the declared type and the infered one. *)
let pp_var_type fmt v =
try
- if Machine_types.is_specified v then
- Machine_types.pp_var_type fmt v
- else
- pp_concrete_type v.var_dec_type.ty_dec_desc v.var_type fmt
- with Failure msg -> eprintf "failed var: %a@.%s@." Printers.pp_var v msg; assert false
-
+ if Machine_types.is_specified v then Machine_types.pp_var_type fmt v
+ else pp_concrete_type v.var_dec_type.ty_dec_desc v.var_type fmt
+ with Failure msg ->
+ eprintf "failed var: %a@.%s@." Printers.pp_var v msg;
+ assert false
+
(******** Other print functions *)
-let pp_emf_list ?(eol:('a, formatter, unit) Stdlib.format="") pp fmt l =
+let pp_emf_list ?(eol : ('a, formatter, unit) Stdlib.format = "") pp fmt l =
match l with
- [] -> ()
- | _ -> fprintf fmt "@[";
- Utils.fprintf_list ~sep:",@ " pp fmt l;
- fprintf fmt "@]%(%)" eol
-
+ | [] ->
+ ()
+ | _ ->
+ fprintf fmt "@[";
+ Utils.fprintf_list ~sep:",@ " pp fmt l;
+ fprintf fmt "@]%(%)" eol
+
(* Print the variable declaration *)
let pp_emf_var_decl fmt v =
- fprintf fmt "@[{\"name\": \"%a\", \"datatype\": %a, \"original_name\": \"%a\"}@]"
- pp_var_name v
- pp_var_type v
- Printers.pp_var_name v
+ fprintf fmt
+ "@[{\"name\": \"%a\", \"datatype\": %a, \"original_name\": \"%a\"}@]"
+ pp_var_name v pp_var_type v Printers.pp_var_name v
let pp_emf_vars_decl = pp_emf_list pp_emf_var_decl
-
-
-let reset_name id =
- "reset_" ^ id
-
+let reset_name id = "reset_" ^ id
+
let pp_tag_id fmt t =
- let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t)) in
- if typ.tydef_id = "bool" then
- pp_print_string fmt t
+ let typ = Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t) in
+ if typ.tydef_id = "bool" then pp_print_string fmt t
else
- let const_list = match typ.tydef_desc with Tydec_enum tl -> tl | _ -> assert false in
+ let const_list =
+ match typ.tydef_desc with Tydec_enum tl -> tl | _ -> assert false
+ in
fprintf fmt "%i" (get_idx t const_list)
let pp_cst_type c inf fmt (*infered_typ*) =
let pp_basic fmt s = fprintf fmt "{ \"kind\": \"%s\" }" s in
match c with
| Const_tag t ->
- let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t)) in
- if typ.tydef_id = "bool" then
- pp_basic fmt "bool"
- else
- pp_tag_type t typ inf fmt
- | Const_int _ -> pp_basic fmt "int" (*!Options.int_type*)
- | Const_real _ -> pp_basic fmt "real" (*!Options.real_type*)
- | Const_string _ -> pp_basic fmt "string"
- | _ -> eprintf "cst: %a@." Printers.pp_const c; assert false
-
-
+ let typ = Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t) in
+ if typ.tydef_id = "bool" then pp_basic fmt "bool"
+ else pp_tag_type t typ inf fmt
+ | Const_int _ ->
+ pp_basic fmt "int" (*!Options.int_type*)
+ | Const_real _ ->
+ pp_basic fmt "real" (*!Options.real_type*)
+ | Const_string _ ->
+ pp_basic fmt "string"
+ | _ ->
+ eprintf "cst: %a@." Printers.pp_const c;
+ assert false
+
let pp_emf_cst c inf fmt =
- let pp_typ fmt =
- fprintf fmt "\"datatype\": %t@ "
- (pp_cst_type c inf)
- in
+ let pp_typ fmt = fprintf fmt "\"datatype\": %t@ " (pp_cst_type c inf) in
match c with
- | Const_tag t->
- let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t)) in
- if typ.tydef_id = "bool" then (
- fprintf fmt "{@[\"type\": \"constant\",@ ";
- fprintf fmt"\"value\": \"%a\",@ "
- Printers.pp_const c;
- pp_typ fmt;
- fprintf fmt "@]}"
- )
- else (
- fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\",@ "
- pp_tag_id t;
- fprintf fmt "\"origin_type\": \"%s\",@ \"origin_value\": \"%s\",@ "
- typ.tydef_id t;
- pp_typ fmt;
- fprintf fmt "@]}"
- )
+ | Const_tag t ->
+ let typ = Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t) in
+ if typ.tydef_id = "bool" then (
+ fprintf fmt "{@[\"type\": \"constant\",@ ";
+ fprintf fmt "\"value\": \"%a\",@ " Printers.pp_const c;
+ pp_typ fmt;
+ fprintf fmt "@]}")
+ else (
+ fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\",@ " pp_tag_id t;
+ fprintf fmt "\"origin_type\": \"%s\",@ \"origin_value\": \"%s\",@ "
+ typ.tydef_id t;
+ pp_typ fmt;
+ fprintf fmt "@]}")
| Const_string s ->
- fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%s\",@ " s;
- pp_typ fmt;
- fprintf fmt "@]}"
-
- | _ -> (
+ fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%s\",@ " s;
+ pp_typ fmt;
+ fprintf fmt "@]}"
+ | _ ->
fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\",@ "
Printers.pp_const c;
pp_typ fmt;
fprintf fmt "@]}"
- )
-
+
(* Print a value: either a constant or a variable value *)
let rec pp_emf_cst_or_var m fmt v =
match v.value_desc with
- | Cst c -> pp_emf_cst c v.value_type fmt
- | Var v -> (
- fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ "
- pp_var_name v;
- (* fprintf fmt "\"original_name\": \"%a\",@ " Printers.pp_var_name v; *)
+ | Cst c ->
+ pp_emf_cst c v.value_type fmt
+ | Var v ->
+ fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ " pp_var_name v;
+ (* fprintf fmt "\"original_name\": \"%a\",@ " Printers.pp_var_name v; *)
fprintf fmt "\"datatype\": %a@ " pp_var_type v;
fprintf fmt "@]}"
- )
- | Array vl -> (
- fprintf fmt "{@[\"type\": \"array\",@ \"value\": @[[%a@]]@ "
+ | Array vl ->
+ fprintf fmt "{@[\"type\": \"array\",@ \"value\": @[[%a@]]@ "
(pp_emf_cst_or_var_list m) vl;
- fprintf fmt "@]}"
- )
- | Access (arr, idx) -> (
- fprintf fmt "{@[\"type\": \"array access\",@ \"array\": @[[%a@]],@ \"idx\": @[[%a@]]@ "
+ fprintf fmt "@]}"
+ | Access (arr, idx) ->
+ fprintf fmt
+ "{@[\"type\": \"array access\",@ \"array\": @[[%a@]],@ \"idx\": \
+ @[[%a@]]@ "
(pp_emf_cst_or_var m) arr (pp_emf_cst_or_var m) idx;
- fprintf fmt "@]}"
- )
- | Power (v,nb) ->(
- fprintf fmt "{@[\"type\": \"power\",@ \"expr\": @[[%a@]],@ \"nb\": @[[%a@]]@ "
+ fprintf fmt "@]}"
+ | Power (v, nb) ->
+ fprintf fmt
+ "{@[\"type\": \"power\",@ \"expr\": @[[%a@]],@ \"nb\": @[[%a@]]@ "
(pp_emf_cst_or_var m) v (pp_emf_cst_or_var m) nb;
- fprintf fmt "@]}"
- )
- | Fun _ -> eprintf "Fun expression should have been normalized: %a@." (pp_val m) v ; assert false (* Invalid argument *)
+ fprintf fmt "@]}"
+ | Fun _ ->
+ eprintf "Fun expression should have been normalized: %a@." (pp_val m) v;
+ assert false (* Invalid argument *)
| ResetFlag ->
(* TODO: handle reset flag *)
assert false
@@ -324,46 +333,37 @@ and pp_emf_cst_or_var_list m =
Utils.fprintf_list ~sep:",@ " (pp_emf_cst_or_var m)
(* Printer lustre expr and eexpr *)
-
+
let rec pp_emf_expr fmt e =
match e.expr_desc with
- | Expr_const c -> pp_emf_cst c e.expr_type fmt
+ | Expr_const c ->
+ pp_emf_cst c e.expr_type fmt
| Expr_ident id ->
- fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ "
- print_protect (fun fmt -> pp_print_string fmt id);
+ fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ " print_protect
+ (fun fmt -> pp_print_string fmt id);
fprintf fmt "\"datatype\": %t@ "
- (pp_concrete_type
- Tydec_any (* don't know much about that time since it was not
- declared. That may not work with clock constants *)
- e.expr_type
- );
+ (pp_concrete_type Tydec_any
+ (* don't know much about that time since it was not declared. That may
+ not work with clock constants *)
+ e.expr_type);
fprintf fmt "@]}"
-
| Expr_tuple el ->
- fprintf fmt "[@[<hov 0>%a@ @]]"
- (Utils.fprintf_list ~sep:",@ " pp_emf_expr) el
- (* Missing these
- | Expr_ite of expr * expr * expr
- | Expr_arrow of expr * expr
- | Expr_fby of expr * expr
- | Expr_array of expr list
- | Expr_access of expr * Dimension.dim_expr
- | Expr_power of expr * Dimension.dim_expr
- | Expr_pre of expr
- | Expr_when of expr * ident * label
- | Expr_merge of ident * (label * expr) list
- | Expr_appl of call_t
- *)
- | _ -> (
- Log.report ~level:2
- (fun fmt ->
- fprintf fmt "Warning: unhandled expression %a in annotation.@ "
- Printers.pp_expr e;
- fprintf fmt "Will not be produced in the experted JSON EMF@."
- );
+ fprintf fmt "[@[<hov 0>%a@ @]]"
+ (Utils.fprintf_list ~sep:",@ " pp_emf_expr)
+ el
+ (* Missing these | Expr_ite of expr * expr * expr | Expr_arrow of expr * expr
+ | Expr_fby of expr * expr | Expr_array of expr list | Expr_access of expr *
+ Dimension.dim_expr | Expr_power of expr * Dimension.dim_expr | Expr_pre of
+ expr | Expr_when of expr * ident * label | Expr_merge of ident * (label *
+ expr) list | Expr_appl of call_t *)
+ | _ ->
+ Log.report ~level:2 (fun fmt ->
+ fprintf fmt "Warning: unhandled expression %a in annotation.@ "
+ Printers.pp_expr e;
+ fprintf fmt "Will not be produced in the experted JSON EMF@.");
fprintf fmt "\"unhandled construct, complain to Ploc\""
- )
-(* Remaining constructs *)
+
+(* Remaining constructs *)
(* | Expr_ite of expr * expr * expr *)
(* | Expr_arrow of expr * expr *)
(* | Expr_fby of expr * expr *)
@@ -376,77 +376,89 @@ let rec pp_emf_expr fmt e =
(* | Expr_appl of call_t *)
let pp_emf_exprs = pp_emf_list pp_emf_expr
-
+
let pp_emf_const fmt v =
- fprintf fmt "@[<hov 0>{\"name\": \"%a\",@ \"datatype\":%a,@ \"original_name\": \"%a\",@ \"value\": %a}@]"
- pp_var_name v
- pp_var_type v
- Printers.pp_var_name v
- pp_emf_expr (match v.var_dec_value with None -> assert false | Some e -> e)
+ fprintf fmt
+ "@[<hov 0>{\"name\": \"%a\",@ \"datatype\":%a,@ \"original_name\": \
+ \"%a\",@ \"value\": %a}@]"
+ pp_var_name v pp_var_type v Printers.pp_var_name v pp_emf_expr
+ (match v.var_dec_value with None -> assert false | Some e -> e)
let pp_emf_consts = pp_emf_list pp_emf_const
-
+
let pp_emf_eexpr fmt ee =
fprintf fmt "{@[<hov 0>%t\"quantifiers\": \"%a\",@ \"qfexpr\": @[%a@]@] }"
- (fun fmt -> match ee.eexpr_name with
- | None -> ()
- | Some name -> Format.fprintf fmt "\"name\": \"%s\",@ " name
- )
+ (fun fmt ->
+ match ee.eexpr_name with
+ | None ->
+ ()
+ | Some name ->
+ Format.fprintf fmt "\"name\": \"%s\",@ " name)
(Utils.fprintf_list ~sep:"; " Printers.pp_quantifiers)
- ee.eexpr_quantifiers
- pp_emf_expr ee.eexpr_qfexpr
+ ee.eexpr_quantifiers pp_emf_expr ee.eexpr_qfexpr
let pp_emf_eexprs = pp_emf_list pp_emf_eexpr
-(*
- TODO Thanksgiving
+(* TODO Thanksgiving
+
+ trouver un moyen de transformer en machine code les instructions de chaque
+ spec peut etre associer a chaque imported node une minimachine et rajouter un
+ champ a spec dans machine code pour stoquer memoire et instr *)
- trouver un moyen de transformer en machine code les instructions de chaque spec
- peut etre associer a chaque imported node une minimachine
- et rajouter un champ a spec dans machine code pour stoquer memoire et instr
- *)
-
let pp_emf_stmt fmt stmt =
match stmt with
- | Aut _ -> assert false
- | Eq eq -> (
- fprintf fmt "@[ @[<v 2>\"%a\": {@ " (Utils.fprintf_list ~sep:"_" pp_print_string) eq.eq_lhs;
- fprintf fmt "\"lhs\": [%a],@ " (Utils.fprintf_list ~sep:", " (fun fmt vid -> fprintf fmt "\"%s\"" vid)) eq.eq_lhs;
+ | Aut _ ->
+ assert false
+ | Eq eq ->
+ fprintf fmt "@[ @[<v 2>\"%a\": {@ "
+ (Utils.fprintf_list ~sep:"_" pp_print_string)
+ eq.eq_lhs;
+ fprintf fmt "\"lhs\": [%a],@ "
+ (Utils.fprintf_list ~sep:", " (fun fmt vid -> fprintf fmt "\"%s\"" vid))
+ eq.eq_lhs;
fprintf fmt "\"rhs\": %a,@ " pp_emf_expr eq.eq_rhs;
fprintf fmt "@]@]@ }"
- )
-let pp_emf_stmts = pp_emf_list pp_emf_stmt
-
+let pp_emf_stmts = pp_emf_list pp_emf_stmt
+
(* Printing the type declaration, not its use *)
let rec pp_emf_typ_dec fmt tydef_dec =
fprintf fmt "{";
(match tydef_dec with
- | Tydec_any -> fprintf fmt "\"kind\": \"any\""
- | Tydec_int -> fprintf fmt "\"kind\": \"int\""
- | Tydec_real -> fprintf fmt "\"kind\": \"real\""
- | Tydec_bool-> fprintf fmt "\"kind\": \"bool\""
- | Tydec_clock ck -> pp_emf_typ_dec fmt ck
- | Tydec_const c -> fprintf fmt "\"kind\": \"alias\",@ \"value\": \"%s\"" c
- | Tydec_enum el -> fprintf fmt "\"kind\": \"enum\",@ \"elements\": [%a]"
- (Utils.fprintf_list ~sep:", " (fun fmt e -> fprintf fmt "\"%s\"" e)) el
- | Tydec_struct s -> fprintf fmt "\"kind\": \"struct\",@ \"fields\": [%a]"
- (Utils.fprintf_list ~sep:", " (fun fmt (id,typ) ->
- fprintf fmt "\"%s\": %a" id pp_emf_typ_dec typ)) s
- | Tydec_array (dim, typ) -> fprintf fmt "\"kind\": \"array\",@ \"dim\": @[%a@],@ \"base\": %a"
- pp_emf_dim dim
- pp_emf_typ_dec typ
- );
+ | Tydec_any ->
+ fprintf fmt "\"kind\": \"any\""
+ | Tydec_int ->
+ fprintf fmt "\"kind\": \"int\""
+ | Tydec_real ->
+ fprintf fmt "\"kind\": \"real\""
+ | Tydec_bool ->
+ fprintf fmt "\"kind\": \"bool\""
+ | Tydec_clock ck ->
+ pp_emf_typ_dec fmt ck
+ | Tydec_const c ->
+ fprintf fmt "\"kind\": \"alias\",@ \"value\": \"%s\"" c
+ | Tydec_enum el ->
+ fprintf fmt "\"kind\": \"enum\",@ \"elements\": [%a]"
+ (Utils.fprintf_list ~sep:", " (fun fmt e -> fprintf fmt "\"%s\"" e))
+ el
+ | Tydec_struct s ->
+ fprintf fmt "\"kind\": \"struct\",@ \"fields\": [%a]"
+ (Utils.fprintf_list ~sep:", " (fun fmt (id, typ) ->
+ fprintf fmt "\"%s\": %a" id pp_emf_typ_dec typ))
+ s
+ | Tydec_array (dim, typ) ->
+ fprintf fmt "\"kind\": \"array\",@ \"dim\": @[%a@],@ \"base\": %a"
+ pp_emf_dim dim pp_emf_typ_dec typ);
fprintf fmt "}"
-
+
let pp_emf_typedef fmt typdef_top =
let typedef = Corelang.typedef_of_top typdef_top in
- fprintf fmt "{ \"%s\": @[%a@] }" typedef.tydef_id pp_emf_typ_dec typedef.tydef_desc
-
-let pp_emf_top_const fmt const_top =
+ fprintf fmt "{ \"%s\": @[%a@] }" typedef.tydef_id pp_emf_typ_dec
+ typedef.tydef_desc
+
+let pp_emf_top_const fmt const_top =
let const = Corelang.const_of_top const_top in
- fprintf fmt "{ \"%s\": %t }"
- const.const_id
+ fprintf fmt "{ \"%s\": %t }" const.const_id
(pp_emf_cst const.const_value const.const_type)
(* Local Variables: *)
diff --git a/src/backends/EMF/EMF_library_calls.ml b/src/backends/EMF/EMF_library_calls.ml
index d34eb96524ff035c8bd94b2d03f4e83566c30559..788f455357feebd22974b5993f457e1414df30d9 100644
--- a/src/backends/EMF/EMF_library_calls.ml
+++ b/src/backends/EMF/EMF_library_calls.ml
@@ -1,7 +1,7 @@
(** This function focuses on standard library calls: conversion functions and
math library. It could be later extended to handle more functions. For the
- moment, modular compilation of multiple lustre sources as one output JSON is not
- considered. *)
+ moment, modular compilation of multiple lustre sources as one output JSON is
+ not considered. *)
open Lustre_types
open Machine_code_types
@@ -9,30 +9,26 @@ open Format
open EMF_common
let pp_call fmt m f outputs inputs =
- let (decl, _) = List.assoc f m.mcalls in
- if Corelang.is_imported_node decl then
+ let decl, _ = List.assoc f m.mcalls in
+ if Corelang.is_imported_node decl then (
let inode = Corelang.imported_node_of_top decl in
match inode.nodei_id, Filename.basename decl.top_decl_owner with
- | name, (("lustrec_math" | "simulink_math_fcn" | "conv") as lib) -> (
- fprintf fmt "\"kind\": \"functioncall\",@ \"name\": \"%s\",@ \"library\": \"%s\",@ "
+ | name, (("lustrec_math" | "simulink_math_fcn" | "conv") as lib) ->
+ fprintf fmt
+ "\"kind\": \"functioncall\",@ \"name\": \"%s\",@ \"library\": \"%s\",@ "
name lib;
fprintf fmt "\"lhs\": [@[%a@]],@ \"args\": [@[%a@]]"
- (Utils.fprintf_list ~sep:",@ " (fun fmt v -> fprintf fmt "\"%a\"" Printers.pp_var_name v)) outputs
- (pp_emf_cst_or_var_list m) inputs
- )
+ (Utils.fprintf_list ~sep:",@ " (fun fmt v ->
+ fprintf fmt "\"%a\"" Printers.pp_var_name v))
+ outputs (pp_emf_cst_or_var_list m) inputs
| _ ->
- Format.eprintf "Calls to function %s in library %s are not handled yet.@."
- inode.nodei_id
- (Filename.basename decl.top_decl_owner)
- ;
- assert false
- else
- assert false (* shall not happen *)
+ Format.eprintf "Calls to function %s in library %s are not handled yet.@."
+ inode.nodei_id
+ (Filename.basename decl.top_decl_owner);
+ assert false)
+ else assert false
+(* shall not happen *)
-
-
-
- (* Local Variables: *)
- (* compile-command: "make -C ../.." *)
- (* End: *)
-
+(* Local Variables: *)
+(* compile-command: "make -C ../.." *)
+(* End: *)
diff --git a/src/backends/Horn/horn_backend.ml b/src/backends/Horn/horn_backend.ml
index a615cd4da0f1b90cba8cbe344ec90b060d301f85..50625633ba0c0ceebc570008c1a71cdd681c800b 100644
--- a/src/backends/Horn/horn_backend.ml
+++ b/src/backends/Horn/horn_backend.ml
@@ -12,41 +12,32 @@
(* The compilation presented here was first defined in Garoche, Gurfinkel,
Kahsai, HCSV'14.
- This is a modified version that handles reset and automaton
-*)
+ This is a modified version that handles reset and automaton *)
open Format
open Lustre_types
open Corelang
open Machine_code_types
-
open Horn_backend_common
open Horn_backend_printers
open Horn_backend_collecting_sem
-(*
-TODO:
-- gerer les traces. Ca merde pour l'instant dans le calcul des memoires sur les arrows
-- gerer le reset --- DONE
-- reconstruire les rechable states DONE
-- reintroduire le cex/traces ... DONE
-- traiter les types enum et les branchements sur ces types enum (en particulier les traitements des resets qui ont lieu dans certaines branches et pas dans d'autres )
-*)
+(* TODO: - gerer les traces. Ca merde pour l'instant dans le calcul des memoires
+ sur les arrows - gerer le reset --- DONE - reconstruire les rechable states
+ DONE - reintroduire le cex/traces ... DONE - traiter les types enum et les
+ branchements sur ces types enum (en particulier les traitements des resets
+ qui ont lieu dans certaines branches et pas dans d'autres ) *)
let main_print machines fmt =
-if !Options.main_node <> "" then
- begin
+ if !Options.main_node <> "" then
let node = !Options.main_node in
let machine = get_machine machines node in
- if !Options.horn_cex then(
+ if !Options.horn_cex then (
cex_computation machines fmt node machine;
get_cex machines fmt machine)
else (
collecting_semantics machines fmt node machine;
- check_prop machines fmt machine;
- )
-end
-
+ check_prop machines fmt machine)
let load_file f =
let ic = open_in f in
@@ -58,82 +49,93 @@ let load_file f =
let print_type_definitions fmt =
let cpt_type = ref 0 in
- Hashtbl.iter (fun typ decl ->
- match typ with
- | Tydec_const var ->
- (match decl.top_decl_desc with
- | TypeDef tdef -> (
- match tdef.tydef_desc with
- | Tydec_enum tl ->
- incr cpt_type;
- fprintf fmt "(declare-datatypes () ((%s %a)));@.@."
- var
- (Utils.fprintf_list ~sep:" " pp_print_string) tl
- | _ -> assert false
- )
- | _ -> assert false
- )
- | _ -> ()) type_table
-
-
-
+ Hashtbl.iter
+ (fun typ decl ->
+ match typ with
+ | Tydec_const var -> (
+ match decl.top_decl_desc with
+ | TypeDef tdef -> (
+ match tdef.tydef_desc with
+ | Tydec_enum tl ->
+ incr cpt_type;
+ fprintf fmt "(declare-datatypes () ((%s %a)));@.@." var
+ (Utils.fprintf_list ~sep:" " pp_print_string)
+ tl
+ | _ ->
+ assert false)
+ | _ ->
+ assert false)
+ | _ ->
+ ())
+ type_table
let print_dep fmt prog =
- Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. extracting Horn libraries@,");
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@[<v 2>.. extracting Horn libraries@,");
fprintf fmt "; Statically linked libraries@,";
let dependencies = Corelang.get_dependencies prog in
List.iter
(fun dep ->
- let (local, s) = Corelang.dependency_of_top dep in
- let basename = (Options_management.name_dependency (local, s) ".lusic") ^ ".smt2" in
- Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@[<v 0> Horn Library %s@," basename);
+ let local, s = Corelang.dependency_of_top dep in
+ let basename =
+ Options_management.name_dependency (local, s) ".lusic" ^ ".smt2"
+ in
+ Log.report ~level:1 (fun fmt ->
+ Format.fprintf fmt "@[<v 0> Horn Library %s@," basename);
let horn = load_file basename in
- fprintf fmt "@.%s@." (horn);
- )
+ fprintf fmt "@.%s@." horn)
dependencies
let check_sfunction mannot =
- (*Check if its an sfunction*)
+ (*Check if its an sfunction*)
match mannot with
- [] -> false
- | [x] ->
- begin
- match x.annots with
- [] -> false
- |[(key, _)] ->
- begin
- match key with
- [] -> false
- | [x] -> x == "c_code" || x =="matlab"
- | _ -> false
- end
- |(_,_)::_ -> false
- end
- | _::_ -> false
+ | [] ->
+ false
+ | [ x ] -> (
+ match x.annots with
+ | [] ->
+ false
+ | [ (key, _) ] -> (
+ match key with
+ | [] ->
+ false
+ | [ x ] ->
+ x == "c_code" || x == "matlab"
+ | _ ->
+ false)
+ | (_, _) :: _ ->
+ false)
+ | _ :: _ ->
+ false
let preprocess machines =
- List.fold_right (fun m res ->
- if List.mem m.mname.node_id registered_keywords then
- { m with mname = { m.mname with node_id = protect_kwd m.mname.node_id }}::res
- else
- m :: res
- ) machines []
-
-let translate fmt prog machines=
+ List.fold_right
+ (fun m res ->
+ if List.mem m.mname.node_id registered_keywords then
+ {
+ m with
+ mname = { m.mname with node_id = protect_kwd m.mname.node_id };
+ }
+ :: res
+ else m :: res)
+ machines []
+
+let translate fmt prog machines =
let machines = preprocess machines in
(* We print typedef *)
- print_dep fmt prog; (*print static library e.g. math*)
+ print_dep fmt prog;
+ (*print static library e.g. math*)
print_type_definitions fmt;
(*List.iter (print_machine machines fmt) (List.rev machines);*)
- List.iter(fun m ->
+ List.iter
+ (fun m ->
let is_sfunction = check_sfunction m.mannot in
- if is_sfunction then(
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. detected sfunction: %s@," m.mname.node_id);
- print_sfunction machines fmt m
- ) else (
- print_machine machines fmt m)
- )
- (List.rev machines);
+ if is_sfunction then (
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt ".. detected sfunction: %s@," m.mname.node_id);
+ print_sfunction machines fmt m)
+ else print_machine machines fmt m)
+ (List.rev machines);
main_print machines fmt
(* Local Variables: *)
diff --git a/src/backends/Horn/horn_backend_collecting_sem.ml b/src/backends/Horn/horn_backend_collecting_sem.ml
index a69848fa4cbf04b861e624e72cdfcc541d86bd8e..059c0ae447f535781c348afad98ee2aa1a8947e0 100644
--- a/src/backends/Horn/horn_backend_collecting_sem.ml
+++ b/src/backends/Horn/horn_backend_collecting_sem.ml
@@ -12,13 +12,11 @@
(* The compilation presented here was first defined in Garoche, Gurfinkel,
Kahsai, HCSV'14.
- This is a modified version that handle reset
-*)
+ This is a modified version that handle reset *)
open Format
open Lustre_types
open Machine_code_types
-
open Horn_backend_common
open Horn_backend_printers
@@ -29,24 +27,29 @@ let collecting_semantics machines fmt node machine =
rename_machine_list machine.mname.node_id machine.mstep.step_outputs
in
let main_output_dummy =
- rename_machine_list ("dummy" ^ machine.mname.node_id) machine.mstep.step_outputs
+ rename_machine_list
+ ("dummy" ^ machine.mname.node_id)
+ machine.mstep.step_outputs
in
let main_memory_next =
- (rename_next_list (* machine.mname.node_id *) (full_memory_vars machines machine)) @
- main_output
+ rename_next_list
+ (* machine.mname.node_id *)
+ (full_memory_vars machines machine)
+ @ main_output
in
let main_memory_current =
- (rename_current_list (* machine.mname.node_id *) (full_memory_vars machines machine)) @
- main_output_dummy
+ rename_current_list
+ (* machine.mname.node_id *)
+ (full_memory_vars machines machine)
+ @ main_output_dummy
in
fprintf fmt "(declare-rel MAIN (%a))@."
(Utils.fprintf_list ~sep:" " pp_type)
(List.map (fun v -> v.var_type) main_memory_next);
-
(* Init case *)
- let _ =
+ let _ =
(* Special case when the main node is stateless *)
if Machine_code_common.is_stateless machine then (
let step_name = pp_machine_stateless_name in
@@ -55,96 +58,102 @@ let collecting_semantics machines fmt node machine =
fprintf fmt "(rule INIT_STATE)@.";
fprintf fmt "@[<v 2>(rule (=> @ (and @[<v 0>";
fprintf fmt "INIT_STATE@ ";
- fprintf fmt "(@[<v 0>%a %a@])"
- step_name node
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) (step_vars_m_x machines machine);
+ fprintf fmt "(@[<v 0>%a %a@])" step_name node
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ (step_vars_m_x machines machine);
fprintf fmt "@]@ )@ ";
fprintf fmt "(MAIN %a)@]@.))@.@."
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) main_memory_next ;
- )
- else (
- let reset_name, step_name =
- pp_machine_reset_name, pp_machine_step_name
- in
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ main_memory_next)
+ else
+ let reset_name, step_name = pp_machine_reset_name, pp_machine_step_name in
fprintf fmt "; Initial set: Reset(c,m) + One Step(m,x) @.";
fprintf fmt "(declare-rel INIT_STATE ())@.";
fprintf fmt "(rule INIT_STATE)@.";
fprintf fmt "@[<v 2>(rule (=> @ (and @[<v 0>";
fprintf fmt "INIT_STATE@ ";
- fprintf fmt "(@[<v 0>%a %a@])@ "
- reset_name node
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) (reset_vars machines machine);
- fprintf fmt "(@[<v 0>%a %a@])"
- step_name node
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) (step_vars_m_x machines machine);
-
+ fprintf fmt "(@[<v 0>%a %a@])@ " reset_name node
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ (reset_vars machines machine);
+ fprintf fmt "(@[<v 0>%a %a@])" step_name node
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ (step_vars_m_x machines machine);
+
fprintf fmt "@]@ )@ ";
fprintf fmt "(MAIN %a)@]@.))@.@."
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) main_memory_next ;
- )
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ main_memory_next
in
- let step_name =
- if Machine_code_common.is_stateless machine then
- pp_machine_stateless_name
- else
- pp_machine_step_name
+ let step_name =
+ if Machine_code_common.is_stateless machine then pp_machine_stateless_name
+ else pp_machine_step_name
in
-
+
fprintf fmt "; Inductive def@.";
- (Utils.fprintf_list ~sep:" " (fun fmt v -> fprintf fmt "%a@." pp_decl_var v)) fmt main_output_dummy;
+ (Utils.fprintf_list ~sep:" " (fun fmt v -> fprintf fmt "%a@." pp_decl_var v))
+ fmt main_output_dummy;
fprintf fmt
- "@[<v 2>(rule (=> @ (and @[<v 0>(MAIN %a)@ (@[<v 0>%a %a@])@]@ )@ (MAIN %a)@]@.))@.@."
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) main_memory_current
- step_name node
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) (step_vars machines machine)
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) main_memory_next
-
+ "@[<v 2>(rule (=> @ (and @[<v 0>(MAIN %a)@ (@[<v 0>%a %a@])@]@ )@ (MAIN \
+ %a)@]@.))@.@."
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ main_memory_current step_name node
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ (step_vars machines machine)
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ main_memory_next
let check_prop machines fmt machine =
let main_output =
rename_machine_list machine.mname.node_id machine.mstep.step_outputs
in
let main_memory_next =
- (rename_next_list (full_memory_vars machines machine)) @ main_output
+ rename_next_list (full_memory_vars machines machine) @ main_output
in
fprintf fmt "; Property def@.";
fprintf fmt "(declare-rel ERR ())@.";
fprintf fmt "@[<v 2>(rule (=> @ (and @[<v 0>(not %a)@ (MAIN %a)@])@ ERR))@."
- (pp_conj (pp_horn_var machine)) main_output
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) main_memory_next
- ;
- if !Options.horn_query then fprintf fmt "(query ERR)@."
-
+ (pp_conj (pp_horn_var machine))
+ main_output
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ main_memory_next;
+ if !Options.horn_query then fprintf fmt "(query ERR)@."
let cex_computation machines fmt node machine =
fprintf fmt "; CounterExample computation for node %s@.@." node;
- (* We print the types of the cex node "memory tree" TODO: add the output *)
+ (* We print the types of the cex node "memory tree" TODO: add the output *)
let cex_input =
rename_machine_list machine.mname.node_id machine.mstep.step_inputs
in
let cex_input_dummy =
- rename_machine_list ("dummy" ^ machine.mname.node_id) machine.mstep.step_inputs
+ rename_machine_list
+ ("dummy" ^ machine.mname.node_id)
+ machine.mstep.step_inputs
in
let cex_output =
rename_machine_list machine.mname.node_id machine.mstep.step_outputs
in
let cex_output_dummy =
- rename_machine_list ("dummy" ^ machine.mname.node_id) machine.mstep.step_outputs
+ rename_machine_list
+ ("dummy" ^ machine.mname.node_id)
+ machine.mstep.step_outputs
in
let cex_memory_next =
- cex_input @ (rename_next_list (full_memory_vars machines machine)) @ cex_output
+ cex_input
+ @ rename_next_list (full_memory_vars machines machine)
+ @ cex_output
in
let cex_memory_current =
- cex_input_dummy @ (rename_current_list (full_memory_vars machines machine)) @ cex_output_dummy
+ cex_input_dummy
+ @ rename_current_list (full_memory_vars machines machine)
+ @ cex_output_dummy
in
- (* Special case when the cex node is stateless *)
+ (* Special case when the cex node is stateless *)
let reset_name, step_name =
if Machine_code_common.is_stateless machine then
pp_machine_stateless_name, pp_machine_stateless_name
- else
- pp_machine_reset_name, pp_machine_step_name
+ else pp_machine_reset_name, pp_machine_step_name
in
fprintf fmt "(declare-rel CEX (Int %a))@.@."
@@ -156,44 +165,54 @@ let cex_computation machines fmt node machine =
fprintf fmt "(rule INIT_STATE_CEX)@.";
fprintf fmt "@[<v 2>(rule (=> @ (and @[<v 0>";
fprintf fmt "INIT_STATE_CEX@ ";
- fprintf fmt "(@[<v 0>%a %a@])@ "
- reset_name node
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) (reset_vars machines machine);
- fprintf fmt "(@[<v 0>%a %a@])"
- step_name node
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) (step_vars_m_x machines machine);
-
+ fprintf fmt "(@[<v 0>%a %a@])@ " reset_name node
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ (reset_vars machines machine);
+ fprintf fmt "(@[<v 0>%a %a@])" step_name node
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ (step_vars_m_x machines machine);
+
fprintf fmt "@]@ )@ ";
fprintf fmt "(CEX 0 %a)@]@.))@.@."
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) cex_memory_next ;
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ cex_memory_next;
fprintf fmt "; Inductive def@.";
- (* Declare dummy inputs. Outputs should have been declared previously with collecting sem *)
- (Utils.fprintf_list ~sep:" " (fun fmt v -> fprintf fmt "%a@." pp_decl_var v)) fmt cex_input_dummy;
+ (* Declare dummy inputs. Outputs should have been declared previously with
+ collecting sem *)
+ (Utils.fprintf_list ~sep:" " (fun fmt v -> fprintf fmt "%a@." pp_decl_var v))
+ fmt cex_input_dummy;
fprintf fmt "(declare-var cexcpt Int)@.";
fprintf fmt
- "@[<v 2>(rule (=> @ (and @[<v 0>(CEX cexcpt %a)@ (@[<v 0>%a %a@])@]@ )@ (CEX (+ 1 cexcpt) %a)@]@.))@.@."
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) cex_memory_current
- step_name node
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) (step_vars machines machine)
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) cex_memory_next
+ "@[<v 2>(rule (=> @ (and @[<v 0>(CEX cexcpt %a)@ (@[<v 0>%a %a@])@]@ )@ \
+ (CEX (+ 1 cexcpt) %a)@]@.))@.@."
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ cex_memory_current step_name node
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ (step_vars machines machine)
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ cex_memory_next
let get_cex machines fmt machine =
- let cex_input =
- rename_machine_list machine.mname.node_id machine.mstep.step_inputs
- in
- let cex_output =
- rename_machine_list machine.mname.node_id machine.mstep.step_outputs
- in
+ let cex_input =
+ rename_machine_list machine.mname.node_id machine.mstep.step_inputs
+ in
+ let cex_output =
+ rename_machine_list machine.mname.node_id machine.mstep.step_outputs
+ in
let cex_memory_next =
- cex_input @ (rename_next_list (full_memory_vars machines machine)) @ cex_output
+ cex_input
+ @ rename_next_list (full_memory_vars machines machine)
+ @ cex_output
in
fprintf fmt "; Property def@.";
fprintf fmt "(declare-rel CEXTRACE ())@.";
- fprintf fmt "@[<v 2>(rule (=> @ (and @[<v 0>(not %a)@ (CEX cexcpt %a)@])@ CEXTRACE))@."
- (pp_conj (pp_horn_var machine)) cex_output
- (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) cex_memory_next
- ;
+ fprintf fmt
+ "@[<v 2>(rule (=> @ (and @[<v 0>(not %a)@ (CEX cexcpt %a)@])@ CEXTRACE))@."
+ (pp_conj (pp_horn_var machine))
+ cex_output
+ (Utils.fprintf_list ~sep:" " (pp_horn_var machine))
+ cex_memory_next;
fprintf fmt "(query CEXTRACE)@."
(* Local Variables: *)
diff --git a/src/backends/Horn/horn_backend_common.ml b/src/backends/Horn/horn_backend_common.ml
index d7e1f12603eda04ea964797489a59894781d4780..60efc7c217ddfe0dad41d9308e68c6af09da0ae6 100644
--- a/src/backends/Horn/horn_backend_common.ml
+++ b/src/backends/Horn/horn_backend_common.ml
@@ -17,142 +17,154 @@ open Corelang
let get_machine = Machine_code_common.get_machine
let machine_reset_name id = id ^ "_reset"
-let machine_step_name id = id ^ "_step"
-let machine_stateless_name id = id ^ "_fun"
+
+let machine_step_name id = id ^ "_step"
+
+let machine_stateless_name id = id ^ "_fun"
+
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
+
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
+
let pp_machine_stateless_name fmt id = fprintf fmt "%s_fun" id
let rec pp_type fmt t =
- if Types.is_bool_type t then fprintf fmt "Bool" else
- if Types.is_int_type t then fprintf fmt "Int" else
- if Types.is_real_type t then fprintf fmt "Real" else
- match (Types.repr t).Types.tdesc with
- | Types.Tconst ty -> pp_print_string fmt ty
- | Types.Tclock t -> pp_type fmt t
- | Types.Tarray(_,ty) -> fprintf fmt "(Array Int "; pp_type fmt ty; fprintf fmt ")"
- | Types.Tstatic(_, ty) -> pp_type fmt ty
- | Types.Tarrow _
- | _ -> eprintf "internal error: pp_type %a@."
- Types.print_ty t; assert false
+ if Types.is_bool_type t then fprintf fmt "Bool"
+ else if Types.is_int_type t then fprintf fmt "Int"
+ else if Types.is_real_type t then fprintf fmt "Real"
+ else
+ match (Types.repr t).Types.tdesc with
+ | Types.Tconst ty ->
+ pp_print_string fmt ty
+ | Types.Tclock t ->
+ pp_type fmt t
+ | Types.Tarray (_, ty) ->
+ fprintf fmt "(Array Int ";
+ pp_type fmt ty;
+ fprintf fmt ")"
+ | Types.Tstatic (_, ty) ->
+ pp_type fmt ty
+ | Types.Tarrow _ | _ ->
+ eprintf "internal error: pp_type %a@." Types.print_ty t;
+ assert false
let pp_decl_var fmt id =
- fprintf fmt "(declare-var %s %a)"
- id.var_id
- pp_type id.var_type
-
-(* let pp_var fmt id = pp_print_string fmt id.var_id *)
+ fprintf fmt "(declare-var %s %a)" id.var_id pp_type id.var_type
+(* let pp_var fmt id = pp_print_string fmt id.var_id *)
let pp_conj pp fmt l =
match l with
- [] -> assert false
- | [x] -> pp fmt x
- | _ -> fprintf fmt "(and @[<v 0>%a@]@ )" (Utils.fprintf_list ~sep:"@ " pp) l
-
-
+ | [] ->
+ assert false
+ | [ x ] ->
+ pp fmt x
+ | _ ->
+ fprintf fmt "(and @[<v 0>%a@]@ )" (Utils.fprintf_list ~sep:"@ " pp) l
(********************************************************************************************)
-(* Workaround to prevent the use of declared keywords as node name *)
+(* Workaround to prevent the use of declared keywords as node name *)
(********************************************************************************************)
-let registered_keywords = ["implies"]
+let registered_keywords = [ "implies" ]
-let protect_kwd s =
- if List.mem s registered_keywords then
- "__" ^ s
- else
- s
+let protect_kwd s = if List.mem s registered_keywords then "__" ^ s else s
let node_name n =
let name = node_name n in
protect_kwd name
-
let concat prefix x = if prefix = "" then x else prefix ^ "." ^ x
-let rename f = (fun v -> {v with var_id = f v.var_id } )
+
+let rename f v = { v with var_id = f v.var_id }
+
let rename_machine p = rename (fun n -> concat p n)
+
let rename_machine_list p = List.map (rename_machine p)
-let rename_current = rename (fun n -> n ^ "_c")
+let rename_current = rename (fun n -> n ^ "_c")
+
let rename_current_list = List.map rename_current
-let rename_mid = rename (fun n -> n ^ "_m")
+
+let rename_mid = rename (fun n -> n ^ "_m")
+
let rename_mid_list = List.map rename_mid
+
let rename_next = rename (fun n -> n ^ "_x")
-let rename_next_list = List.map rename_next
+let rename_next_list = List.map rename_next
let local_memory_vars machine =
rename_machine_list machine.mname.node_id machine.mmemory
-
-let instances_memory_vars ?(without_arrow=false) machines machine =
+
+let instances_memory_vars ?(without_arrow = false) machines machine =
let rec aux fst prefix m =
- (
- if not fst then (
- (rename_machine_list (concat prefix m.mname.node_id) m.mmemory)
- )
- else []
- ) @
- List.fold_left (fun accu (id, (n, _)) ->
- let name = node_name n in
- if without_arrow && name = "_arrow" then
- accu
- else
- let machine_n = get_machine machines name in
- ( aux false (concat prefix
- (if fst then id else concat m.mname.node_id id))
- machine_n ) @ accu
- ) [] (m.minstances)
+ (if not fst then
+ rename_machine_list (concat prefix m.mname.node_id) m.mmemory
+ else [])
+ @ List.fold_left
+ (fun accu (id, (n, _)) ->
+ let name = node_name n in
+ if without_arrow && name = "_arrow" then accu
+ else
+ let machine_n = get_machine machines name in
+ aux false
+ (concat prefix (if fst then id else concat m.mname.node_id id))
+ machine_n
+ @ accu)
+ [] m.minstances
in
aux true machine.mname.node_id machine
(* Extract the arrows of a given node/machine *)
let arrow_vars machines machine : Lustre_types.var_decl list =
let rec aux fst prefix m =
- List.fold_left (fun accu (id, (n, _)) ->
- let name = node_name n in
- if name = "_arrow" then
- let arrow_machine = Machine_code_common.arrow_machine in
- (rename_machine_list
- (concat prefix (concat (if fst then id else concat m.mname.node_id id) "_arrow"))
- arrow_machine.mmemory
- ) @ accu
- else
- let machine_n = get_machine machines name in
- ( aux false (concat prefix
- (if fst then id else concat m.mname.node_id id))
- machine_n ) @ accu
- ) [] (m.minstances)
+ List.fold_left
+ (fun accu (id, (n, _)) ->
+ let name = node_name n in
+ if name = "_arrow" then
+ let arrow_machine = Machine_code_common.arrow_machine in
+ rename_machine_list
+ (concat prefix
+ (concat (if fst then id else concat m.mname.node_id id) "_arrow"))
+ arrow_machine.mmemory
+ @ accu
+ else
+ let machine_n = get_machine machines name in
+ aux false
+ (concat prefix (if fst then id else concat m.mname.node_id id))
+ machine_n
+ @ accu)
+ [] m.minstances
in
aux true machine.mname.node_id machine
-let full_memory_vars ?(without_arrow=false) machines machine =
- (local_memory_vars machine)
- @ (instances_memory_vars ~without_arrow machines machine)
+let full_memory_vars ?(without_arrow = false) machines machine =
+ local_memory_vars machine
+ @ instances_memory_vars ~without_arrow machines machine
let inout_vars m =
- (rename_machine_list m.mname.node_id m.mstep.step_inputs)
- @ (rename_machine_list m.mname.node_id m.mstep.step_outputs)
+ rename_machine_list m.mname.node_id m.mstep.step_inputs
+ @ rename_machine_list m.mname.node_id m.mstep.step_outputs
let step_vars machines m =
- (inout_vars m)
- @ (rename_current_list (full_memory_vars machines m))
- @ (rename_next_list (full_memory_vars machines m))
+ inout_vars m
+ @ rename_current_list (full_memory_vars machines m)
+ @ rename_next_list (full_memory_vars machines m)
let step_vars_m_x machines m =
- (inout_vars m)
- @ (rename_mid_list (full_memory_vars machines m))
- @ (rename_next_list (full_memory_vars machines m))
+ inout_vars m
+ @ rename_mid_list (full_memory_vars machines m)
+ @ rename_next_list (full_memory_vars machines m)
let reset_vars machines m =
- (rename_current_list (full_memory_vars machines m))
- @ (rename_mid_list (full_memory_vars machines m))
+ rename_current_list (full_memory_vars machines m)
+ @ rename_mid_list (full_memory_vars machines m)
let step_vars_c_m_x machines m =
- (inout_vars m)
- @ (rename_current_list (full_memory_vars machines m))
- @ (rename_mid_list (full_memory_vars machines m))
- @ (rename_next_list (full_memory_vars machines m))
-
+ inout_vars m
+ @ rename_current_list (full_memory_vars machines m)
+ @ rename_mid_list (full_memory_vars machines m)
+ @ rename_next_list (full_memory_vars machines m)
(* Local Variables: *)
(* compile-command:"make -C ../.." *)
diff --git a/src/backends/Horn/horn_backend_printers.ml b/src/backends/Horn/horn_backend_printers.ml
index de903a39faa196e179990851676f64f9d7616bad..1e06099f44de5bf842ff471ab1f9eacf52cf2861 100644
--- a/src/backends/Horn/horn_backend_printers.ml
+++ b/src/backends/Horn/horn_backend_printers.ml
@@ -12,712 +12,726 @@
(* The compilation presented here was first defined in Garoche, Gurfinkel,
Kahsai, HCSV'14.
- This is a modified version that handle reset
-*)
+ This is a modified version that handle reset *)
open Format
open Lustre_types
open Machine_code_types
open Corelang
open Machine_code_common
-
open Horn_backend_common
-
+
(********************************************************************************************)
-(* Instruction Printing functions *)
+(* Instruction Printing functions *)
(********************************************************************************************)
let pp_horn_var _ fmt id =
- (*if Types.is_array_type id.var_type
- then
- assert false (* no arrays in Horn output *)
- else*)
- fprintf fmt "%s" id.var_id
+ (*if Types.is_array_type id.var_type then assert false (* no arrays in Horn
+ output *) else*)
+ fprintf fmt "%s" id.var_id
(* Used to print boolean constants *)
let pp_horn_tag fmt t =
- pp_print_string fmt (if t = tag_true then "true" else if t = tag_false then "false" else t)
-
+ pp_print_string fmt
+ (if t = tag_true then "true" else if t = tag_false then "false" else t)
+
(* Prints a constant value *)
let pp_horn_const fmt c =
match c with
- | Const_int i -> pp_print_int fmt i
- | Const_real r -> Real.pp fmt r
- | Const_tag t -> pp_horn_tag fmt t
- | _ -> assert false
+ | Const_int i ->
+ pp_print_int fmt i
+ | Const_real r ->
+ Real.pp fmt r
+ | Const_tag t ->
+ pp_horn_tag fmt t
+ | _ ->
+ assert false
(* Default value for each type, used when building arrays. Eg integer array
[2;7] is defined as (store (store (0) 1 7) 0 2) where 0 is this default value
- for the type integer (arrays).
-*)
+ for the type integer (arrays). *)
let rec pp_default_val fmt t =
let t = Types.dynamic_type t in
- if Types.is_bool_type t then fprintf fmt "true" else
- if Types.is_int_type t then fprintf fmt "0" else
- if Types.is_real_type t then fprintf fmt "0" else
- match (Types.dynamic_type t).Types.tdesc with
- | Types.Tarray _ -> (* TODO PL: this strange code has to be (heavily) checked *)
- let valt = Types.array_element_type t in
- fprintf fmt "((as const (Array Int %a)) %a)"
- pp_type valt
- pp_default_val valt
- | Types.Tstruct _ -> assert false
- | Types.Ttuple _ -> assert false
- |_ -> assert false
+ if Types.is_bool_type t then fprintf fmt "true"
+ else if Types.is_int_type t then fprintf fmt "0"
+ else if Types.is_real_type t then fprintf fmt "0"
+ else
+ match (Types.dynamic_type t).Types.tdesc with
+ | Types.Tarray _ ->
+ (* TODO PL: this strange code has to be (heavily) checked *)
+ let valt = Types.array_element_type t in
+ fprintf fmt "((as const (Array Int %a)) %a)" pp_type valt pp_default_val
+ valt
+ | Types.Tstruct _ ->
+ assert false
+ | Types.Ttuple _ ->
+ assert false
+ | _ ->
+ assert false
let pp_mod pp_val v1 v2 fmt =
- if Types.is_int_type v1.value_type && not !Options.integer_div_euclidean then
- (* C semantics: converting it from Euclidean operators
- (a mod_M b) - ((a mod_M b > 0 && a < 0) ? abs(b) : 0)
- *)
- Format.fprintf fmt "(- (mod %a %a) (ite (and (> (mod %a %a) 0) (< %a 0)) (abs %a) 0))"
- pp_val v1 pp_val v2
- pp_val v1 pp_val v2
- pp_val v1
- pp_val v2
- else
- Format.fprintf fmt "(mod %a %a)" pp_val v1 pp_val v2
+ if Types.is_int_type v1.value_type && not !Options.integer_div_euclidean then
+ (* C semantics: converting it from Euclidean operators (a mod_M b) - ((a
+ mod_M b > 0 && a < 0) ? abs(b) : 0) *)
+ Format.fprintf fmt
+ "(- (mod %a %a) (ite (and (> (mod %a %a) 0) (< %a 0)) (abs %a) 0))" pp_val
+ v1 pp_val v2 pp_val v1 pp_val v2 pp_val v1 pp_val v2
+ else Format.fprintf fmt "(mod %a %a)" pp_val v1 pp_val v2
let pp_div pp_val v1 v2 fmt =
- if Types.is_int_type v1.value_type && not !Options.integer_div_euclidean then
- (* C semantics: converting it from Euclidean operators
- (a - (a mod_C b)) div_M b
- *)
- Format.fprintf fmt "(div (- %a %t) %a)"
- pp_val v1
- (pp_mod pp_val v1 v2)
+ if Types.is_int_type v1.value_type && not !Options.integer_div_euclidean then
+ (* C semantics: converting it from Euclidean operators (a - (a mod_C b))
+ div_M b *)
+ Format.fprintf fmt "(div (- %a %t) %a)" pp_val v1 (pp_mod pp_val v1 v2)
pp_val v2
- else
- Format.fprintf fmt "(div %a %a)" pp_val v1 pp_val v2
-
+ else Format.fprintf fmt "(div %a %a)" pp_val v1 pp_val v2
let pp_basic_lib_fun i pp_val fmt vl =
match i, vl with
- | "ite", [v1; v2; v3] -> Format.fprintf fmt "(@[<hov 2>ite %a@ %a@ %a@])" pp_val v1 pp_val v2 pp_val v3
- | "uminus", [v] -> Format.fprintf fmt "(- %a)" pp_val v
- | "not", [v] -> Format.fprintf fmt "(not %a)" pp_val v
- | "=", [v1; v2] -> Format.fprintf fmt "(= %a %a)" pp_val v1 pp_val v2
- | "&&", [v1; v2] -> Format.fprintf fmt "(and %a %a)" pp_val v1 pp_val v2
- | "||", [v1; v2] -> Format.fprintf fmt "(or %a %a)" pp_val v1 pp_val v2
- | "impl", [v1; v2] -> Format.fprintf fmt "(=> %a %a)" pp_val v1 pp_val v2
- | "equi", [v1; v2] -> Format.fprintf fmt "(%a = %a)" pp_val v1 pp_val v2
- | "xor", [v1; v2] -> Format.fprintf fmt "(%a xor %a)" pp_val v1 pp_val v2
- | "!=", [v1; v2] -> Format.fprintf fmt "(not (= %a %a))" pp_val v1 pp_val v2
- | "mod", [v1; v2] -> pp_mod pp_val v1 v2 fmt
- | "/", [v1; v2] -> pp_div pp_val v1 v2 fmt
- | _, [v1; v2] -> Format.fprintf fmt "(%s %a %a)" i pp_val v1 pp_val v2
- | _ -> (Format.eprintf "internal error: Basic_library.pp_horn %s@." i; assert false)
-(* | "mod", [v1; v2] -> Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2
-
-*)
-
-
-(* Prints a value expression [v], with internal function calls only.
- [pp_var] is a printer for variables (typically [pp_c_var_read]),
- but an offset suffix may be added for array variables
-*)
-let rec pp_horn_val ?(is_lhs=false) m self pp_var fmt v =
- match v.value_desc with
- | Cst c -> pp_horn_const fmt c
+ | "ite", [ v1; v2; v3 ] ->
+ Format.fprintf fmt "(@[<hov 2>ite %a@ %a@ %a@])" pp_val v1 pp_val v2 pp_val
+ v3
+ | "uminus", [ v ] ->
+ Format.fprintf fmt "(- %a)" pp_val v
+ | "not", [ v ] ->
+ Format.fprintf fmt "(not %a)" pp_val v
+ | "=", [ v1; v2 ] ->
+ Format.fprintf fmt "(= %a %a)" pp_val v1 pp_val v2
+ | "&&", [ v1; v2 ] ->
+ Format.fprintf fmt "(and %a %a)" pp_val v1 pp_val v2
+ | "||", [ v1; v2 ] ->
+ Format.fprintf fmt "(or %a %a)" pp_val v1 pp_val v2
+ | "impl", [ v1; v2 ] ->
+ Format.fprintf fmt "(=> %a %a)" pp_val v1 pp_val v2
+ | "equi", [ v1; v2 ] ->
+ Format.fprintf fmt "(%a = %a)" pp_val v1 pp_val v2
+ | "xor", [ v1; v2 ] ->
+ Format.fprintf fmt "(%a xor %a)" pp_val v1 pp_val v2
+ | "!=", [ v1; v2 ] ->
+ Format.fprintf fmt "(not (= %a %a))" pp_val v1 pp_val v2
+ | "mod", [ v1; v2 ] ->
+ pp_mod pp_val v1 v2 fmt
+ | "/", [ v1; v2 ] ->
+ pp_div pp_val v1 v2 fmt
+ | _, [ v1; v2 ] ->
+ Format.fprintf fmt "(%s %a %a)" i pp_val v1 pp_val v2
+ | _ ->
+ Format.eprintf "internal error: Basic_library.pp_horn %s@." i;
+ assert false
+(* | "mod", [v1; v2] -> Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 *)
+(* Prints a value expression [v], with internal function calls only. [pp_var] is
+ a printer for variables (typically [pp_c_var_read]), but an offset suffix may
+ be added for array variables *)
+let rec pp_horn_val ?(is_lhs = false) m self pp_var fmt v =
+ match v.value_desc with
+ | Cst c ->
+ pp_horn_const fmt c
(* Code specific for arrays *)
- | Array il ->
- (* An array definition:
- (store (
- ...
- (store (
- store (
- default_val
- )
- idx_n val_n
- )
- idx_n-1 val_n-1)
- ...
- idx_1 val_1
- ) *)
- let rec print fmt (tab, x) =
- match tab with
- | [] -> pp_default_val fmt v.value_type(* (get_type v) *)
- | h::t ->
- fprintf fmt "(store %a %i %a)"
- print (t, (x+1))
- x
- (pp_horn_val ~is_lhs:is_lhs m self pp_var) h
- in
- print fmt (il, 0)
-
- | Access(tab,index) ->
- fprintf fmt "(select %a %a)"
- (pp_horn_val ~is_lhs:is_lhs m self pp_var) tab
- (pp_horn_val ~is_lhs:is_lhs m self pp_var) index
-
+ | Array il ->
+ (* An array definition: (store ( ... (store ( store ( default_val ) idx_n
+ val_n ) idx_n-1 val_n-1) ... idx_1 val_1 ) *)
+ let rec print fmt (tab, x) =
+ match tab with
+ | [] ->
+ pp_default_val fmt v.value_type (* (get_type v) *)
+ | h :: t ->
+ fprintf fmt "(store %a %i %a)" print
+ (t, x + 1)
+ x
+ (pp_horn_val ~is_lhs m self pp_var)
+ h
+ in
+ print fmt (il, 0)
+ | Access (tab, index) ->
+ fprintf fmt "(select %a %a)"
+ (pp_horn_val ~is_lhs m self pp_var)
+ tab
+ (pp_horn_val ~is_lhs m self pp_var)
+ index
(* Code specific for arrays *)
-
- | Power _ -> assert false
- | Var v ->
- if is_memory m v then
- if Types.is_array_type v.var_type
- then assert false
- else pp_var fmt (rename_machine self ((if is_lhs then rename_next else rename_current) (* self *) v))
- else
- pp_var fmt (rename_machine self v)
-
- | Fun (n, vl) -> fprintf fmt "%a" (pp_basic_lib_fun n (pp_horn_val m self pp_var)) vl
+ | Power _ ->
+ assert false
+ | Var v ->
+ if is_memory m v then
+ if Types.is_array_type v.var_type then assert false
+ else
+ pp_var fmt
+ (rename_machine self
+ ((if is_lhs then rename_next else rename_current (* self *)) v))
+ else pp_var fmt (rename_machine self v)
+ | Fun (n, vl) ->
+ fprintf fmt "%a" (pp_basic_lib_fun n (pp_horn_val m self pp_var)) vl
| ResetFlag ->
(* TODO: handle reset flag *)
assert false
(* Prints a [value] indexed by the suffix list [loop_vars] *)
let rec pp_value_suffix m self pp_value fmt value =
- match value.value_desc with
- | Fun (n, vl) ->
+ match value.value_desc with
+ | Fun (n, vl) ->
pp_basic_lib_fun n (pp_value_suffix m self pp_value) fmt vl
- | _ ->
- pp_horn_val m self pp_value fmt value
-
-(* type_directed assignment: array vs. statically sized type
- - [var_type]: type of variable to be assigned
- - [var_name]: name of variable to be assigned
- - [value]: assigned value
- - [pp_var]: printer for variables
-*)
+ | _ ->
+ pp_horn_val m self pp_value fmt value
+
+(* type_directed assignment: array vs. statically sized type - [var_type]: type
+ of variable to be assigned - [var_name]: name of variable to be assigned -
+ [value]: assigned value - [pp_var]: printer for variables *)
let pp_assign m pp_var fmt var_name value =
let self = m.mname.node_id in
- fprintf fmt "(= %a %a)"
- (pp_horn_val ~is_lhs:true m self pp_var) var_name
- (pp_value_suffix m self pp_var) value
-
+ fprintf fmt "(= %a %a)"
+ (pp_horn_val ~is_lhs:true m self pp_var)
+ var_name
+ (pp_value_suffix m self pp_var)
+ value
(* In case of no reset call, we define mid_mem = current_mem *)
let pp_no_reset machines m fmt i =
- let (n,_) = List.assoc i m.minstances in
- let target_machine = List.find (fun m -> m.mname.node_id = (node_name n)) machines in
+ let n, _ = List.assoc i m.minstances in
+ let target_machine =
+ List.find (fun m -> m.mname.node_id = node_name n) machines
+ in
- let m_list =
- rename_machine_list
- (concat m.mname.node_id i)
+ let m_list =
+ rename_machine_list (concat m.mname.node_id i)
(rename_mid_list (full_memory_vars machines target_machine))
in
let c_list =
- rename_machine_list
- (concat m.mname.node_id i)
+ rename_machine_list (concat m.mname.node_id i)
(rename_current_list (full_memory_vars machines target_machine))
in
match c_list, m_list with
- | [chd], [mhd] ->
- fprintf fmt "(= %a %a)"
- (pp_horn_var m) mhd
- (pp_horn_var m) chd
-
- | _ -> (
+ | [ chd ], [ mhd ] ->
+ fprintf fmt "(= %a %a)" (pp_horn_var m) mhd (pp_horn_var m) chd
+ | _ ->
fprintf fmt "@[<v 0>(and @[<v 0>";
- List.iter2 (fun mhd chd ->
- fprintf fmt "(= %a %a)@ "
- (pp_horn_var m) mhd
- (pp_horn_var m) chd
- )
- m_list
- c_list ;
+ List.iter2
+ (fun mhd chd ->
+ fprintf fmt "(= %a %a)@ " (pp_horn_var m) mhd (pp_horn_var m) chd)
+ m_list c_list;
fprintf fmt ")@]@ @]"
- )
let pp_instance_reset machines m fmt i =
- let (n,_) = List.assoc i m.minstances in
- let target_machine = List.find (fun m -> m.mname.node_id = (node_name n)) machines in
-
- fprintf fmt "(%a @[<v 0>%a)@]"
- pp_machine_reset_name (node_name n)
- (Utils.fprintf_list ~sep:"@ " (pp_horn_var m))
- (
- (rename_machine_list
- (concat m.mname.node_id i)
- (rename_current_list (full_memory_vars machines target_machine))
- )
- @
- (rename_machine_list
- (concat m.mname.node_id i)
- (rename_mid_list (full_memory_vars machines target_machine))
- )
- )
+ let n, _ = List.assoc i m.minstances in
+ let target_machine =
+ List.find (fun m -> m.mname.node_id = node_name n) machines
+ in
+
+ fprintf fmt "(%a @[<v 0>%a)@]" pp_machine_reset_name (node_name n)
+ (Utils.fprintf_list ~sep:"@ " (pp_horn_var m))
+ (rename_machine_list (concat m.mname.node_id i)
+ (rename_current_list (full_memory_vars machines target_machine))
+ @ rename_machine_list (concat m.mname.node_id i)
+ (rename_mid_list (full_memory_vars machines target_machine)))
let pp_instance_call machines reset_instances m fmt i inputs outputs =
let self = m.mname.node_id in
- try (* stateful node instance *)
- begin
- let (n,_) = List.assoc i m.minstances in
- let target_machine = List.find (fun m -> m.mname.node_id = node_name n) machines in
- (* Checking whether this specific instances has been reset yet *)
- if not (List.mem i reset_instances) then
- (* If not, declare mem_m = mem_c *)
- pp_no_reset machines m fmt i;
-
- let mems = full_memory_vars machines target_machine in
- let rename_mems f = rename_machine_list (concat m.mname.node_id i) (f mems) in
- let mid_mems = rename_mems rename_mid_list in
- let next_mems = rename_mems rename_next_list in
-
- match node_name n, inputs, outputs, mid_mems, next_mems with
- | "_arrow", [i1; i2], [o], [mem_m], [mem_x] -> begin
- fprintf fmt "@[<v 5>(and ";
- fprintf fmt "(= %a (ite %a %a %a))"
- (pp_horn_val ~is_lhs:true m self (pp_horn_var m)) (mk_val (Var o) o.var_type) (* output var *)
- (pp_horn_var m) mem_m
- (pp_horn_val m self (pp_horn_var m)) i1
- (pp_horn_val m self (pp_horn_var m)) i2
- ;
- fprintf fmt "@ ";
- fprintf fmt "(= %a false)" (pp_horn_var m) mem_x;
- fprintf fmt ")@]"
- end
-
- | _ -> begin
- fprintf fmt "(%a @[<v 0>%a%t%a%t%a)@]"
- pp_machine_step_name (node_name n)
- (Utils.fprintf_list ~sep:"@ " (pp_horn_val m self (pp_horn_var m))) inputs
- (Utils.pp_final_char_if_non_empty "@ " inputs)
- (Utils.fprintf_list ~sep:"@ " (pp_horn_val m self (pp_horn_var m)))
- (List.map (fun v -> mk_val (Var v) v.var_type) outputs)
- (Utils.pp_final_char_if_non_empty "@ " outputs)
- (Utils.fprintf_list ~sep:"@ " (pp_horn_var m)) (mid_mems@next_mems)
-
- end
- end
- with Not_found -> ( (* stateless node instance *)
- let (n,_) = List.assoc i m.mcalls in
- fprintf fmt "(%a @[<v 0>%a%t%a)@]"
- pp_machine_stateless_name (node_name n)
+ try
+ (* stateful node instance *)
+ let n, _ = List.assoc i m.minstances in
+ let target_machine =
+ List.find (fun m -> m.mname.node_id = node_name n) machines
+ in
+ (* Checking whether this specific instances has been reset yet *)
+ if not (List.mem i reset_instances) then
+ (* If not, declare mem_m = mem_c *)
+ pp_no_reset machines m fmt i;
+
+ let mems = full_memory_vars machines target_machine in
+ let rename_mems f =
+ rename_machine_list (concat m.mname.node_id i) (f mems)
+ in
+ let mid_mems = rename_mems rename_mid_list in
+ let next_mems = rename_mems rename_next_list in
+
+ match node_name n, inputs, outputs, mid_mems, next_mems with
+ | "_arrow", [ i1; i2 ], [ o ], [ mem_m ], [ mem_x ] ->
+ fprintf fmt "@[<v 5>(and ";
+ fprintf fmt "(= %a (ite %a %a %a))"
+ (pp_horn_val ~is_lhs:true m self (pp_horn_var m))
+ (mk_val (Var o) o.var_type)
+ (* output var *)
+ (pp_horn_var m)
+ mem_m
+ (pp_horn_val m self (pp_horn_var m))
+ i1
+ (pp_horn_val m self (pp_horn_var m))
+ i2;
+ fprintf fmt "@ ";
+ fprintf fmt "(= %a false)" (pp_horn_var m) mem_x;
+ fprintf fmt ")@]"
+ | _ ->
+ fprintf fmt "(%a @[<v 0>%a%t%a%t%a)@]" pp_machine_step_name (node_name n)
+ (Utils.fprintf_list ~sep:"@ " (pp_horn_val m self (pp_horn_var m)))
+ inputs
+ (Utils.pp_final_char_if_non_empty "@ " inputs)
+ (Utils.fprintf_list ~sep:"@ " (pp_horn_val m self (pp_horn_var m)))
+ (List.map (fun v -> mk_val (Var v) v.var_type) outputs)
+ (Utils.pp_final_char_if_non_empty "@ " outputs)
+ (Utils.fprintf_list ~sep:"@ " (pp_horn_var m))
+ (mid_mems @ next_mems)
+ with Not_found ->
+ (* stateless node instance *)
+ let n, _ = List.assoc i m.mcalls in
+ fprintf fmt "(%a @[<v 0>%a%t%a)@]" pp_machine_stateless_name (node_name n)
(Utils.fprintf_list ~sep:"@ " (pp_horn_val m self (pp_horn_var m)))
inputs
(Utils.pp_final_char_if_non_empty "@ " inputs)
(Utils.fprintf_list ~sep:"@ " (pp_horn_val m self (pp_horn_var m)))
(List.map (fun v -> mk_val (Var v) v.var_type) outputs)
- )
-
-
+
(* Print the instruction and update the set of reset instances *)
-let rec pp_machine_instr machines reset_instances (m: machine_t) fmt instr : ident list =
+let rec pp_machine_instr machines reset_instances (m : machine_t) fmt instr :
+ ident list =
match get_instr_desc instr with
- | MSpec _ | MComment _ -> reset_instances
+ | MSpec _ | MComment _ ->
+ reset_instances
(* TODO: handle reset flag *)
- | MResetAssign _ -> reset_instances
+ | MResetAssign _ ->
+ reset_instances
(* TODO: handle clear_reset *)
- | MClearReset -> reset_instances
- | MNoReset i -> (* we assign middle_mem with mem_m. And declare i as reset *)
+ | MClearReset ->
+ reset_instances
+ | MNoReset i ->
+ (* we assign middle_mem with mem_m. And declare i as reset *)
pp_no_reset machines m fmt i;
- i::reset_instances
- | MSetReset i -> (* we assign middle_mem with reset: reset(mem_m) *)
+ i :: reset_instances
+ | MSetReset i ->
+ (* we assign middle_mem with reset: reset(mem_m) *)
pp_instance_reset machines m fmt i;
- i::reset_instances
- | MLocalAssign (i,v) ->
- pp_assign
- m (pp_horn_var m) fmt
- (mk_val (Var i) i.var_type) v;
+ i :: reset_instances
+ | MLocalAssign (i, v) ->
+ pp_assign m (pp_horn_var m) fmt (mk_val (Var i) i.var_type) v;
reset_instances
- | MStateAssign (i,v) ->
- pp_assign
- m (pp_horn_var m) fmt
- (mk_val (Var i) i.var_type) v;
+ | MStateAssign (i, v) ->
+ pp_assign m (pp_horn_var m) fmt (mk_val (Var i) i.var_type) v;
reset_instances
- | MStep ([_], i, vl) when Basic_library.is_internal_fun i (List.map (fun v -> v.value_type) vl) ->
+ | MStep ([ _ ], i, vl)
+ when Basic_library.is_internal_fun i (List.map (fun v -> v.value_type) vl)
+ ->
assert false (* This should not happen anymore *)
| MStep (il, i, vl) ->
- (* if reset instance, just print the call over mem_m , otherwise declare mem_m =
- mem_c and print the call to mem_m *)
+ (* if reset instance, just print the call over mem_m , otherwise declare
+ mem_m = mem_c and print the call to mem_m *)
pp_instance_call machines reset_instances m fmt i vl il;
- reset_instances (* Since this instance call will only happen once, we
- don't have to update reset_instances *)
-
- | MBranch (g,hl) -> (* (g = tag1 => expr1) and (g = tag2 => expr2) ...
- should not be produced yet. Later, we will have to
- compare the reset_instances of each branch and
- introduced the mem_m = mem_c for branches to do not
- address it while other did. Am I clear ? *)
+ reset_instances
+ (* Since this instance call will only happen once, we don't have to update
+ reset_instances *)
+ | MBranch (g, hl) ->
+ (* (g = tag1 => expr1) and (g = tag2 => expr2) ... should not be produced
+ yet. Later, we will have to compare the reset_instances of each branch
+ and introduced the mem_m = mem_c for branches to do not address it while
+ other did. Am I clear ? *)
(* For each branch we obtain the logical encoding, and the information
whether a sub node has been reset or not. If a node has been reset in one
- of the branch, then all others have to have the mem_m = mem_c
- statement. *)
+ of the branch, then all others have to have the mem_m = mem_c statement. *)
let self = m.mname.node_id in
let pp_branch fmt (tag, instrs) =
- fprintf fmt
- "@[<v 3>(or (not (= %a %a))@ "
- (*"@[<v 3>(=> (= %a %s)@ "*) (* Issues with some versions of Z3. It
- seems that => within Horn predicate
- may cause trouble. I have hard time
- producing a MWE, so I'll just keep the
- fix here as (not a) or b *)
- (pp_horn_val m self (pp_horn_var m)) g
- pp_horn_tag tag;
- let _ (* rs *) = pp_machine_instrs machines reset_instances m fmt instrs in
+ fprintf fmt "@[<v 3>(or (not (= %a %a))@ "
+ (*"@[<v 3>(=> (= %a %s)@ "*)
+ (* Issues with some versions of Z3. It seems that => within Horn
+ predicate may cause trouble. I have hard time producing a MWE, so
+ I'll just keep the fix here as (not a) or b *)
+ (pp_horn_val m self (pp_horn_var m))
+ g pp_horn_tag tag;
+ let _ (* rs *) =
+ pp_machine_instrs machines reset_instances m fmt instrs
+ in
fprintf fmt "@])";
- () (* rs *)
+ ()
+ (* rs *)
in
pp_conj pp_branch fmt hl;
- reset_instances
+ reset_instances
-and pp_machine_instrs machines reset_instances m fmt instrs =
+and pp_machine_instrs machines reset_instances m fmt instrs =
let ppi rs fmt i = pp_machine_instr machines rs m fmt i in
match instrs with
- | [x] -> ppi reset_instances fmt x
- | _::_ ->
+ | [ x ] ->
+ ppi reset_instances fmt x
+ | _ :: _ ->
fprintf fmt "(and @[<v 0>";
- let rs = List.fold_left (fun rs i ->
- let rs = ppi rs fmt i in
- fprintf fmt "@ ";
- rs
- )
- reset_instances instrs
+ let rs =
+ List.fold_left
+ (fun rs i ->
+ let rs = ppi rs fmt i in
+ fprintf fmt "@ ";
+ rs)
+ reset_instances instrs
in
fprintf fmt "@])";
rs
-
- | [] -> fprintf fmt "true"; reset_instances
+ | [] ->
+ fprintf fmt "true";
+ reset_instances
let pp_machine_reset machines fmt m =
let locals = local_memory_vars m in
fprintf fmt "@[<v 5>(and @ ";
(* print "x_m = x_c" for each local memory *)
- (Utils.fprintf_list ~sep:"@ " (fun fmt v ->
- fprintf fmt "(= %a %a)"
- (pp_horn_var m) (rename_mid v)
- (pp_horn_var m) (rename_current v)
- )) fmt locals;
+ (Utils.fprintf_list ~sep:"@ " (fun fmt v ->
+ fprintf fmt "(= %a %a)" (pp_horn_var m) (rename_mid v) (pp_horn_var m)
+ (rename_current v)))
+ fmt locals;
fprintf fmt "@ ";
- (* print "child_reset ( associated vars _ {c,m} )" for each subnode.
- Special treatment for _arrow: _first = true
- *)
+ (* print "child_reset ( associated vars _ {c,m} )" for each subnode. Special
+ treatment for _arrow: _first = true *)
(Utils.fprintf_list ~sep:"@ " (fun fmt (id, (n, _)) ->
- let name = node_name n in
- if name = "_arrow" then (
- fprintf fmt "(= %s._arrow._first_m true)"
- (concat m.mname.node_id id)
- ) else (
- let machine_n = get_machine machines name in
- fprintf fmt "(%s_reset @[<hov 0>%a@])"
- name
- (Utils.fprintf_list ~sep:"@ " (pp_horn_var m))
- (rename_machine_list (concat m.mname.node_id id) (reset_vars machines machine_n))
- )
- )) fmt m.minstances;
+ let name = node_name n in
+ if name = "_arrow" then
+ fprintf fmt "(= %s._arrow._first_m true)" (concat m.mname.node_id id)
+ else
+ let machine_n = get_machine machines name in
+ fprintf fmt "(%s_reset @[<hov 0>%a@])" name
+ (Utils.fprintf_list ~sep:"@ " (pp_horn_var m))
+ (rename_machine_list
+ (concat m.mname.node_id id)
+ (reset_vars machines machine_n))))
+ fmt m.minstances;
fprintf fmt "@]@ )"
-
-
(**************************************************************)
-
-(* Print the machine m:
- two functions: m_init and m_step
- - m_init is a predicate over m memories
- - m_step is a predicate over old_memories, inputs, new_memories, outputs
- We first declare all variables then the two /rules/.
-*)
+(* Print the machine m: two functions: m_init and m_step - m_init is a predicate
+ over m memories - m_step is a predicate over old_memories, inputs,
+ new_memories, outputs We first declare all variables then the two /rules/. *)
let print_machine machines fmt m =
- if m.mname.node_id = Arrow.arrow_id then
- (* We don't print arrow function *)
+ if m.mname.node_id = Arrow.arrow_id then (* We don't print arrow function *)
()
- else
- begin
- fprintf fmt "; %s@." m.mname.node_id;
-
- (* Printing variables *)
- Utils.fprintf_list ~sep:"@." pp_decl_var fmt
- (
- (inout_vars m)@
- (rename_current_list (full_memory_vars machines m)) @
- (rename_mid_list (full_memory_vars machines m)) @
- (rename_next_list (full_memory_vars machines m)) @
- (rename_machine_list m.mname.node_id m.mstep.step_locals)
- );
- pp_print_newline fmt ();
+ else (
+ fprintf fmt "; %s@." m.mname.node_id;
+
+ (* Printing variables *)
+ Utils.fprintf_list ~sep:"@." pp_decl_var fmt
+ (inout_vars m
+ @ rename_current_list (full_memory_vars machines m)
+ @ rename_mid_list (full_memory_vars machines m)
+ @ rename_next_list (full_memory_vars machines m)
+ @ rename_machine_list m.mname.node_id m.mstep.step_locals);
+ pp_print_newline fmt ();
+
+ if is_stateless m then (
+ (* Declaring single predicate *)
+ fprintf fmt "(declare-rel %a (%a))@." pp_machine_stateless_name
+ m.mname.node_id
+ (Utils.fprintf_list ~sep:" " pp_type)
+ (List.map (fun v -> v.var_type) (inout_vars m));
+
+ match m.mstep.step_asserts with
+ | [] ->
+ (* Rule for single predicate *)
+ fprintf fmt "; Stateless step rule @.";
+ fprintf fmt "@[<v 2>(rule (=> @ ";
+ ignore
+ (pp_machine_instrs machines []
+ (* No reset info for stateless nodes *) m fmt m.mstep.step_instrs);
+ fprintf fmt "@ (%a @[<v 0>%a)@]@]@.))@.@." pp_machine_stateless_name
+ m.mname.node_id
+ (Utils.fprintf_list ~sep:" " (pp_horn_var m))
+ (inout_vars m)
+ | assertsl ->
+ let pp_val =
+ pp_horn_val ~is_lhs:true m m.mname.node_id (pp_horn_var m)
+ in
+
+ fprintf fmt "; Stateless step rule with Assertions @.";
+ (*Rule for step*)
+ fprintf fmt "@[<v 2>(rule (=> @ (and @ ";
+ ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
+ fprintf fmt "@. %a)@ (%a @[<v 0>%a)@]@]@.))@.@." (pp_conj pp_val)
+ assertsl pp_machine_stateless_name m.mname.node_id
+ (Utils.fprintf_list ~sep:" " (pp_horn_var m))
+ (step_vars machines m))
+ else (
+ (* Declaring predicate *)
+ fprintf fmt "(declare-rel %a (%a))@." pp_machine_reset_name
+ m.mname.node_id
+ (Utils.fprintf_list ~sep:" " pp_type)
+ (List.map (fun v -> v.var_type) (reset_vars machines m));
+
+ fprintf fmt "(declare-rel %a (%a))@." pp_machine_step_name m.mname.node_id
+ (Utils.fprintf_list ~sep:" " pp_type)
+ (List.map (fun v -> v.var_type) (step_vars machines m));
- if is_stateless m then
- begin
- (* Declaring single predicate *)
- fprintf fmt "(declare-rel %a (%a))@."
- pp_machine_stateless_name m.mname.node_id
- (Utils.fprintf_list ~sep:" " pp_type)
- (List.map (fun v -> v.var_type) (inout_vars m));
-
- match m.mstep.step_asserts with
- | [] ->
- begin
-
- (* Rule for single predicate *)
- fprintf fmt "; Stateless step rule @.";
- fprintf fmt "@[<v 2>(rule (=> @ ";
- ignore (pp_machine_instrs machines ([] (* No reset info for stateless nodes *) ) m fmt m.mstep.step_instrs);
- fprintf fmt "@ (%a @[<v 0>%a)@]@]@.))@.@."
- pp_machine_stateless_name m.mname.node_id
- (Utils.fprintf_list ~sep:" " (pp_horn_var m)) (inout_vars m);
- end
- | assertsl ->
- begin
- let pp_val = pp_horn_val ~is_lhs:true m m.mname.node_id (pp_horn_var m) in
-
- fprintf fmt "; Stateless step rule with Assertions @.";
- (*Rule for step*)
- fprintf fmt "@[<v 2>(rule (=> @ (and @ ";
- ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
- fprintf fmt "@. %a)@ (%a @[<v 0>%a)@]@]@.))@.@." (pp_conj pp_val) assertsl
- pp_machine_stateless_name m.mname.node_id
- (Utils.fprintf_list ~sep:" " (pp_horn_var m)) (step_vars machines m);
-
- end
-
- end
- else
- begin
- (* Declaring predicate *)
- fprintf fmt "(declare-rel %a (%a))@."
- pp_machine_reset_name m.mname.node_id
- (Utils.fprintf_list ~sep:" " pp_type)
- (List.map (fun v -> v.var_type) (reset_vars machines m));
-
- fprintf fmt "(declare-rel %a (%a))@."
- pp_machine_step_name m.mname.node_id
- (Utils.fprintf_list ~sep:" " pp_type)
- (List.map (fun v -> v.var_type) (step_vars machines m));
-
- pp_print_newline fmt ();
-
- (* Rule for reset *)
- fprintf fmt "@[<v 2>(rule (=> @ %a@ (%a @[<v 0>%a)@]@]@.))@.@."
- (pp_machine_reset machines) m
- pp_machine_reset_name m.mname.node_id
- (Utils.fprintf_list ~sep:"@ " (pp_horn_var m)) (reset_vars machines m);
-
- match m.mstep.step_asserts with
- | [] ->
- begin
- fprintf fmt "; Step rule @.";
- (* Rule for step*)
- fprintf fmt "@[<v 2>(rule (=> @ ";
- ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
- fprintf fmt "@ (%a @[<v 0>%a)@]@]@.))@.@."
- pp_machine_step_name m.mname.node_id
- (Utils.fprintf_list ~sep:"@ " (pp_horn_var m)) (step_vars machines m);
- end
- | assertsl ->
- begin
- let pp_val = pp_horn_val ~is_lhs:true m m.mname.node_id (pp_horn_var m) in
- (* print_string pp_val; *)
- fprintf fmt "; Step rule with Assertions @.";
-
- (*Rule for step*)
- fprintf fmt "@[<v 2>(rule (=> @ (and @ ";
- ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
- fprintf fmt "@. %a)@ (%a @[<v 0>%a)@]@]@.))@.@." (pp_conj pp_val) assertsl
- pp_machine_step_name m.mname.node_id
- (Utils.fprintf_list ~sep:" " (pp_horn_var m)) (step_vars machines m);
- end
-
-
- end
- end
+ pp_print_newline fmt ();
+ (* Rule for reset *)
+ fprintf fmt "@[<v 2>(rule (=> @ %a@ (%a @[<v 0>%a)@]@]@.))@.@."
+ (pp_machine_reset machines)
+ m pp_machine_reset_name m.mname.node_id
+ (Utils.fprintf_list ~sep:"@ " (pp_horn_var m))
+ (reset_vars machines m);
+
+ match m.mstep.step_asserts with
+ | [] ->
+ fprintf fmt "; Step rule @.";
+ (* Rule for step*)
+ fprintf fmt "@[<v 2>(rule (=> @ ";
+ ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
+ fprintf fmt "@ (%a @[<v 0>%a)@]@]@.))@.@." pp_machine_step_name
+ m.mname.node_id
+ (Utils.fprintf_list ~sep:"@ " (pp_horn_var m))
+ (step_vars machines m)
+ | assertsl ->
+ let pp_val =
+ pp_horn_val ~is_lhs:true m m.mname.node_id (pp_horn_var m)
+ in
+ (* print_string pp_val; *)
+ fprintf fmt "; Step rule with Assertions @.";
+
+ (*Rule for step*)
+ fprintf fmt "@[<v 2>(rule (=> @ (and @ ";
+ ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
+ fprintf fmt "@. %a)@ (%a @[<v 0>%a)@]@]@.))@.@." (pp_conj pp_val)
+ assertsl pp_machine_step_name m.mname.node_id
+ (Utils.fprintf_list ~sep:" " (pp_horn_var m))
+ (step_vars machines m)))
let mk_flags arity =
let b_range =
- let rec range i j =
- if i > arity then [] else i :: (range (i+1) j) in
- range 2 arity;
- in
- List.fold_left (fun acc _ -> acc ^ " false") "true" b_range
-
+ let rec range i j = if i > arity then [] else i :: range (i + 1) j in
+ range 2 arity
+ in
+ List.fold_left (fun acc _ -> acc ^ " false") "true" b_range
- (*Get sfunction infos from command line*)
-let get_sf_info() =
+(*Get sfunction infos from command line*)
+let get_sf_info () =
let splitted = Str.split (Str.regexp "@") !Options.sfunction in
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. sfunction name: %s@," !Options.sfunction);
- let sf_name, flags, arity = match splitted with
- [h;flg;par] -> h, flg, par
- | _ -> failwith "Wrong Sfunction info"
-
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt ".. sfunction name: %s@," !Options.sfunction);
+ let sf_name, flags, arity =
+ match splitted with
+ | [ h; flg; par ] ->
+ h, flg, par
+ | _ ->
+ failwith "Wrong Sfunction info"
in
- Log.report ~level:1 (fun fmt -> fprintf fmt "... sf_name: %s@, .. flags: %s@ .. arity: %s@," sf_name flags arity);
- sf_name, flags, arity
-
- (*a function to print the rules in case we have an s-function*)
- let print_sfunction machines fmt m =
- if m.mname.node_id = Arrow.arrow_id then
- (* We don't print arrow function *)
- ()
- else
- begin
- Format.fprintf fmt "; SFUNCTION@.";
- Format.fprintf fmt "; %s@." m.mname.node_id;
- Format.fprintf fmt "; EndPoint Predicate %s." !Options.sfunction;
-
- (* Check if there is annotation for s-function *)
- if m.mannot != [] then(
- Format.fprintf fmt "; @[%a@]@]@\n" (Utils.fprintf_list ~sep:"@ " Printers.pp_s_function) m.mannot;
- );
-
- (* Printing variables *)
- Utils.fprintf_list ~sep:"@." pp_decl_var fmt
- ((step_vars machines m)@
- (rename_machine_list m.mname.node_id m.mstep.step_locals));
- Format.pp_print_newline fmt ();
- let sf_name, flags, _ = get_sf_info() in
-
- if is_stateless m then
- begin
- (* Declaring single predicate *)
- Format.fprintf fmt "(declare-rel %a (%a))@."
- pp_machine_stateless_name m.mname.node_id
- (Utils.fprintf_list ~sep:" " pp_type)
- (List.map (fun v -> v.var_type) (reset_vars machines m));
- Format.pp_print_newline fmt ();
- (* Rule for single predicate *)
- let str_flags = sf_name ^ " " ^ mk_flags (int_of_string flags) in
- Format.fprintf fmt "@[<v 2>(rule (=> @ (%s %a) (%a %a)@]@.))@.@."
- str_flags
- (Utils.fprintf_list ~sep:" " (pp_horn_var m)) (reset_vars machines m)
- pp_machine_stateless_name m.mname.node_id
- (Utils.fprintf_list ~sep:" " (pp_horn_var m)) (reset_vars machines m);
- end
- else
- begin
- (* Declaring predicate *)
- Format.fprintf fmt "(declare-rel %a (%a))@."
- pp_machine_reset_name m.mname.node_id
- (Utils.fprintf_list ~sep:" " pp_type)
- (List.map (fun v -> v.var_type) (inout_vars m));
-
- Format.fprintf fmt "(declare-rel %a (%a))@."
- pp_machine_step_name m.mname.node_id
- (Utils.fprintf_list ~sep:" " pp_type)
- (List.map (fun v -> v.var_type) (step_vars machines m));
-
- Format.pp_print_newline fmt ();
- (* Adding assertions *)
- match m.mstep.step_asserts with
- | [] ->
- begin
-
- (* Rule for step*)
- fprintf fmt "@[<v 2>(rule (=> @ ";
- ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
- fprintf fmt "@ (%a @[<v 0>%a)@]@]@.))@.@."
- pp_machine_step_name m.mname.node_id
- (Utils.fprintf_list ~sep:"@ " (pp_horn_var m)) (step_vars machines m);
- end
- | assertsl ->
- begin
- let pp_val = pp_horn_val ~is_lhs:true m m.mname.node_id (pp_horn_var m) in
- (* print_string pp_val; *)
- fprintf fmt "; with Assertions @.";
-
- (*Rule for step*)
- fprintf fmt "@[<v 2>(rule (=> @ (and @ ";
- ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
- fprintf fmt "@. %a)(%a @[<v 0>%a)@]@]@.))@.@." (pp_conj pp_val) assertsl
- pp_machine_step_name m.mname.node_id
- (Utils.fprintf_list ~sep:" " (pp_horn_var m)) (step_vars machines m);
- end
-
- end
-
- end
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "... sf_name: %s@, .. flags: %s@ .. arity: %s@," sf_name flags
+ arity);
+ sf_name, flags, arity
+(*a function to print the rules in case we have an s-function*)
+let print_sfunction machines fmt m =
+ if m.mname.node_id = Arrow.arrow_id then (* We don't print arrow function *)
+ ()
+ else (
+ Format.fprintf fmt "; SFUNCTION@.";
+ Format.fprintf fmt "; %s@." m.mname.node_id;
+ Format.fprintf fmt "; EndPoint Predicate %s." !Options.sfunction;
+
+ (* Check if there is annotation for s-function *)
+ if m.mannot != [] then
+ Format.fprintf fmt "; @[%a@]@]@\n"
+ (Utils.fprintf_list ~sep:"@ " Printers.pp_s_function)
+ m.mannot;
+
+ (* Printing variables *)
+ Utils.fprintf_list ~sep:"@." pp_decl_var fmt
+ (step_vars machines m
+ @ rename_machine_list m.mname.node_id m.mstep.step_locals);
+ Format.pp_print_newline fmt ();
+ let sf_name, flags, _ = get_sf_info () in
+
+ if is_stateless m then (
+ (* Declaring single predicate *)
+ Format.fprintf fmt "(declare-rel %a (%a))@." pp_machine_stateless_name
+ m.mname.node_id
+ (Utils.fprintf_list ~sep:" " pp_type)
+ (List.map (fun v -> v.var_type) (reset_vars machines m));
+ Format.pp_print_newline fmt ();
+ (* Rule for single predicate *)
+ let str_flags = sf_name ^ " " ^ mk_flags (int_of_string flags) in
+ Format.fprintf fmt "@[<v 2>(rule (=> @ (%s %a) (%a %a)@]@.))@.@."
+ str_flags
+ (Utils.fprintf_list ~sep:" " (pp_horn_var m))
+ (reset_vars machines m) pp_machine_stateless_name m.mname.node_id
+ (Utils.fprintf_list ~sep:" " (pp_horn_var m))
+ (reset_vars machines m))
+ else (
+ (* Declaring predicate *)
+ Format.fprintf fmt "(declare-rel %a (%a))@." pp_machine_reset_name
+ m.mname.node_id
+ (Utils.fprintf_list ~sep:" " pp_type)
+ (List.map (fun v -> v.var_type) (inout_vars m));
+
+ Format.fprintf fmt "(declare-rel %a (%a))@." pp_machine_step_name
+ m.mname.node_id
+ (Utils.fprintf_list ~sep:" " pp_type)
+ (List.map (fun v -> v.var_type) (step_vars machines m));
+
+ Format.pp_print_newline fmt ();
+ (* Adding assertions *)
+ match m.mstep.step_asserts with
+ | [] ->
+ (* Rule for step*)
+ fprintf fmt "@[<v 2>(rule (=> @ ";
+ ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
+ fprintf fmt "@ (%a @[<v 0>%a)@]@]@.))@.@." pp_machine_step_name
+ m.mname.node_id
+ (Utils.fprintf_list ~sep:"@ " (pp_horn_var m))
+ (step_vars machines m)
+ | assertsl ->
+ let pp_val =
+ pp_horn_val ~is_lhs:true m m.mname.node_id (pp_horn_var m)
+ in
+ (* print_string pp_val; *)
+ fprintf fmt "; with Assertions @.";
+
+ (*Rule for step*)
+ fprintf fmt "@[<v 2>(rule (=> @ (and @ ";
+ ignore (pp_machine_instrs machines [] m fmt m.mstep.step_instrs);
+ fprintf fmt "@. %a)(%a @[<v 0>%a)@]@]@.))@.@." (pp_conj pp_val) assertsl
+ pp_machine_step_name m.mname.node_id
+ (Utils.fprintf_list ~sep:" " (pp_horn_var m))
+ (step_vars machines m)))
(**************** XML printing functions *************)
- let rec pp_xml_expr fmt expr =
- (match expr.expr_annot with
- | None -> fprintf fmt "%t"
- | Some ann -> fprintf fmt "@[(%a %t)@]" pp_xml_expr_annot ann)
- (fun fmt ->
+let rec pp_xml_expr fmt expr =
+ (match expr.expr_annot with
+ | None ->
+ fprintf fmt "%t"
+ | Some ann ->
+ fprintf fmt "@[(%a %t)@]" pp_xml_expr_annot ann) (fun fmt ->
match expr.expr_desc with
- | Expr_const c -> Printers.pp_const fmt c
- | Expr_ident id -> fprintf fmt "%s" id
- | Expr_array a -> fprintf fmt "[%a]" pp_xml_tuple a
- | Expr_access (a, d) -> fprintf fmt "%a[%a]" pp_xml_expr a Dimension.pp_dimension d
- | Expr_power (a, d) -> fprintf fmt "(%a^%a)" pp_xml_expr a Dimension.pp_dimension d
- | Expr_tuple el -> fprintf fmt "(%a)" pp_xml_tuple el
- | Expr_ite (c, t, e) -> fprintf fmt "@[<hov 1>(if %a then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@])" pp_xml_expr c pp_xml_expr t pp_xml_expr e
- | Expr_arrow (e1, e2) -> fprintf fmt "(%a -> %a)" pp_xml_expr e1 pp_xml_expr e2
- | Expr_fby (e1, e2) -> fprintf fmt "%a fby %a" pp_xml_expr e1 pp_xml_expr e2
- | Expr_pre e -> fprintf fmt "pre %a" pp_xml_expr e
- | Expr_when (e, id, l) -> fprintf fmt "%a when %s(%s)" pp_xml_expr e l id
- | Expr_merge (id, hl) ->
- fprintf fmt "merge %s %a" id pp_xml_handlers hl
- | Expr_appl (id, e, r) -> pp_xml_app fmt id e r
- )
-and pp_xml_tuple fmt el =
- Utils.fprintf_list ~sep:"," pp_xml_expr fmt el
-
-and pp_xml_handler fmt (t, h) =
- fprintf fmt "(%s -> %a)" t pp_xml_expr h
-
-and pp_xml_handlers fmt hl =
- Utils.fprintf_list ~sep:" " pp_xml_handler fmt hl
+ | Expr_const c ->
+ Printers.pp_const fmt c
+ | Expr_ident id ->
+ fprintf fmt "%s" id
+ | Expr_array a ->
+ fprintf fmt "[%a]" pp_xml_tuple a
+ | Expr_access (a, d) ->
+ fprintf fmt "%a[%a]" pp_xml_expr a Dimension.pp_dimension d
+ | Expr_power (a, d) ->
+ fprintf fmt "(%a^%a)" pp_xml_expr a Dimension.pp_dimension d
+ | Expr_tuple el ->
+ fprintf fmt "(%a)" pp_xml_tuple el
+ | Expr_ite (c, t, e) ->
+ fprintf fmt
+ "@[<hov 1>(if %a then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@])"
+ pp_xml_expr c pp_xml_expr t pp_xml_expr e
+ | Expr_arrow (e1, e2) ->
+ fprintf fmt "(%a -> %a)" pp_xml_expr e1 pp_xml_expr e2
+ | Expr_fby (e1, e2) ->
+ fprintf fmt "%a fby %a" pp_xml_expr e1 pp_xml_expr e2
+ | Expr_pre e ->
+ fprintf fmt "pre %a" pp_xml_expr e
+ | Expr_when (e, id, l) ->
+ fprintf fmt "%a when %s(%s)" pp_xml_expr e l id
+ | Expr_merge (id, hl) ->
+ fprintf fmt "merge %s %a" id pp_xml_handlers hl
+ | Expr_appl (id, e, r) ->
+ pp_xml_app fmt id e r)
+
+and pp_xml_tuple fmt el = Utils.fprintf_list ~sep:"," pp_xml_expr fmt el
+
+and pp_xml_handler fmt (t, h) = fprintf fmt "(%s -> %a)" t pp_xml_expr h
+
+and pp_xml_handlers fmt hl = Utils.fprintf_list ~sep:" " pp_xml_handler fmt hl
and pp_xml_app fmt id e r =
match r with
- | None -> pp_xml_call fmt id e
- | Some c -> fprintf fmt "%t every (%a)" (fun fmt -> pp_xml_call fmt id e) pp_xml_expr c
+ | None ->
+ pp_xml_call fmt id e
+ | Some c ->
+ fprintf fmt "%t every (%a)" (fun fmt -> pp_xml_call fmt id e) pp_xml_expr c
and pp_xml_call fmt id e =
match id, e.expr_desc with
- | "+", Expr_tuple([e1;e2]) -> fprintf fmt "(%a + %a)" pp_xml_expr e1 pp_xml_expr e2
- | "uminus", _ -> fprintf fmt "(- %a)" pp_xml_expr e
- | "-", Expr_tuple([e1;e2]) -> fprintf fmt "(%a - %a)" pp_xml_expr e1 pp_xml_expr e2
- | "*", Expr_tuple([e1;e2]) -> fprintf fmt "(%a * %a)" pp_xml_expr e1 pp_xml_expr e2
- | "/", Expr_tuple([e1;e2]) -> fprintf fmt "(%a / %a)" pp_xml_expr e1 pp_xml_expr e2
- | "mod", Expr_tuple([e1;e2]) -> fprintf fmt "(%a mod %a)" pp_xml_expr e1 pp_xml_expr e2
- | "&&", Expr_tuple([e1;e2]) -> fprintf fmt "(%a and %a)" pp_xml_expr e1 pp_xml_expr e2
- | "||", Expr_tuple([e1;e2]) -> fprintf fmt "(%a or %a)" pp_xml_expr e1 pp_xml_expr e2
- | "xor", Expr_tuple([e1;e2]) -> fprintf fmt "(%a xor %a)" pp_xml_expr e1 pp_xml_expr e2
- | "impl", Expr_tuple([e1;e2]) -> fprintf fmt "(%a => %a)" pp_xml_expr e1 pp_xml_expr e2
- | "<", Expr_tuple([e1;e2]) -> fprintf fmt "(%a < %a)" pp_xml_expr e1 pp_xml_expr e2
- | "<=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a <= %a)" pp_xml_expr e1 pp_xml_expr e2
- | ">", Expr_tuple([e1;e2]) -> fprintf fmt "(%a > %a)" pp_xml_expr e1 pp_xml_expr e2
- | ">=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a >= %a)" pp_xml_expr e1 pp_xml_expr e2
- | "!=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a != %a)" pp_xml_expr e1 pp_xml_expr e2
- | "=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a = %a)" pp_xml_expr e1 pp_xml_expr e2
- | "not", _ -> fprintf fmt "(not %a)" pp_xml_expr e
- | _, Expr_tuple _ -> fprintf fmt "%s %a" id pp_xml_expr e
- | _ -> fprintf fmt "%s (%a)" id pp_xml_expr e
+ | "+", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a + %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "uminus", _ ->
+ fprintf fmt "(- %a)" pp_xml_expr e
+ | "-", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a - %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "*", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a * %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "/", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a / %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "mod", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a mod %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "&&", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a and %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "||", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a or %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "xor", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a xor %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "impl", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a => %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "<", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a < %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "<=", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a <= %a)" pp_xml_expr e1 pp_xml_expr e2
+ | ">", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a > %a)" pp_xml_expr e1 pp_xml_expr e2
+ | ">=", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a >= %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "!=", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a != %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "=", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a = %a)" pp_xml_expr e1 pp_xml_expr e2
+ | "not", _ ->
+ fprintf fmt "(not %a)" pp_xml_expr e
+ | _, Expr_tuple _ ->
+ fprintf fmt "%s %a" id pp_xml_expr e
+ | _ ->
+ fprintf fmt "%s (%a)" id pp_xml_expr e
and pp_xml_eexpr fmt e =
fprintf fmt "%a%t %a"
- (Utils.fprintf_list ~sep:"; " Printers.pp_quantifiers) e.eexpr_quantifiers
- (fun fmt -> match e.eexpr_quantifiers with [] -> () | _ -> fprintf fmt ";")
+ (Utils.fprintf_list ~sep:"; " Printers.pp_quantifiers)
+ e.eexpr_quantifiers
+ (fun fmt ->
+ match e.eexpr_quantifiers with [] -> () | _ -> fprintf fmt ";")
pp_xml_expr e.eexpr_qfexpr
-and pp_xml_sf_value fmt e =
- fprintf fmt "%a"
- (* (Utils.fprintf_list ~sep:"; " pp_xml_quantifiers) e.eexpr_quantifiers *)
- (* (fun fmt -> match e.eexpr_quantifiers *)
- (* with [] -> () *)
- (* | _ -> fprintf fmt ";") *)
- pp_xml_expr e.eexpr_qfexpr
+and pp_xml_sf_value fmt e =
+ fprintf fmt "%a"
+ (* (Utils.fprintf_list ~sep:"; " pp_xml_quantifiers) e.eexpr_quantifiers *)
+ (* (fun fmt -> match e.eexpr_quantifiers *)
+ (* with [] -> () *)
+ (* | _ -> fprintf fmt ";") *)
+ pp_xml_expr e.eexpr_qfexpr
and pp_xml_s_function fmt expr_ann =
let pp_xml_annot fmt (kwds, ee) =
Format.fprintf fmt " %t : %a"
- (fun fmt -> match kwds with
- | [] -> assert false
- | [x] -> Format.pp_print_string fmt x
- | _ -> Format.fprintf fmt "%a" (Utils.fprintf_list ~sep:"/" Format.pp_print_string) kwds)
- pp_xml_sf_value ee
+ (fun fmt ->
+ match kwds with
+ | [] ->
+ assert false
+ | [ x ] ->
+ Format.pp_print_string fmt x
+ | _ ->
+ Format.fprintf fmt "%a"
+ (Utils.fprintf_list ~sep:"/" Format.pp_print_string)
+ kwds)
+ pp_xml_sf_value ee
in
Utils.fprintf_list ~sep:"@ " pp_xml_annot fmt expr_ann.annots
and pp_xml_expr_annot fmt expr_ann =
let pp_xml_annot fmt (kwds, ee) =
Format.fprintf fmt "(*! %t: %a; *)"
- (fun fmt -> match kwds with | [] -> assert false | [x] -> Format.pp_print_string fmt x | _ -> Format.fprintf fmt "/%a/" (Utils.fprintf_list ~sep:"/" Format.pp_print_string) kwds)
+ (fun fmt ->
+ match kwds with
+ | [] ->
+ assert false
+ | [ x ] ->
+ Format.pp_print_string fmt x
+ | _ ->
+ Format.fprintf fmt "/%a/"
+ (Utils.fprintf_list ~sep:"/" Format.pp_print_string)
+ kwds)
pp_xml_eexpr ee
in
Utils.fprintf_list ~sep:"@ " pp_xml_annot fmt expr_ann.annots
-
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
(* End: *)
diff --git a/src/backends/Horn/horn_backend_traces.ml b/src/backends/Horn/horn_backend_traces.ml
index a9838824f8a5c6e680110bb6a15a3d99c0c51904..5cc92914ddccf7352c134b6748e1d009431e3558 100644
--- a/src/backends/Horn/horn_backend_traces.ml
+++ b/src/backends/Horn/horn_backend_traces.ml
@@ -12,218 +12,231 @@
(* The compilation presented here was first defined in Garoche, Gurfinkel,
Kahsai, HCSV'14.
- This is a modified version that handle reset
-*)
+ This is a modified version that handle reset *)
open Format
open Lustre_types
open Corelang
open Machine_code_types
-
open Horn_backend_common
open Horn_backend_printers
-let pp_traces = (Utils.fprintf_list ~sep:", " (fun fmt (v,e) -> Format.fprintf fmt "%s -> %a"
- v
- Printers.pp_expr e))
+let pp_traces =
+ Utils.fprintf_list ~sep:", " (fun fmt (v, e) ->
+ Format.fprintf fmt "%s -> %a" v Printers.pp_expr e)
(* Compute memories associated to each machine *)
let compute_mems machines m =
let rec aux fst prefix m =
- (List.map (fun mem -> (prefix, mem)) m.mmemory) @
- List.fold_left (fun accu (id, (n, _)) ->
- let name = node_name n in
- if name = "_arrow" then accu else
- let machine_n = get_machine machines name in
- ( aux false ((id,machine_n)::prefix) machine_n )
- @ accu
- ) [] m.minstances
+ List.map (fun mem -> prefix, mem) m.mmemory
+ @ List.fold_left
+ (fun accu (id, (n, _)) ->
+ let name = node_name n in
+ if name = "_arrow" then accu
+ else
+ let machine_n = get_machine machines name in
+ aux false ((id, machine_n) :: prefix) machine_n @ accu)
+ [] m.minstances
in
aux true [] m
-
(* We extract the annotation dealing with traceability *)
-let machines_traces machines =
- List.map (fun m ->
- let traces : (ident * expr) list=
- let all_annots = List.flatten (List.map (fun ann -> ann.annots) m.mannot) in
- let filtered =
- List.filter (fun (kwds, _) -> kwds = ["traceability"]) all_annots
+let machines_traces machines =
+ List.map
+ (fun m ->
+ let traces : (ident * expr) list =
+ let all_annots =
+ List.flatten (List.map (fun ann -> ann.annots) m.mannot)
+ in
+ let filtered =
+ List.filter (fun (kwds, _) -> kwds = [ "traceability" ]) all_annots
+ in
+ (* List.iter (Format.eprintf "Annots: %a@." Printers.pp_expr_annot)
+ (m.mannot); *)
+ let content = List.map snd filtered in
+ (* Elements are supposed to be a pair (tuple): variable, expression *)
+ List.map
+ (fun ee ->
+ match ee.eexpr_quantifiers, ee.eexpr_qfexpr.expr_desc with
+ | [], Expr_tuple [ v; e ] -> (
+ match v.expr_desc with
+ | Expr_ident vid ->
+ vid, e
+ | _ ->
+ assert false)
+ | _ ->
+ assert false)
+ content
in
- (* List.iter (Format.eprintf "Annots: %a@." Printers.pp_expr_annot) (m.mannot); *)
- let content = List.map snd filtered in
- (* Elements are supposed to be a pair (tuple): variable, expression *)
- List.map (fun ee ->
- match ee.eexpr_quantifiers, ee.eexpr_qfexpr.expr_desc with
- | [], Expr_tuple [v;e] -> (
- match v.expr_desc with
- | Expr_ident vid -> vid, e
- | _ -> assert false )
- | _ -> assert false)
- content
- in
- (* Format.eprintf "Build traces: %a@." pp_traces traces; *)
- m, traces
-
- ) machines
-
+ (* Format.eprintf "Build traces: %a@." pp_traces traces; *)
+ m, traces)
+ machines
+
let memories_old machines m =
- List.map (fun (p, v) ->
- let machine = match p with | [] -> m | (_,m')::_ -> m' in
- let traces = List.assoc machine (machines_traces machines) in
- if List.mem_assoc v.var_id traces then
- (
- (* We take the expression associated to variable v in the trace
- info *)
-
- (* eprintf "Found variable %a in traces: %a@." Printers.pp_var v
- * Printers.pp_expr (List.assoc v.var_id traces); *)
- p, List.assoc v.var_id traces
- )
- else
- begin
-
- (* We keep the variable as is: we create an expression v *)
-
- (* eprintf "Unable to found variable %a in traces (%a)@." Printers.pp_var v
- * pp_traces traces; *)
-
- p, mkexpr Location.dummy_loc (Expr_ident v.var_id)
- end
-
- ) (compute_mems machines m)
-
-let memories_next machines m = (* We remove the topest pre in each expression *)
+ List.map
+ (fun (p, v) ->
+ let machine = match p with [] -> m | (_, m') :: _ -> m' in
+ let traces = List.assoc machine (machines_traces machines) in
+ if List.mem_assoc v.var_id traces then
+ ( (* We take the expression associated to variable v in the trace info *)
+
+ (* eprintf "Found variable %a in traces: %a@." Printers.pp_var v *
+ Printers.pp_expr (List.assoc v.var_id traces); *)
+ p,
+ List.assoc v.var_id traces )
+ else
+ ( (* We keep the variable as is: we create an expression v *)
+
+ (* eprintf "Unable to found variable %a in traces (%a)@."
+ Printers.pp_var v * pp_traces traces; *)
+ p,
+ mkexpr Location.dummy_loc (Expr_ident v.var_id) ))
+ (compute_mems machines m)
+
+let memories_next machines m =
+ (* We remove the topest pre in each expression *)
List.map
(fun (prefix, ee) ->
- let m = match prefix with | [] -> m | (_,m')::_ -> m' in
+ let m = match prefix with [] -> m | (_, m') :: _ -> m' in
match ee.expr_desc with
- | Expr_pre e -> prefix, e
- | Expr_ident var_id -> (
- (* This memory was not introduced through
- normalization. It shall then be a regular x = pre y
- expression. Otherwise it would have been rewritten. We
- have to get its definition and extract the argument of
+ | Expr_pre e ->
+ prefix, e
+ | Expr_ident var_id ->
+ (* This memory was not introduced through normalization. It shall then
+ be a regular x = pre y expression. Otherwise it would have been
+ rewritten. We have to get its definition and extract the argument of
the pre *)
-
let selected_def =
- try
+ try
List.find
(fun def ->
match def with
- | Eq eq -> (match eq.eq_lhs with
- | [v] -> v = var_id
- | _ -> assert false
- )
- | _ -> false)
+ | Eq eq -> (
+ match eq.eq_lhs with [ v ] -> v = var_id | _ -> assert false)
+ | _ ->
+ false)
m.mname.node_stmts
- with _ -> (Format.eprintf
- "Unable to find definition of %s in stmts %a@.prefix=%a@.@?"
- var_id
- Printers.pp_node_stmts m.mname.node_stmts
- (Utils.fprintf_list ~sep:","
- (fun fmt (id,n) -> fprintf fmt "(%s,%s)" id n.mname.node_id ))
- (List.rev prefix)
-
- ;
- assert false)
+ with _ ->
+ Format.eprintf
+ "Unable to find definition of %s in stmts %a@.prefix=%a@.@?"
+ var_id Printers.pp_node_stmts m.mname.node_stmts
+ (Utils.fprintf_list ~sep:"," (fun fmt (id, n) ->
+ fprintf fmt "(%s,%s)" id n.mname.node_id))
+ (List.rev prefix);
+
+ assert false
in
- let def = match selected_def with
+ let def =
+ match selected_def with
| Eq eq -> (
match eq.eq_lhs, eq.eq_rhs.expr_desc with
- | [single_var], Expr_pre e -> if single_var = var_id then e else assert false
- | _ -> assert false
- )
- | _ -> assert false
+ | [ single_var ], Expr_pre e ->
+ if single_var = var_id then e else assert false
+ | _ ->
+ assert false)
+ | _ ->
+ assert false
in
prefix, def
- )
-
| _ ->
- eprintf "Mem Failure: (prefix: %a, eexpr: %a)@.@?"
- (Utils.fprintf_list ~sep:","
- (fun fmt (id,n) -> fprintf fmt "(%s,%s)" id n.mname.node_id ))
- (List.rev prefix)
- Printers.pp_expr ee;
- assert false
- )
+ eprintf "Mem Failure: (prefix: %a, eexpr: %a)@.@?"
+ (Utils.fprintf_list ~sep:"," (fun fmt (id, n) ->
+ fprintf fmt "(%s,%s)" id n.mname.node_id))
+ (List.rev prefix) Printers.pp_expr ee;
+ assert false)
(memories_old machines m)
-
-
let pp_prefix_rev fmt prefix =
- Utils.fprintf_list ~sep:"."
- (fun fmt (id,n) -> fprintf fmt "(%s,%s)" id n.mname.node_id)
- fmt
- (List.rev prefix)
-
+ Utils.fprintf_list ~sep:"."
+ (fun fmt (id, n) -> fprintf fmt "(%s,%s)" id n.mname.node_id)
+ fmt (List.rev prefix)
let traces_file fmt machines =
fprintf fmt "<?xml version=\"1.0\"?>@.";
- fprintf fmt "<Traces xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\">@.";
+ fprintf fmt
+ "<Traces xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\">@.";
fprintf fmt "@[<v 5>@ %a@ @]@."
(Utils.fprintf_list ~sep:"@ " (fun fmt m ->
- let pp_var = pp_horn_var m in
- let memories_old = memories_old machines m in
- let memories_next = memories_next machines m in
-
- (* fprintf fmt "; Node %s@." m.mname.node_id; *)
- fprintf fmt "@[<v 2><Node name=\"%s\">@ " m.mname.node_id;
-
- let input_vars = (rename_machine_list m.mname.node_id m.mstep.step_inputs) in
- let output_vars = (rename_machine_list m.mname.node_id m.mstep.step_outputs) in
- fprintf fmt "<input name=\"%a\" type=\"%a\">%a</input>@ "
- (Utils.fprintf_list ~sep:" | " (pp_horn_var m)) input_vars
- (Utils.fprintf_list ~sep:" | " (fun fmt id -> pp_type fmt id.var_type)) input_vars
- (Utils.fprintf_list ~sep:" | " (pp_horn_var m)) (m.mstep.step_inputs);
-
- fprintf fmt "<output name=\"%a\" type=\"%a\">%a</output>@ "
- (Utils.fprintf_list ~sep:" | " pp_var) output_vars
- (Utils.fprintf_list ~sep:" | " (fun fmt id -> pp_type fmt id.var_type)) output_vars
- (Utils.fprintf_list ~sep:" | " pp_var) (m.mstep.step_outputs);
-
- let local_vars =
- (try
- full_memory_vars ~without_arrow:true machines m
- with Not_found -> Format.eprintf "machine %s@.@?" m.mname.node_id; assert false
- )
- in
- let init_local_vars = rename_next_list local_vars in
- let step_local_vars = rename_current_list local_vars in
-
- fprintf fmt "<localInit name=\"%a\" type=\"%a\">%t%a</localInit>@ "
- (Utils.fprintf_list ~sep:" | " pp_var) init_local_vars
- (Utils.fprintf_list ~sep:" | " (fun fmt id -> pp_type fmt id.var_type)) init_local_vars
- (fun fmt -> match memories_next with [] -> () | _ -> fprintf fmt "")
- (Utils.fprintf_list ~sep:" | " (fun fmt (_, ee) -> fprintf fmt "%a" pp_xml_expr ee)) memories_next;
-
- fprintf fmt "<localStep name=\"%a\" type=\"%a\">%t%a</localStep>@ "
- (Utils.fprintf_list ~sep:" | " pp_var) step_local_vars
- (Utils.fprintf_list ~sep:" | " (fun fmt id -> pp_type fmt id.var_type)) step_local_vars
- (fun fmt -> match memories_old with [] -> () | _ -> fprintf fmt "")
- (Utils.fprintf_list ~sep:" | " (fun fmt (_,ee) -> fprintf fmt "(%a)"
- pp_xml_expr ee)) (memories_old);
-
- let arrow_vars = arrow_vars machines m in
- let arrow_vars_curr = rename_current_list arrow_vars and
- arrow_vars_mid = rename_mid_list arrow_vars and
- arrow_vars_next = rename_next_list arrow_vars
- in
- Utils.fprintf_list ~sep:"@ "
- (fun fmt v -> fprintf fmt "<reset name=\"%a\"/>" pp_var v)
- fmt (arrow_vars_curr@arrow_vars_mid@arrow_vars_next);
- fprintf fmt "@]@ </Node>";
- )) (List.rev machines);
+ let pp_var = pp_horn_var m in
+ let memories_old = memories_old machines m in
+ let memories_next = memories_next machines m in
+
+ (* fprintf fmt "; Node %s@." m.mname.node_id; *)
+ fprintf fmt "@[<v 2><Node name=\"%s\">@ " m.mname.node_id;
+
+ let input_vars =
+ rename_machine_list m.mname.node_id m.mstep.step_inputs
+ in
+ let output_vars =
+ rename_machine_list m.mname.node_id m.mstep.step_outputs
+ in
+ fprintf fmt "<input name=\"%a\" type=\"%a\">%a</input>@ "
+ (Utils.fprintf_list ~sep:" | " (pp_horn_var m))
+ input_vars
+ (Utils.fprintf_list ~sep:" | " (fun fmt id ->
+ pp_type fmt id.var_type))
+ input_vars
+ (Utils.fprintf_list ~sep:" | " (pp_horn_var m))
+ m.mstep.step_inputs;
+
+ fprintf fmt "<output name=\"%a\" type=\"%a\">%a</output>@ "
+ (Utils.fprintf_list ~sep:" | " pp_var)
+ output_vars
+ (Utils.fprintf_list ~sep:" | " (fun fmt id ->
+ pp_type fmt id.var_type))
+ output_vars
+ (Utils.fprintf_list ~sep:" | " pp_var)
+ m.mstep.step_outputs;
+
+ let local_vars =
+ try full_memory_vars ~without_arrow:true machines m
+ with Not_found ->
+ Format.eprintf "machine %s@.@?" m.mname.node_id;
+ assert false
+ in
+ let init_local_vars = rename_next_list local_vars in
+ let step_local_vars = rename_current_list local_vars in
+
+ fprintf fmt "<localInit name=\"%a\" type=\"%a\">%t%a</localInit>@ "
+ (Utils.fprintf_list ~sep:" | " pp_var)
+ init_local_vars
+ (Utils.fprintf_list ~sep:" | " (fun fmt id ->
+ pp_type fmt id.var_type))
+ init_local_vars
+ (fun fmt ->
+ match memories_next with [] -> () | _ -> fprintf fmt "")
+ (Utils.fprintf_list ~sep:" | " (fun fmt (_, ee) ->
+ fprintf fmt "%a" pp_xml_expr ee))
+ memories_next;
+
+ fprintf fmt "<localStep name=\"%a\" type=\"%a\">%t%a</localStep>@ "
+ (Utils.fprintf_list ~sep:" | " pp_var)
+ step_local_vars
+ (Utils.fprintf_list ~sep:" | " (fun fmt id ->
+ pp_type fmt id.var_type))
+ step_local_vars
+ (fun fmt -> match memories_old with [] -> () | _ -> fprintf fmt "")
+ (Utils.fprintf_list ~sep:" | " (fun fmt (_, ee) ->
+ fprintf fmt "(%a)" pp_xml_expr ee))
+ memories_old;
+
+ let arrow_vars = arrow_vars machines m in
+ let arrow_vars_curr = rename_current_list arrow_vars
+ and arrow_vars_mid = rename_mid_list arrow_vars
+ and arrow_vars_next = rename_next_list arrow_vars in
+ Utils.fprintf_list ~sep:"@ "
+ (fun fmt v -> fprintf fmt "<reset name=\"%a\"/>" pp_var v)
+ fmt
+ (arrow_vars_curr @ arrow_vars_mid @ arrow_vars_next);
+ fprintf fmt "@]@ </Node>"))
+ (List.rev machines);
fprintf fmt "</Traces>@."
-
-(* (Utils.fprintf_list ~sep:" | " (fun fmt (prefix, ee) -> fprintf fmt
- "%a%a" pp_prefix_rev prefix Printers.pp_expr ee)) memories_next; *)
-(* (Utils.fprintf_list ~sep:" | " (fun fmt (prefix,ee) -> fprintf fmt
- "%a(%a)" *)
+(* (Utils.fprintf_list ~sep:" | " (fun fmt (prefix, ee) -> fprintf fmt "%a%a"
+ pp_prefix_rev prefix Printers.pp_expr ee)) memories_next; *)
+(* (Utils.fprintf_list ~sep:" | " (fun fmt (prefix,ee) -> fprintf fmt "%a(%a)" *)
(* pp_prefix_rev prefix Printers.pp_expr ee)) (memories_old); *)
-
(* Local Variables: *)
(* compile-command:"make -C ../.." *)
(* End: *)
diff --git a/src/backends/Java/java_backend.ml b/src/backends/Java/java_backend.ml
index 8783933b74e16260cf41aca99994f1768bb8eb31..680a9fe10282045910235647caeda16e6385b7fb 100644
--- a/src/backends/Java/java_backend.ml
+++ b/src/backends/Java/java_backend.ml
@@ -15,203 +15,223 @@ open LustreSpec
open Corelang
open Machine_code
-
(********************************************************************************************)
-(* Basic Printing functions *)
+(* Basic Printing functions *)
(********************************************************************************************)
-let pp_final_char_if_non_empty c l =
- (fun fmt -> match l with [] -> () | _ -> fprintf fmt "%s" c)
+let pp_final_char_if_non_empty c l fmt =
+ match l with [] -> () | _ -> fprintf fmt "%s" c
-let pp_newline_if_non_empty l =
- (fun fmt -> match l with [] -> () | _ -> fprintf fmt "@,")
+let pp_newline_if_non_empty l fmt =
+ match l with [] -> () | _ -> fprintf fmt "@,"
-let pp_dimension fmt d =
- Printers.pp_expr fmt (expr_of_dimension d)
+let pp_dimension fmt d = Printers.pp_expr fmt (expr_of_dimension d)
-let pp_type fmt t =
+let pp_type fmt t =
match (Types.repr t).Types.tdesc with
- | Types.Tbool -> pp_print_string fmt "boolean"
- | Types.Treal -> pp_print_string fmt "double"
- | _ -> Types.print_ty fmt t
+ | Types.Tbool ->
+ pp_print_string fmt "boolean"
+ | Types.Treal ->
+ pp_print_string fmt "double"
+ | _ ->
+ Types.print_ty fmt t
let pp_var fmt id = fprintf fmt "%a %s" pp_type id.var_type id.var_id
-let pp_tag fmt t =
- pp_print_string fmt t
+let pp_tag fmt t = pp_print_string fmt t
let rec pp_const fmt c =
match c with
- | Const_int i -> pp_print_int fmt i
- | Const_real r -> pp_print_string fmt r
- | Const_float r -> pp_print_float fmt r
- | Const_tag t -> pp_tag fmt t
- | Const_array ca -> Format.fprintf fmt "{%a}" (Utils.fprintf_list ~sep:"," pp_const) ca
+ | Const_int i ->
+ pp_print_int fmt i
+ | Const_real r ->
+ pp_print_string fmt r
+ | Const_float r ->
+ pp_print_float fmt r
+ | Const_tag t ->
+ pp_tag fmt t
+ | Const_array ca ->
+ Format.fprintf fmt "{%a}" (Utils.fprintf_list ~sep:"," pp_const) ca
let rec pp_val m fmt v =
match v with
- | Cst c -> pp_const fmt c
- | Var v ->
- if is_state_vars m.memories v then
- fprintf fmt "%s" v
- else
- if List.exists (fun o -> o.var_id = v) m.mstep.step_outputs then
- fprintf fmt "*%s" v
- else
- pp_print_string fmt v
- | Fun (n, vl) -> if Basic_library.is_internal_fun n then
- Basic_library.pp_java n (pp_val m) fmt vl
- else
- fprintf fmt "%s (%a)" n (Utils.fprintf_list ~sep:", " (pp_val m)) vl
+ | Cst c ->
+ pp_const fmt c
+ | Var v ->
+ if is_state_vars m.memories v then fprintf fmt "%s" v
+ else if List.exists (fun o -> o.var_id = v) m.mstep.step_outputs then
+ fprintf fmt "*%s" v
+ else pp_print_string fmt v
+ | Fun (n, vl) ->
+ if Basic_library.is_internal_fun n then
+ Basic_library.pp_java n (pp_val m) fmt vl
+ else fprintf fmt "%s (%a)" n (Utils.fprintf_list ~sep:", " (pp_val m)) vl
let pp_add_val m fmt i =
- if List.exists (fun o -> o.var_id = i) m.mstep.step_outputs
- then
+ if List.exists (fun o -> o.var_id = i) m.mstep.step_outputs then
fprintf fmt "%s" i
- else
- fprintf fmt "&%s" i
+ else fprintf fmt "&%s" i
(********************************************************************************************)
-(* Instruction Printing functions *)
+(* Instruction Printing functions *)
(********************************************************************************************)
let get_output_of_machine machines i =
- try
+ try
let m = List.find (fun m -> m.mname.node_id = i) machines in
m.mstep.step_outputs
with Not_found -> assert false
let rec pp_machine_instr m machines instance_out_list fmt instr =
match instr with
- | MReset i -> (
- match List.assoc i m.minstances with
- | "_arrow" -> fprintf fmt "%s = true;" i
- | _ -> fprintf fmt "%s.reset();" i
- )
- | MLocalAssign (i,v) -> (
- fprintf fmt "%s = %a;"
- i (pp_val m) v
- )
- | MStateAssign (i,v) ->
- fprintf fmt "%s = %a;" i (pp_val m) v
- | MStep ([i0], i, vl) when Basic_library.is_internal_fun i ->
- fprintf fmt "%s = %a;" i0 (Basic_library.pp_java i (pp_val m)) vl
- | MStep ([i0], i, [init; step]) when ((List.assoc i m.minstances) = "_arrow") -> (
- fprintf fmt "@[<v 2>if (%s) {@,%s = false;@,%s = %a;@]@,@[<v 2>} else {@,%s = %a;@]@,};@,"
- i i i0 (pp_val m) init i0 (pp_val m) step
- )
- | MStep (il, i, vl) -> (
- let out =
- try
- List.assoc i instance_out_list
- with Not_found -> (eprintf "impossible to find instance %s in the list@.@?" i;
- assert false)
- in
- fprintf fmt "%s = %s.step (%a);@,"
- out i
- (Utils.fprintf_list ~sep:", " (pp_val m)) vl;
- Utils.fprintf_list ~sep:"@,"
- (fun fmt (o, oname) -> fprintf fmt "%s = %s.%s;" o out oname) fmt
- (List.map2
- (fun x y -> x, y.var_id)
- il
- (get_output_of_machine machines (List.assoc i m.minstances))
- )
- )
-
- | MBranch (g,hl) ->
- Format.fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
- (pp_val m) g
- (Utils.fprintf_list ~sep:"@," (pp_machine_branch m machines instance_out_list)) hl
+ | MReset i -> (
+ match List.assoc i m.minstances with
+ | "_arrow" ->
+ fprintf fmt "%s = true;" i
+ | _ ->
+ fprintf fmt "%s.reset();" i)
+ | MLocalAssign (i, v) ->
+ fprintf fmt "%s = %a;" i (pp_val m) v
+ | MStateAssign (i, v) ->
+ fprintf fmt "%s = %a;" i (pp_val m) v
+ | MStep ([ i0 ], i, vl) when Basic_library.is_internal_fun i ->
+ fprintf fmt "%s = %a;" i0 (Basic_library.pp_java i (pp_val m)) vl
+ | MStep ([ i0 ], i, [ init; step ]) when List.assoc i m.minstances = "_arrow"
+ ->
+ fprintf fmt
+ "@[<v 2>if (%s) {@,\
+ %s = false;@,\
+ %s = %a;@]@,\
+ @[<v 2>} else {@,\
+ %s = %a;@]@,\
+ };@,"
+ i i i0 (pp_val m) init i0 (pp_val m) step
+ | MStep (il, i, vl) ->
+ let out =
+ try List.assoc i instance_out_list
+ with Not_found ->
+ eprintf "impossible to find instance %s in the list@.@?" i;
+ assert false
+ in
+ fprintf fmt "%s = %s.step (%a);@," out i
+ (Utils.fprintf_list ~sep:", " (pp_val m))
+ vl;
+ Utils.fprintf_list ~sep:"@,"
+ (fun fmt (o, oname) -> fprintf fmt "%s = %s.%s;" o out oname)
+ fmt
+ (List.map2
+ (fun x y -> x, y.var_id)
+ il
+ (get_output_of_machine machines (List.assoc i m.minstances)))
+ | MBranch (g, hl) ->
+ Format.fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]" (pp_val m) g
+ (Utils.fprintf_list ~sep:"@,"
+ (pp_machine_branch m machines instance_out_list))
+ hl
and pp_machine_branch m machines instance_out_list fmt (t, h) =
- Format.fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_tag t (Utils.fprintf_list ~sep:"@," (pp_machine_instr m machines instance_out_list)) h
+ Format.fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_tag t
+ (Utils.fprintf_list ~sep:"@,"
+ (pp_machine_instr m machines instance_out_list))
+ h
(********************************************************************************************)
-(* Java file Printing functions *)
+(* Java file Printing functions *)
(********************************************************************************************)
-let get_class_name n = match n with "_arrow" -> "boolean" | _ -> String.capitalize n
+let get_class_name n =
+ match n with "_arrow" -> "boolean" | _ -> String.capitalize n
-let pp_local_fields visibility =
- fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "%s %a;" visibility pp_var v)
+let pp_local_fields visibility =
+ fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "%s %a;" visibility pp_var v)
-let pp_local_field_instances =
- fprintf_list ~sep:"@,"
- (fun fmt (node_inst, node_type) -> fprintf fmt "protected %s %s;"
- (get_class_name node_type)
- node_inst
- )
+let pp_local_field_instances =
+ fprintf_list ~sep:"@," (fun fmt (node_inst, node_type) ->
+ fprintf fmt "protected %s %s;" (get_class_name node_type) node_inst)
let pp_output_constructor fmt outputs =
fprintf fmt "@[<v 2>public Output(%a) {@,%a@]@,}"
- (fprintf_list ~sep:"; " pp_var) outputs
- (fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "this.%s = %s;" v.var_id v.var_id)) outputs
+ (fprintf_list ~sep:"; " pp_var)
+ outputs
+ (fprintf_list ~sep:"@," (fun fmt v ->
+ fprintf fmt "this.%s = %s;" v.var_id v.var_id))
+ outputs
-let pp_output_class fmt step =
+let pp_output_class fmt step =
fprintf fmt "@[<v 2>public class Output {@,%a@,@,%a@]@,}@,"
- (pp_local_fields "public") step.step_outputs
- pp_output_constructor step.step_outputs
-
-let pp_constructor fmt (name, instances) =
- fprintf fmt "@[<v 2>public %s () {@,%a@]@,}@,"
- (String.capitalize name)
- (
- fprintf_list ~sep:"@,"
- (fun fmt (node_inst, node_type) ->
- match node_type with
- "_arrow" -> fprintf fmt "%s = true;" node_inst
- | _ -> fprintf fmt "%s = new %s();" node_inst (get_class_name node_type)
- )
- )
+ (pp_local_fields "public") step.step_outputs pp_output_constructor
+ step.step_outputs
+
+let pp_constructor fmt (name, instances) =
+ fprintf fmt "@[<v 2>public %s () {@,%a@]@,}@," (String.capitalize name)
+ (fprintf_list ~sep:"@," (fun fmt (node_inst, node_type) ->
+ match node_type with
+ | "_arrow" ->
+ fprintf fmt "%s = true;" node_inst
+ | _ ->
+ fprintf fmt "%s = new %s();" node_inst (get_class_name node_type)))
instances
-let pp_reset machines fmt m =
+let pp_reset machines fmt m =
fprintf fmt "@[<v 2>public void reset () {@,%a@]@,}@,"
- (fprintf_list ~sep:"@," (pp_machine_instr m machines [])) m.minit
+ (fprintf_list ~sep:"@," (pp_machine_instr m machines []))
+ m.minit
-let pp_step machines fmt m : unit =
- let out_assoc_list =
+let pp_step machines fmt m : unit =
+ let out_assoc_list =
List.map (fun (node_inst, _) -> node_inst, "out_" ^ node_inst) m.minstances
in
- fprintf fmt
- "@[<v 2>public Output step (%a) {@,%a%t@,%a%a%t@,%a@,%t@]@,}@,"
- (Utils.fprintf_list ~sep:",@ " pp_var) m.mstep.step_inputs
+ fprintf fmt "@[<v 2>public Output step (%a) {@,%a%t@,%a%a%t@,%a@,%t@]@,}@,"
+ (Utils.fprintf_list ~sep:",@ " pp_var)
+ m.mstep.step_inputs
(* locals *)
- (Utils.fprintf_list ~sep:";@," pp_var) m.mstep.step_locals
- (pp_final_char_if_non_empty ";" m.mstep.step_locals)
+ (Utils.fprintf_list ~sep:";@," pp_var)
+ m.mstep.step_locals
+ (pp_final_char_if_non_empty ";" m.mstep.step_locals)
(* declare out variables of subnode instances + out of this node *)
- (fprintf_list ~sep:""
- (fun fmt (ninst, ntype) -> fprintf fmt "%s.Output out_%s;@," (get_class_name ntype) ninst ))
- (List.filter (fun (_,ntyp) -> not (ntyp = "_arrow")) m.minstances)
- (fprintf_list ~sep:";@," pp_var) m.mstep.step_outputs
- (pp_final_char_if_non_empty ";" m.mstep.step_outputs)
+ (fprintf_list ~sep:"" (fun fmt (ninst, ntype) ->
+ fprintf fmt "%s.Output out_%s;@," (get_class_name ntype) ninst))
+ (List.filter (fun (_, ntyp) -> not (ntyp = "_arrow")) m.minstances)
+ (fprintf_list ~sep:";@," pp_var)
+ m.mstep.step_outputs
+ (pp_final_char_if_non_empty ";" m.mstep.step_outputs)
(* instructions *)
- (fprintf_list ~sep:"@," (pp_machine_instr m machines out_assoc_list)) m.mstep.step_instrs
+ (fprintf_list ~sep:"@," (pp_machine_instr m machines out_assoc_list))
+ m.mstep.step_instrs
(* create out object and return it *)
- (fun fmt -> fprintf fmt "return new Output(%a);"
- (fprintf_list ~sep:"," (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_outputs
- )
-
-
+ (fun fmt ->
+ fprintf fmt "return new Output(%a);"
+ (fprintf_list ~sep:"," (fun fmt v -> pp_print_string fmt v.var_id))
+ m.mstep.step_outputs)
let print_machine machines fmt m =
- if m.mname.node_id = "_arrow" then () else ( (* We don't print arrow function *)
+ if m.mname.node_id = "_arrow" then ()
+ else
+ (* We don't print arrow function *)
fprintf fmt "@[<v 2>class %s {@,%a%t%a%t%t%a@,%a@,%a@,%a@]@,}@.@.@."
- (String.capitalize m.mname.node_id) (* class name *)
- (pp_local_fields "protected") m.mmemory (* fields *)
- (pp_newline_if_non_empty m.mmemory)
- pp_local_field_instances m.minstances (* object fields *)
- (pp_newline_if_non_empty m.minstances)
- (pp_newline_if_non_empty m.minstances)
- pp_output_class m.mstep (* class for output of step method *)
- pp_constructor (m.mname.node_id, m.minstances) (* constructor to instanciate object fields *)
- (pp_reset machines) m (* reset method *)
- (pp_step machines) m (* step method *)
-
- )
+ (String.capitalize m.mname.node_id)
+ (* class name *)
+ (pp_local_fields "protected")
+ m.mmemory
+ (* fields *)
+ (pp_newline_if_non_empty m.mmemory)
+ pp_local_field_instances m.minstances
+ (* object fields *)
+ (pp_newline_if_non_empty m.minstances)
+ (pp_newline_if_non_empty m.minstances)
+ pp_output_class m.mstep
+ (* class for output of step method *)
+ pp_constructor
+ (m.mname.node_id, m.minstances)
+ (* constructor to instanciate object fields *)
+ (pp_reset machines)
+ m
+ (* reset method *)
+ (pp_step machines)
+ m
+(* step method *)
(********************************************************************************************)
-(* Main related functions *)
+(* Main related functions *)
(********************************************************************************************)
(* let print_get_input fmt v = *)
@@ -226,37 +246,43 @@ let print_machine machines fmt m =
(* match o.var_type.Types.tdesc with *)
(* | Types.Tint -> fprintf fmt "_put_int(\"%s\", %s)" o.var_id o.var_id *)
(* | Types.Tbool -> fprintf fmt "_put_bool(\"%s\", %s)" o.var_id o.var_id *)
-(* | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o.var_id o.var_id *)
+(* | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o.var_id o.var_id *)
(* | _ -> assert false *)
(* in *)
(* List.iter (fprintf fmt "@ %a;" po) ol *)
-let read_input fmt typ = match typ.Types.tdesc with
- | Types.Treal -> fprintf fmt "StdIn.readDouble()"
- | Types.Tint -> fprintf fmt "StdIn.readInt()"
- | Types.Tbool -> fprintf fmt "StdIn.readBoolean()"
- | _ -> assert false
+let read_input fmt typ =
+ match typ.Types.tdesc with
+ | Types.Treal ->
+ fprintf fmt "StdIn.readDouble()"
+ | Types.Tint ->
+ fprintf fmt "StdIn.readInt()"
+ | Types.Tbool ->
+ fprintf fmt "StdIn.readBoolean()"
+ | _ ->
+ assert false
let print_main_fun basename machines m fmt =
let m_class = String.capitalize m.mname.node_id in
fprintf fmt "@[<v 2>class %s {@,@,@[<v 2>%s {@,%t@,%t@]@,}@,@]@,}@."
(String.capitalize basename)
"public static void main (String[] args)"
- (fun fmt -> fprintf fmt "%s main_node = new %s();" m_class m_class)
- (fun fmt -> fprintf fmt "@[<v 2>while (true) {@,%a@,%t@,%a@]@,}@,"
- (fprintf_list ~sep:"@,"
- (fun fmt v -> fprintf fmt "System.out.println(\"%s?\");@,%a = %a;"
- v.var_id pp_var v read_input v.var_type))
- m.mstep.step_inputs
- (fun fmt -> fprintf fmt "%s.Output out = main_node.step(%a);"
- m_class
- (fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs
- )
- (fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "System.out.println(\"%s = \" + out.%s);" v.var_id v.var_id))
- m.mstep.step_outputs
- )
-
-
+ (fun fmt -> fprintf fmt "%s main_node = new %s();" m_class m_class)
+ (fun fmt ->
+ fprintf fmt "@[<v 2>while (true) {@,%a@,%t@,%a@]@,}@,"
+ (fprintf_list ~sep:"@," (fun fmt v ->
+ fprintf fmt "System.out.println(\"%s?\");@,%a = %a;" v.var_id
+ pp_var v read_input v.var_type))
+ m.mstep.step_inputs
+ (fun fmt ->
+ fprintf fmt "%s.Output out = main_node.step(%a);" m_class
+ (fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))
+ m.mstep.step_inputs)
+ (fprintf_list ~sep:"@," (fun fmt v ->
+ fprintf fmt "System.out.println(\"%s = \" + out.%s);" v.var_id
+ v.var_id))
+ m.mstep.step_outputs)
+
(* let print_main_fun machines m fmt = *)
(* let mname = m.mname.node_id in *)
(* let main_mem = *)
@@ -266,15 +292,18 @@ let print_main_fun basename machines m fmt =
(* fprintf fmt "@[<v 2>int main (int argc, char *argv[]) {@ "; *)
(* fprintf fmt "/* Declaration of inputs/outputs variables */@ "; *)
(* List.iter *)
-(* (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id pp_c_initialize v.var_type *)
+(* (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id
+ pp_c_initialize v.var_type *)
(* ) m.mstep.step_inputs; *)
(* List.iter *)
-(* (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id pp_c_initialize v.var_type *)
+(* (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id
+ pp_c_initialize v.var_type *)
(* ) m.mstep.step_outputs; *)
(* fprintf fmt "@ /* Main memory allocation */@ "; *)
(* if (!Options.static_mem && !Options.main_node <> "") *)
(* then (fprintf fmt "%a(main_mem);@ " pp_machine_static_alloc_name mname) *)
-(* else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname pp_machine_alloc_name mname); *)
+(* else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname
+ pp_machine_alloc_name mname); *)
(* fprintf fmt "@ /* Initialize the main memory */@ "; *)
(* fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem; *)
(* fprintf fmt "@ ISATTY = isatty(0);@ "; *)
@@ -290,7 +319,8 @@ let print_main_fun basename machines m fmt =
(* | [] -> ( *)
(* fprintf fmt "%a(%a%t%s);@ " *)
(* pp_machine_step_name mname *)
-(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
+(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))
+ m.mstep.step_inputs *)
(* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
(* main_mem *)
(* ) *)
@@ -298,17 +328,21 @@ let print_main_fun basename machines m fmt =
(* fprintf fmt "%s = %a(%a%t%a, %s);%a" *)
(* o.var_id *)
(* pp_machine_step_name mname *)
-(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
-(* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
-(* (Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs *)
+(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))
+ m.mstep.step_inputs *)
+(* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
+(* (Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id))
+ m.mstep.step_outputs *)
(* main_mem *)
(* print_put_outputs [o]) *)
(* | _ -> ( *)
(* fprintf fmt "%a(%a%t%a, %s);%a" *)
(* pp_machine_step_name mname *)
-(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
-(* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
-(* (Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs *)
+(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))
+ m.mstep.step_inputs *)
+(* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
+(* (Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id))
+ m.mstep.step_outputs *)
(* main_mem *)
(* print_put_outputs m.mstep.step_outputs) *)
(* ); *)
@@ -317,41 +351,41 @@ let print_main_fun basename machines m fmt =
(* fprintf fmt "@]@ }@." *)
(* let print_main_header fmt = *)
-(* fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include \"io_frontend.h\"@." *)
-
-
+(* fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include
+ \"io_frontend.h\"@." *)
+
(********************************************************************************************)
-(* Translation function *)
+(* Translation function *)
(********************************************************************************************)
let translate_to_java source_fmt basename prog machines =
-
-
(* If a main node is identified, generate a main function for it *)
let main_print =
match !Options.main_node with
- | "" -> (fun _ -> ())
- | main_node -> (
- let main_node_opt =
- List.fold_left
- (fun res m ->
- match res with
- | Some _ -> res
- | None -> if m.mname.node_id = main_node then Some m else None)
- None machines
- in
- match main_node_opt with
- | None -> eprintf "Unable to find a main node named %s@.@?" main_node; (fun _ -> ())
- | Some m -> print_main_fun basename machines m
- )
+ | "" ->
+ fun _ -> ()
+ | main_node -> (
+ let main_node_opt =
+ List.fold_left
+ (fun res m ->
+ match res with
+ | Some _ ->
+ res
+ | None ->
+ if m.mname.node_id = main_node then Some m else None)
+ None machines
+ in
+ match main_node_opt with
+ | None ->
+ eprintf "Unable to find a main node named %s@.@?" main_node;
+ fun _ -> ()
+ | Some m ->
+ print_main_fun basename machines m)
in
-
+
(* Print nodes one by one (in the previous order) *)
List.iter ((print_machine machines) source_fmt) machines;
- main_print source_fmt
-
-
-
+ main_print source_fmt
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/backends/VHDL/vhdl_ast.ml b/src/backends/VHDL/vhdl_ast.ml
index 139db6390c23a538e8e97e3082407cfb5e88d977..f82444a56a1f7f0e1424a0578a8c2943f1603bfe 100644
--- a/src/backends/VHDL/vhdl_ast.ml
+++ b/src/backends/VHDL/vhdl_ast.ml
@@ -1,464 +1,484 @@
(* source: Synario VHDL Reference Manual - March 1997 *)
-(************************************************************************************)
-(* Types *)
-(************************************************************************************)
-let base_types = ["integer"; "character"; "bit"; "real"; "natural"; "positive"; "std_logic"; "std_logic_vector" ]
+(************************************************************************************)
+(* Types *)
+(************************************************************************************)
+let base_types =
+ [
+ "integer";
+ "character";
+ "bit";
+ "real";
+ "natural";
+ "positive";
+ "std_logic";
+ "std_logic_vector";
+ ]
type vhdl_type_t =
| Base of string
| Range of string option * int * int
- | Bit_vector of int * int
- | Array of int * int * vhdl_type_t
+ | Bit_vector of int * int
+ | Array of int * int * vhdl_type_t
| Enumerated of string list
-
+
let rec pp_vhdl_type fmt t =
match t with
- | Base s -> Format.fprintf fmt "%s" s
- | Bit_vector (n,m) -> Format.fprintf fmt "bit_vector(%i downto %i)" n m
- | Range(base, n, m) -> Format.fprintf fmt "%trange %i to %i" (fun fmt -> match base with Some s -> Format.fprintf fmt "%s " s | None -> ()) n m
- | Array (n, m, base) -> Format.fprintf fmt "array (%i to %i) of %a" n m pp_vhdl_type base
- | Enumerated sl -> Format.fprintf fmt "(%a)" (Utils.fprintf_list ~sep:", " Format.pp_print_string) sl
-
-
-
-(************************************************************************************)
-(* Constants *)
-(************************************************************************************)
-
-(* Std_logic values :
- 'U': uninitialized. This signal hasn't been set yet.
- 'X': unknown. Impossible to determine this value/result.
- '0': logic 0
- '1': logic 1
- 'Z': High Impedance
- 'W': Weak signal, can't tell if it should be 0 or 1.
- 'L': Weak signal that should probably go to 0
- 'H': Weak signal that should probably go to 1
- '-': Don't care. *)
-let std_logic_cst = ["U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ]
+ | Base s ->
+ Format.fprintf fmt "%s" s
+ | Bit_vector (n, m) ->
+ Format.fprintf fmt "bit_vector(%i downto %i)" n m
+ | Range (base, n, m) ->
+ Format.fprintf fmt "%trange %i to %i"
+ (fun fmt ->
+ match base with Some s -> Format.fprintf fmt "%s " s | None -> ())
+ n m
+ | Array (n, m, base) ->
+ Format.fprintf fmt "array (%i to %i) of %a" n m pp_vhdl_type base
+ | Enumerated sl ->
+ Format.fprintf fmt "(%a)"
+ (Utils.fprintf_list ~sep:", " Format.pp_print_string)
+ sl
+
+(************************************************************************************)
+(* Constants *)
+(************************************************************************************)
+
+(* Std_logic values : 'U': uninitialized. This signal hasn't been set yet. 'X':
+ unknown. Impossible to determine this value/result. '0': logic 0 '1': logic 1
+ 'Z': High Impedance 'W': Weak signal, can't tell if it should be 0 or 1. 'L':
+ Weak signal that should probably go to 0 'H': Weak signal that should
+ probably go to 1 '-': Don't care. *)
+let std_logic_cst = [ "U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ]
(* TODO: do we need more constructors ? *)
-type cst_val_t = CstInt of int | CstStdLogic of string | CstBV of string * string
+type cst_val_t =
+ | CstInt of int
+ | CstStdLogic of string
+ | CstBV of string * string
let pp_cst_val fmt c =
match c with
- | CstInt i -> Format.fprintf fmt "%i" i
- | CstStdLogic s -> if List.mem s std_logic_cst then Format.fprintf fmt "%s" s else assert false
- | CstBV (pref,suff) -> Format.fprintf fmt "%s\"%s\"" pref suff
-
-(************************************************************************************)
-(* Declarations *)
-(************************************************************************************)
+ | CstInt i ->
+ Format.fprintf fmt "%i" i
+ | CstStdLogic s ->
+ if List.mem s std_logic_cst then Format.fprintf fmt "%s" s else assert false
+ | CstBV (pref, suff) ->
+ Format.fprintf fmt "%s\"%s\"" pref suff
+(************************************************************************************)
+(* Declarations *)
+(************************************************************************************)
(* TODO ? Shall we merge definition / declaration ? Do they appear at the same
-place or at different ones ? *)
+ place or at different ones ? *)
type vhdl_definition_t =
- | Type of {name : string ; definition: vhdl_type_t}
- | Subtype of {name : string ; definition: vhdl_type_t}
-
+ | Type of { name : string; definition : vhdl_type_t }
+ | Subtype of { name : string; definition : vhdl_type_t }
+
let pp_vhdl_definition fmt def =
match def with
- | Type s -> Format.fprintf fmt "type %s is %a;" s.name pp_vhdl_type s.definition
- | Subtype s -> Format.fprintf fmt "subtype %s is %a;" s.name pp_vhdl_type s.definition
-
+ | Type s ->
+ Format.fprintf fmt "type %s is %a;" s.name pp_vhdl_type s.definition
+ | Subtype s ->
+ Format.fprintf fmt "subtype %s is %a;" s.name pp_vhdl_type s.definition
+
type vhdl_declaration_t =
| VarDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }
- | CstDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t }
+ | CstDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t }
| SigDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }
let pp_vhdl_declaration fmt decl =
match decl with
- | VarDecl v -> Format.fprintf
- fmt
- "variable %s : %a%t;"
- v.name
- pp_vhdl_type v.typ
- (fun fmt -> match v.init_val with Some initv -> Format.fprintf fmt " := %a" pp_cst_val initv | _ -> ())
- | CstDecl v -> Format.fprintf
- fmt
- "constant %s : %a := %a;"
- v.name
- pp_vhdl_type v.typ
- pp_cst_val v.init_val
- | SigDecl v -> Format.fprintf
- fmt
- "signal %s : %a%t;"
- v.name
- pp_vhdl_type v.typ
- (fun fmt -> match v.init_val with Some initv -> Format.fprintf fmt " := %a" pp_cst_val initv | _ -> ())
-
-
-(************************************************************************************)
-(* Attributes for types, arrays, signals and strings *)
-(************************************************************************************)
+ | VarDecl v ->
+ Format.fprintf fmt "variable %s : %a%t;" v.name pp_vhdl_type v.typ
+ (fun fmt ->
+ match v.init_val with
+ | Some initv ->
+ Format.fprintf fmt " := %a" pp_cst_val initv
+ | _ ->
+ ())
+ | CstDecl v ->
+ Format.fprintf fmt "constant %s : %a := %a;" v.name pp_vhdl_type v.typ
+ pp_cst_val v.init_val
+ | SigDecl v ->
+ Format.fprintf fmt "signal %s : %a%t;" v.name pp_vhdl_type v.typ (fun fmt ->
+ match v.init_val with
+ | Some initv ->
+ Format.fprintf fmt " := %a" pp_cst_val initv
+ | _ ->
+ ())
+
+(************************************************************************************)
+(* Attributes for types, arrays, signals and strings *)
+(************************************************************************************)
type 'basetype vhdl_type_attributes_t =
- | TAttNoArg of { id: string }
- | TAttIntArg of { id: string; arg: int }
- | TAttValArg of { id: string; arg: 'basetype }
- | TAttStringArg of { id: string; arg: string }
-
-let typ_att_noarg = ["base"; "left"; "right"; "high"; "low"]
-let typ_att_intarg = ["pos"; "val"; "succ"; "pred"; "leftof"; "rightof"]
-let typ_att_valarg = ["image"]
-let typ_att_stringarg = ["value"]
-
+ | TAttNoArg of { id : string }
+ | TAttIntArg of { id : string; arg : int }
+ | TAttValArg of { id : string; arg : 'basetype }
+ | TAttStringArg of { id : string; arg : string }
+
+let typ_att_noarg = [ "base"; "left"; "right"; "high"; "low" ]
+
+let typ_att_intarg = [ "pos"; "val"; "succ"; "pred"; "leftof"; "rightof" ]
+
+let typ_att_valarg = [ "image" ]
+
+let typ_att_stringarg = [ "value" ]
+
let pp_type_attribute pp_val fmt tatt =
match tatt with
- | TAttNoArg a -> Format.fprintf fmt "'%s" a.id
- | TAttIntArg a -> Format.fprintf fmt "'%s(%i)" a.id a.arg
- | TAttValArg a -> Format.fprintf fmt "'%s(%a)" a.id pp_val a.arg
- | TAttStringArg a -> Format.fprintf fmt "'%s(%s)" a.id a.arg
+ | TAttNoArg a ->
+ Format.fprintf fmt "'%s" a.id
+ | TAttIntArg a ->
+ Format.fprintf fmt "'%s(%i)" a.id a.arg
+ | TAttValArg a ->
+ Format.fprintf fmt "'%s(%a)" a.id pp_val a.arg
+ | TAttStringArg a ->
+ Format.fprintf fmt "'%s(%s)" a.id a.arg
+
+type vhdl_array_attributes_t =
+ | AAttInt of { id : string; arg : int }
+ | AAttAscending
-type vhdl_array_attributes_t = AAttInt of { id: string; arg: int; } | AAttAscending
let pp_array_attribute fmt aatt =
match aatt with
- | AAttInt a -> Format.fprintf fmt "'%s(%i)" a.id a.arg
- | AAttAscending -> Format.fprintf fmt "'ascending"
-let array_att_intarg = ["left"; "right"; "high"; "low"; "range"; "reverse_range"; "length"]
+ | AAttInt a ->
+ Format.fprintf fmt "'%s(%i)" a.id a.arg
+ | AAttAscending ->
+ Format.fprintf fmt "'ascending"
+
+let array_att_intarg =
+ [ "left"; "right"; "high"; "low"; "range"; "reverse_range"; "length" ]
type vhdl_signal_attributes_t = SigAtt of string
-let pp_signal_attribute fmt sa = match sa with
- | SigAtt s -> Format.fprintf fmt "'%s" s
+
+let pp_signal_attribute fmt sa =
+ match sa with SigAtt s -> Format.fprintf fmt "'%s" s
+
let signal_att = [ "event"; "stable"; "last_value" ]
type vhdl_string_attributes_t = StringAtt of string
-let pp_string_attribute fmt sa = match sa with
- | StringAtt s -> Format.fprintf fmt "'%s" s
+
+let pp_string_attribute fmt sa =
+ match sa with StringAtt s -> Format.fprintf fmt "'%s" s
+
let signal_att = [ "simple_name"; "path_name"; "instance_name" ]
-(************************************************************************************)
-(* Expressions / Statements *)
-(************************************************************************************)
+(************************************************************************************)
+(* Expressions / Statements *)
+(************************************************************************************)
-
(* TODO: call to functions? procedures? component instanciations ? *)
type suffix_selection_t = Idx of int | Range of int * int
+
let pp_suffix_selection fmt sel =
match sel with
- | Idx n -> Format.fprintf fmt "(%i)" n
- | Range(n,m) -> Format.fprintf fmt "(%i downto %i)" n m
-
+ | Idx n ->
+ Format.fprintf fmt "(%i)" n
+ | Range (n, m) ->
+ Format.fprintf fmt "(%i downto %i)" n m
+
type vhdl_expr_t =
- | Cst of cst_val_t
- | Var of string (* a signal or a variable *)
- | Sig of { name: string; att: vhdl_signal_attributes_t option }
+ | Cst of cst_val_t
+ | Var of string
+ (* a signal or a variable *)
+ | Sig of { name : string; att : vhdl_signal_attributes_t option }
| SuffixMod of { expr : vhdl_expr_t; selection : suffix_selection_t }
- | Op of { id: string; args: vhdl_expr_t list }
-
+ | Op of { id : string; args : vhdl_expr_t list }
+
let rec pp_vhdl_expr fmt e =
match e with
- | Cst c -> pp_cst_val fmt c
- | Var s -> Format.fprintf fmt "%s" s
- | Sig s -> Format.fprintf
- fmt
- "%s%t"
- s.name
- (fun fmt -> match s.att with None -> () | Some att -> pp_signal_attribute fmt att)
+ | Cst c ->
+ pp_cst_val fmt c
+ | Var s ->
+ Format.fprintf fmt "%s" s
+ | Sig s ->
+ Format.fprintf fmt "%s%t" s.name (fun fmt ->
+ match s.att with None -> () | Some att -> pp_signal_attribute fmt att)
| SuffixMod s ->
- Format.fprintf fmt "%a %a"
- pp_vhdl_expr s.expr
- pp_suffix_selection s.selection
+ Format.fprintf fmt "%a %a" pp_vhdl_expr s.expr pp_suffix_selection
+ s.selection
| Op op -> (
match op.args with
- | [] -> assert false
- | [ e1; e2] -> Format.fprintf fmt "@[<hov 3>%a %s %a@]" pp_vhdl_expr e1 op.id pp_vhdl_expr e2
- | _ -> assert false (* all ops are binary up to now *)
- (* | _ -> Format.fprintf fmt "@[<hov 3>%s (%a)@]" op.id (Utils.fprintf_list ~sep:",@ " pp_vhdl_expr) op.args *)
- )
+ | [] ->
+ assert false
+ | [ e1; e2 ] ->
+ Format.fprintf fmt "@[<hov 3>%a %s %a@]" pp_vhdl_expr e1 op.id
+ pp_vhdl_expr e2
+ | _ ->
+ assert false
+ (* all ops are binary up to now *)
+ (* | _ -> Format.fprintf fmt "@[<hov 3>%s (%a)@]" op.id
+ (Utils.fprintf_list ~sep:",@ " pp_vhdl_expr) op.args *))
(* Available operators in the standard library. There are some restrictions on
-types. See reference doc. *)
-let arith_funs = ["+";"-";"*";"/";"mod"; "rem";"abs";"**"]
-let bool_funs = ["and"; "or"; "nand"; "nor"; "xor"; "not"]
-let rel_funs = ["<";">";"<=";">=";"/=";"="]
+ types. See reference doc. *)
+let arith_funs = [ "+"; "-"; "*"; "/"; "mod"; "rem"; "abs"; "**" ]
+
+let bool_funs = [ "and"; "or"; "nand"; "nor"; "xor"; "not" ]
+
+let rel_funs = [ "<"; ">"; "<="; ">="; "/="; "=" ]
-
type vhdl_if_case_t = {
- if_cond: vhdl_expr_t;
- if_block: vhdl_sequential_stmt_t list;
- }
- and vhdl_sequential_stmt_t =
- | VarAssign of { lhs: string; rhs: vhdl_expr_t }
- | SigSeqAssign of { lhs: string; rhs: vhdl_expr_t }
- | If of { if_cases: vhdl_if_case_t list;
- default: (vhdl_sequential_stmt_t list) option; }
- | Case of { guard: vhdl_expr_t; branches: vhdl_case_item_t list }
+ if_cond : vhdl_expr_t;
+ if_block : vhdl_sequential_stmt_t list;
+}
+
+and vhdl_sequential_stmt_t =
+ | VarAssign of { lhs : string; rhs : vhdl_expr_t }
+ | SigSeqAssign of { lhs : string; rhs : vhdl_expr_t }
+ | If of {
+ if_cases : vhdl_if_case_t list;
+ default : vhdl_sequential_stmt_t list option;
+ }
+ | Case of { guard : vhdl_expr_t; branches : vhdl_case_item_t list }
+
and vhdl_case_item_t = {
- when_cond: vhdl_expr_t;
- when_stmt: vhdl_sequential_stmt_t;
- }
+ when_cond : vhdl_expr_t;
+ when_stmt : vhdl_sequential_stmt_t;
+}
-
-
let rec pp_vhdl_sequential_stmt fmt stmt =
match stmt with
- | VarAssign va -> Format.fprintf fmt "%s := %a;" va.lhs pp_vhdl_expr va.rhs
- | SigSeqAssign va -> Format.fprintf fmt "%s <= %a;" va.lhs pp_vhdl_expr va.rhs
- | If ifva -> (
- List.iteri (fun idx ifcase ->
- if idx = 0 then
- Format.fprintf fmt "@[<v 3>if"
- else
- Format.fprintf fmt "@ @[<v 3>elsif";
- Format.fprintf fmt " %a then@ %a@]"
- pp_vhdl_expr ifcase.if_cond
- pp_vhdl_sequential_stmts ifcase.if_block
- ) ifva.if_cases;
- let _ =
- match ifva.default with
- | None -> ()
- | Some bl -> Format.fprintf fmt "@ @[<v 3>else@ %a@]" pp_vhdl_sequential_stmts bl
- in
- Format.fprintf fmt "@ end if;"
- )
- | Case caseva -> (
- Format.fprintf fmt "@[<v 3>case %a is@ %a@]@ end case;"
- pp_vhdl_expr caseva.guard
- (Utils.fprintf_list ~sep:"@ " pp_vhdl_case) caseva.branches
- )
-
-
-and pp_vhdl_sequential_stmts fmt l = Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt fmt l
+ | VarAssign va ->
+ Format.fprintf fmt "%s := %a;" va.lhs pp_vhdl_expr va.rhs
+ | SigSeqAssign va ->
+ Format.fprintf fmt "%s <= %a;" va.lhs pp_vhdl_expr va.rhs
+ | If ifva ->
+ List.iteri
+ (fun idx ifcase ->
+ if idx = 0 then Format.fprintf fmt "@[<v 3>if"
+ else Format.fprintf fmt "@ @[<v 3>elsif";
+ Format.fprintf fmt " %a then@ %a@]" pp_vhdl_expr ifcase.if_cond
+ pp_vhdl_sequential_stmts ifcase.if_block)
+ ifva.if_cases;
+ let _ =
+ match ifva.default with
+ | None ->
+ ()
+ | Some bl ->
+ Format.fprintf fmt "@ @[<v 3>else@ %a@]" pp_vhdl_sequential_stmts bl
+ in
+ Format.fprintf fmt "@ end if;"
+ | Case caseva ->
+ Format.fprintf fmt "@[<v 3>case %a is@ %a@]@ end case;" pp_vhdl_expr
+ caseva.guard
+ (Utils.fprintf_list ~sep:"@ " pp_vhdl_case)
+ caseva.branches
+
+and pp_vhdl_sequential_stmts fmt l =
+ Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt fmt l
+
and pp_vhdl_case fmt case =
- Format.fprintf fmt "when %a => %a"
- pp_vhdl_expr case.when_cond
- pp_vhdl_sequential_stmt case.when_stmt
-
-type signal_condition_t =
- {
- expr: vhdl_expr_t; (* when expression *)
- else_case: vhdl_expr_t option; (* optional else case expression.
- If None, could be a latch *)
- }
-
-type signal_selection_t =
- {
- sel_lhs: string;
- expr : vhdl_expr_t;
- when_sel: vhdl_expr_t option;
- }
-
-type conditional_signal_t =
- {
- lhs: string; (* assigned signal *)
- rhs: vhdl_expr_t; (* expression *)
- cond: signal_condition_t option (* conditional signal statement *)
- }
-
-type process_t =
- { id: string option; active_sigs: string list; body: vhdl_sequential_stmt_t list }
-
-type selected_signal_t = { sel: vhdl_expr_t; branches: signal_selection_t list }
-
+ Format.fprintf fmt "when %a => %a" pp_vhdl_expr case.when_cond
+ pp_vhdl_sequential_stmt case.when_stmt
+
+type signal_condition_t = {
+ expr : vhdl_expr_t;
+ (* when expression *)
+ else_case : vhdl_expr_t option;
+ (* optional else case expression. If None, could be a latch *)
+}
+
+type signal_selection_t = {
+ sel_lhs : string;
+ expr : vhdl_expr_t;
+ when_sel : vhdl_expr_t option;
+}
+
+type conditional_signal_t = {
+ lhs : string;
+ (* assigned signal *)
+ rhs : vhdl_expr_t;
+ (* expression *)
+ cond : signal_condition_t option; (* conditional signal statement *)
+}
+
+type process_t = {
+ id : string option;
+ active_sigs : string list;
+ body : vhdl_sequential_stmt_t list;
+}
+
+type selected_signal_t = {
+ sel : vhdl_expr_t;
+ branches : signal_selection_t list;
+}
+
type vhdl_concurrent_stmt_t =
- | SigAssign of conditional_signal_t
- | Process of process_t
+ | SigAssign of conditional_signal_t
+ | Process of process_t
| SelectedSig of selected_signal_t
- (*
-type vhdl_statement_t =
-
- (* | DeclarationStmt of declaration_stmt_t *)
- | ConcurrentStmt of vhdl_concurrent_stmt_t
- | SequentialStmt of vhdl_sequential_stmt_t
- *)
-
+(* type vhdl_statement_t =
+
+ (* | DeclarationStmt of declaration_stmt_t *) | ConcurrentStmt of
+ vhdl_concurrent_stmt_t | SequentialStmt of vhdl_sequential_stmt_t *)
+
let pp_vhdl_concurrent_stmt fmt stmt =
- let pp_sig_cond fmt va =
- Format.fprintf
- fmt
- "%s <= %a%t;"
- va.lhs
- pp_vhdl_expr va.rhs
- (fun fmt -> match va.cond with
- | None -> ()
- | Some cond ->
- Format.fprintf
- fmt
- " when %a%t"
- pp_vhdl_expr cond.expr
- (fun fmt -> match cond.else_case with
- | None -> ()
- | Some else_case ->
- Format.fprintf
- fmt
- " else %a"
- pp_vhdl_expr else_case
- )
- )
+ let pp_sig_cond fmt va =
+ Format.fprintf fmt "%s <= %a%t;" va.lhs pp_vhdl_expr va.rhs (fun fmt ->
+ match va.cond with
+ | None ->
+ ()
+ | Some cond ->
+ Format.fprintf fmt " when %a%t" pp_vhdl_expr cond.expr (fun fmt ->
+ match cond.else_case with
+ | None ->
+ ()
+ | Some else_case ->
+ Format.fprintf fmt " else %a" pp_vhdl_expr else_case))
in
let pp_process fmt p =
- Format.fprintf
- fmt
- "@[<v 0>%tprocess %a@ @[<v 3>begin@ %a@]@ end process;@]"
- (fun fmt -> match p.id with Some id -> Format.fprintf fmt "%s: " id| None -> ())
+ Format.fprintf fmt "@[<v 0>%tprocess %a@ @[<v 3>begin@ %a@]@ end process;@]"
+ (fun fmt ->
+ match p.id with Some id -> Format.fprintf fmt "%s: " id | None -> ())
(fun fmt asigs ->
- if asigs <> [] then
- Format.fprintf
- fmt
- "(@[<hov 0>%a)@]"
- (Utils.fprintf_list ~sep:",@ " Format.pp_print_string) asigs)
+ if asigs <> [] then
+ Format.fprintf fmt "(@[<hov 0>%a)@]"
+ (Utils.fprintf_list ~sep:",@ " Format.pp_print_string)
+ asigs)
p.active_sigs
- (Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt) p.body
+ (Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt)
+ p.body
in
let pp_sig_sel fmt va =
- Format.fprintf fmt "@[<v 3>with %a select@ %a;@]"
- pp_vhdl_expr va.sel
- (Utils.fprintf_list
- ~sep:"@ "
- (fun fmt b ->
- Format.fprintf
- fmt
- "%s <= %a when %t"
- b.sel_lhs
- pp_vhdl_expr b.expr
- (fun fmt -> match b.when_sel with
- | None -> Format.fprintf fmt "others"
- | Some w -> pp_vhdl_expr fmt w
- ))
- ) va.branches in
+ Format.fprintf fmt "@[<v 3>with %a select@ %a;@]" pp_vhdl_expr va.sel
+ (Utils.fprintf_list ~sep:"@ " (fun fmt b ->
+ Format.fprintf fmt "%s <= %a when %t" b.sel_lhs pp_vhdl_expr b.expr
+ (fun fmt ->
+ match b.when_sel with
+ | None ->
+ Format.fprintf fmt "others"
+ | Some w ->
+ pp_vhdl_expr fmt w)))
+ va.branches
+ in
match stmt with
- | SigAssign va -> pp_sig_cond fmt va
- | Process p -> pp_process fmt p
- | SelectedSig va -> pp_sig_sel fmt va
-
-
-
-
-
+ | SigAssign va ->
+ pp_sig_cond fmt va
+ | Process p ->
+ pp_process fmt p
+ | SelectedSig va ->
+ pp_sig_sel fmt va
+(************************************************************************************)
+(* Entities *)
+(************************************************************************************)
-(************************************************************************************)
-(* Entities *)
-(************************************************************************************)
-
(* TODO? Seems to appear optionally in entities *)
type vhdl_generic_t = unit
+
let pp_vhdl_generic fmt g = ()
-
type vhdl_port_kind_t = InPort | OutPort | InoutPort | BufferPort
+
let pp_vhdl_port_kind fmt p =
match p with
- | InPort -> Format.fprintf fmt "in"
- | OutPort -> Format.fprintf fmt "in"
- | InoutPort -> Format.fprintf fmt "inout"
- | BufferPort -> Format.fprintf fmt "buffer"
-
-
-type vhdl_port_t =
- {
- name: string;
- kind: vhdl_port_kind_t;
- typ: vhdl_type_t;
- }
+ | InPort ->
+ Format.fprintf fmt "in"
+ | OutPort ->
+ Format.fprintf fmt "in"
+ | InoutPort ->
+ Format.fprintf fmt "inout"
+ | BufferPort ->
+ Format.fprintf fmt "buffer"
+
+type vhdl_port_t = { name : string; kind : vhdl_port_kind_t; typ : vhdl_type_t }
let pp_vhdl_port fmt p =
- Format.fprintf fmt "%s : %a %a"
- p.name
- pp_vhdl_port_kind p.kind
- pp_vhdl_type p.typ
-
-
-type vhdl_entity_t =
- {
- name: string;
- generics: vhdl_generic_t list;
- ports: vhdl_port_t list;
- }
+ Format.fprintf fmt "%s : %a %a" p.name pp_vhdl_port_kind p.kind pp_vhdl_type
+ p.typ
+
+type vhdl_entity_t = {
+ name : string;
+ generics : vhdl_generic_t list;
+ ports : vhdl_port_t list;
+}
+
let pp_vhdl_entity fmt e =
- Format.fprintf
- fmt
- "@[<v 3>entity %s is@ %t%t@]@ end %s;@ "
- e.name
- (fun fmt -> List.iter (fun g -> Format.fprintf fmt "generic %a;@ " pp_vhdl_generic g) e.generics)
+ Format.fprintf fmt "@[<v 3>entity %s is@ %t%t@]@ end %s;@ " e.name
+ (fun fmt ->
+ List.iter
+ (fun g -> Format.fprintf fmt "generic %a;@ " pp_vhdl_generic g)
+ e.generics)
(fun fmt ->
- if e.ports = [] then () else
- Format.fprintf fmt "port (@[<hov 0>%a@]);" (Utils.fprintf_list ~sep:",@ " pp_vhdl_port) e.ports)
+ if e.ports = [] then ()
+ else
+ Format.fprintf fmt "port (@[<hov 0>%a@]);"
+ (Utils.fprintf_list ~sep:",@ " pp_vhdl_port)
+ e.ports)
e.name
+(************************************************************************************)
+(* Packages / Library loading *)
+(************************************************************************************)
-
-
-(************************************************************************************)
-(* Packages / Library loading *)
-(************************************************************************************)
-
-
-
(* Optional. Describes shared definitions *)
-type vhdl_package_t =
- {
- name: string;
- shared_defs: vhdl_definition_t list;
- }
+type vhdl_package_t = { name : string; shared_defs : vhdl_definition_t list }
let pp_vhdl_package fmt p =
- Format.fprintf
- fmt
- "@[<v 3>package %s is@ %a@]@ end %s;@ "
- p.name
- (Utils.fprintf_list ~sep:"@ " pp_vhdl_definition) p.shared_defs
- p.name
+ Format.fprintf fmt "@[<v 3>package %s is@ %a@]@ end %s;@ " p.name
+ (Utils.fprintf_list ~sep:"@ " pp_vhdl_definition)
+ p.shared_defs p.name
type vhdl_load_t = Library of string | Use of string list
+
let pp_vhdl_load fmt l =
match l with
- | Library s -> Format.fprintf fmt "library %s;@ " s
- | Use sl -> Format.fprintf fmt "use %a;@ " (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl
-
-
-(************************************************************************************)
-(* Architecture / VHDL Design *)
-(************************************************************************************)
-
-
-type vhdl_architecture_t =
- {
- name: string;
- entity: string;
- declarations: vhdl_declaration_t list;
- body: vhdl_concurrent_stmt_t list;
- }
-
+ | Library s ->
+ Format.fprintf fmt "library %s;@ " s
+ | Use sl ->
+ Format.fprintf fmt "use %a;@ "
+ (Utils.fprintf_list ~sep:"." Format.pp_print_string)
+ sl
+
+(************************************************************************************)
+(* Architecture / VHDL Design *)
+(************************************************************************************)
+
+type vhdl_architecture_t = {
+ name : string;
+ entity : string;
+ declarations : vhdl_declaration_t list;
+ body : vhdl_concurrent_stmt_t list;
+}
+
let pp_vhdl_architecture fmt a =
- Format.fprintf
- fmt
- "@[<v 3>architecture %s of %s is@ %a@]@ @[<v 3>begin@ %a@]@ end %s;"
- a.name
+ Format.fprintf fmt
+ "@[<v 3>architecture %s of %s is@ %a@]@ @[<v 3>begin@ %a@]@ end %s;" a.name
a.entity
- (Utils.fprintf_list ~sep:"@ " pp_vhdl_declaration) a.declarations
- (Utils.fprintf_list ~sep:"@ " pp_vhdl_concurrent_stmt) a.body
- a.name
-
+ (Utils.fprintf_list ~sep:"@ " pp_vhdl_declaration)
+ a.declarations
+ (Utils.fprintf_list ~sep:"@ " pp_vhdl_concurrent_stmt)
+ a.body a.name
(* TODO. Configuraiton is optional *)
type vhdl_configuration_t = unit
-let pp_vhdl_configuration fmt c = ()
-
+let pp_vhdl_configuration fmt c = ()
-type vhdl_design_t =
- {
- packages: vhdl_package_t list;
- libraries: vhdl_load_t list;
- entities: vhdl_entity_t list;
- architectures: vhdl_architecture_t list;
- configuration: vhdl_configuration_t option;
- }
+type vhdl_design_t = {
+ packages : vhdl_package_t list;
+ libraries : vhdl_load_t list;
+ entities : vhdl_entity_t list;
+ architectures : vhdl_architecture_t list;
+ configuration : vhdl_configuration_t option;
+}
let pp_vhdl_design fmt d =
- Format.fprintf
- fmt
- "@[<v 0>%a%t%a%t%a%t%a%t@]"
- (Utils.fprintf_list ~sep:"@ " pp_vhdl_package) d.packages
+ Format.fprintf fmt "@[<v 0>%a%t%a%t%a%t%a%t@]"
+ (Utils.fprintf_list ~sep:"@ " pp_vhdl_package)
+ d.packages
(fun fmt -> if d.packages <> [] then Format.fprintf fmt "@ ")
- (Utils.fprintf_list ~sep:"@ " pp_vhdl_load) d.libraries
+ (Utils.fprintf_list ~sep:"@ " pp_vhdl_load)
+ d.libraries
(fun fmt -> if d.libraries <> [] then Format.fprintf fmt "@ ")
- (Utils.fprintf_list ~sep:"@ " pp_vhdl_entity) d.entities
+ (Utils.fprintf_list ~sep:"@ " pp_vhdl_entity)
+ d.entities
(fun fmt -> if d.entities <> [] then Format.fprintf fmt "@ ")
- (Utils.fprintf_list ~sep:"@ " pp_vhdl_architecture) d.architectures
+ (Utils.fprintf_list ~sep:"@ " pp_vhdl_architecture)
+ d.architectures
(fun fmt -> if d.architectures <> [] then Format.fprintf fmt "@ ")
diff --git a/src/backends/VHDL/vhdl_test.ml b/src/backends/VHDL/vhdl_test.ml
index 44d61c875e1fd48b6b82226b67ed456a22947a11..93b85ec729aaece968e24cc11f3c609e68f6a170 100644
--- a/src/backends/VHDL/vhdl_test.ml
+++ b/src/backends/VHDL/vhdl_test.ml
@@ -1,123 +1,246 @@
open Vhdl_ast
-let design1 = {
- packages = [{name = "typedef"; shared_defs = [Subtype{name = "byte"; definition = Bit_vector (7, 0)}]}];
- libraries = [Use ["work";"typedef";"all"]];
- entities = [{ name = "data_path";
- generics = [];
- ports = [
- {name = "clk"; kind = InPort; typ = Base "boolean"};
- {name = "rst"; kind = InPort; typ = Base "boolean"};
- {name = "s_1"; kind = InPort; typ = Base "boolean"};
- {name = "s0"; kind = InPort; typ = Base "bit"};
- {name = "s1"; kind = InPort; typ = Base "bit"};
- {name = "d0"; kind = InPort; typ = Base "byte"};
- {name = "d1"; kind = InPort; typ = Base "byte"};
- {name = "d2"; kind = InPort; typ = Base "byte"};
- {name = "d3"; kind = InPort; typ = Base "byte"};
- {name = "q"; kind = OutPort; typ = Base "byte"};
-
- ];
- }];
- architectures = [{
- name = "behavior";
- entity = "data_path";
- declarations = [
- SigDecl { name = "reg"; typ = Base "byte"; init_val = None};
- SigDecl { name = "shft"; typ = Base "byte"; init_val = None};
- SigDecl { name = "sel"; typ = Bit_vector(1,0); init_val = None};
-
- ];
- body = [
- Process {
- id = None;
- active_sigs = ["clk"; "rst"];
- body = [
- If {
- if_cases = [
- {
- if_cond = Sig{ name = "rst"; att = None };
- if_block = [
- SigSeqAssign { lhs = "req"; rhs = Cst (CstBV("x", "00"))};
- SigSeqAssign { lhs = "shft"; rhs = Cst (CstBV("x", "00"))};
- ];
- };
- {
- if_cond = Op {id = "and"; args = [Sig{ name = "clk"; att = None };
- Sig{ name = "clk"; att = Some (SigAtt "event") }]};
- if_block = [
- SigSeqAssign { lhs = "req"; rhs = Op { id = "&"; args = [
- Sig{ name = "s0"; att = None };
- Sig{ name = "s1"; att = None }
- ]
- }
- };
- Case {
- guard = Sig{ name = "sel"; att = None };
- branches = [
- {
- when_cond = Cst (CstBV("b", "00"));
- when_stmt = SigSeqAssign { lhs = "req"; rhs = Sig{ name = "d0"; att = None }};
- };
- {
- when_cond = Cst (CstBV("b", "10"));
- when_stmt = SigSeqAssign { lhs = "req"; rhs = Sig{ name = "d1"; att = None }};
- };
- {
- when_cond = Cst (CstBV("b", "01"));
- when_stmt = SigSeqAssign { lhs = "req"; rhs = Sig{ name = "d2"; att = None }};
- };
- {
- when_cond = Cst (CstBV("b", "11"));
- when_stmt = SigSeqAssign { lhs = "req"; rhs = Sig{ name = "d3"; att = None }};
- };
-
- ]
-
- };
- If {
- if_cases = [
- {
- if_cond = Sig{ name = "s_1"; att = None };
- if_block = [
- SigSeqAssign {
- lhs = "shft";
- rhs = Op { id = "&";
- args = [
- SuffixMod {
- expr = Sig{ name = "shft"; att = None };
- selection = Range (6,0);
- };
- SuffixMod {
- expr = Sig{ name = "shft"; att = None };
- selection = Idx 7;
- }
- ]
- }
- };
- ];
- };
- ];
- default = Some [
- SigSeqAssign { lhs = "shft"; rhs = Var "reg"};
- ]
- };
- ];
- };
-
- ];
- default = None;
- }
- ];
- };
- SigAssign {
- lhs = "q";
- rhs = Var "shft";
- cond = None;
- }
-
- ];
- }];
+let design1 =
+ {
+ packages =
+ [
+ {
+ name = "typedef";
+ shared_defs =
+ [ Subtype { name = "byte"; definition = Bit_vector (7, 0) } ];
+ };
+ ];
+ libraries = [ Use [ "work"; "typedef"; "all" ] ];
+ entities =
+ [
+ {
+ name = "data_path";
+ generics = [];
+ ports =
+ [
+ { name = "clk"; kind = InPort; typ = Base "boolean" };
+ { name = "rst"; kind = InPort; typ = Base "boolean" };
+ { name = "s_1"; kind = InPort; typ = Base "boolean" };
+ { name = "s0"; kind = InPort; typ = Base "bit" };
+ { name = "s1"; kind = InPort; typ = Base "bit" };
+ { name = "d0"; kind = InPort; typ = Base "byte" };
+ { name = "d1"; kind = InPort; typ = Base "byte" };
+ { name = "d2"; kind = InPort; typ = Base "byte" };
+ { name = "d3"; kind = InPort; typ = Base "byte" };
+ { name = "q"; kind = OutPort; typ = Base "byte" };
+ ];
+ };
+ ];
+ architectures =
+ [
+ {
+ name = "behavior";
+ entity = "data_path";
+ declarations =
+ [
+ SigDecl { name = "reg"; typ = Base "byte"; init_val = None };
+ SigDecl { name = "shft"; typ = Base "byte"; init_val = None };
+ SigDecl { name = "sel"; typ = Bit_vector (1, 0); init_val = None };
+ ];
+ body =
+ [
+ Process
+ {
+ id = None;
+ active_sigs = [ "clk"; "rst" ];
+ body =
+ [
+ If
+ {
+ if_cases =
+ [
+ {
+ if_cond = Sig { name = "rst"; att = None };
+ if_block =
+ [
+ SigSeqAssign
+ {
+ lhs = "req";
+ rhs = Cst (CstBV ("x", "00"));
+ };
+ SigSeqAssign
+ {
+ lhs = "shft";
+ rhs = Cst (CstBV ("x", "00"));
+ };
+ ];
+ };
+ {
+ if_cond =
+ Op
+ {
+ id = "and";
+ args =
+ [
+ Sig { name = "clk"; att = None };
+ Sig
+ {
+ name = "clk";
+ att = Some (SigAtt "event");
+ };
+ ];
+ };
+ if_block =
+ [
+ SigSeqAssign
+ {
+ lhs = "req";
+ rhs =
+ Op
+ {
+ id = "&";
+ args =
+ [
+ Sig
+ { name = "s0"; att = None };
+ Sig
+ { name = "s1"; att = None };
+ ];
+ };
+ };
+ Case
+ {
+ guard = Sig { name = "sel"; att = None };
+ branches =
+ [
+ {
+ when_cond =
+ Cst (CstBV ("b", "00"));
+ when_stmt =
+ SigSeqAssign
+ {
+ lhs = "req";
+ rhs =
+ Sig
+ {
+ name = "d0";
+ att = None;
+ };
+ };
+ };
+ {
+ when_cond =
+ Cst (CstBV ("b", "10"));
+ when_stmt =
+ SigSeqAssign
+ {
+ lhs = "req";
+ rhs =
+ Sig
+ {
+ name = "d1";
+ att = None;
+ };
+ };
+ };
+ {
+ when_cond =
+ Cst (CstBV ("b", "01"));
+ when_stmt =
+ SigSeqAssign
+ {
+ lhs = "req";
+ rhs =
+ Sig
+ {
+ name = "d2";
+ att = None;
+ };
+ };
+ };
+ {
+ when_cond =
+ Cst (CstBV ("b", "11"));
+ when_stmt =
+ SigSeqAssign
+ {
+ lhs = "req";
+ rhs =
+ Sig
+ {
+ name = "d3";
+ att = None;
+ };
+ };
+ };
+ ];
+ };
+ If
+ {
+ if_cases =
+ [
+ {
+ if_cond =
+ Sig { name = "s_1"; att = None };
+ if_block =
+ [
+ SigSeqAssign
+ {
+ lhs = "shft";
+ rhs =
+ Op
+ {
+ id = "&";
+ args =
+ [
+ SuffixMod
+ {
+ expr =
+ Sig
+ {
+ name =
+ "shft";
+ att =
+ None;
+ };
+ selection =
+ Range
+ (6, 0);
+ };
+ SuffixMod
+ {
+ expr =
+ Sig
+ {
+ name =
+ "shft";
+ att =
+ None;
+ };
+ selection =
+ Idx 7;
+ };
+ ];
+ };
+ };
+ ];
+ };
+ ];
+ default =
+ Some
+ [
+ SigSeqAssign
+ {
+ lhs = "shft";
+ rhs = Var "reg";
+ };
+ ];
+ };
+ ];
+ };
+ ];
+ default = None;
+ };
+ ];
+ };
+ SigAssign { lhs = "q"; rhs = Var "shft"; cond = None };
+ ];
+ };
+ ];
configuration = None;
}
-
diff --git a/src/backends/backends.ml b/src/backends/backends.ml
index c4a4f012786d48974acd9891cde7831afd355da1..22da34e022d5f8547199af7f6c29b9064f4f7664 100644
--- a/src/backends/backends.ml
+++ b/src/backends/backends.ml
@@ -2,46 +2,37 @@
let join_guards = ref true
let setup () =
- if !Options.output = "emf" then begin
+ if !Options.output = "emf" then (
(* Not merging branches *)
join_guards := false;
(* In case of a default "int" type, substitute it with the legal int32 value *)
- if !Options.int_type = "int" then Options.int_type := "int32"
- end;
- if !Options.optimization < 0 then
- join_guards := false
+ if !Options.int_type = "int" then Options.int_type := "int32");
+ if !Options.optimization < 0 then join_guards := false
-let is_functional () =
+let is_functional () =
match !Options.output with
- | "horn" | "lustre" | "acsl" | "emf" -> true
- | _ -> false
+ | "horn" | "lustre" | "acsl" | "emf" ->
+ true
+ | _ ->
+ false
-
(* Special treatment of arrows in lustre backend. We want to keep them *)
-let unfold_arrow () =
- match !Options.output with
- | "lustre" -> false
- | _ -> true
+let unfold_arrow () = match !Options.output with "lustre" -> false | _ -> true
(* Forcing ite normalization *)
-let alias_ite () =
- match !Options.output with
- | "emf" -> true
- | _ -> false
+let alias_ite () = match !Options.output with "emf" -> true | _ -> false
(* Forcing basic functions normalization *)
let alias_internal_fun () =
- match !Options.output with
- | "emf" -> true
- | _ -> false
+ match !Options.output with "emf" -> true | _ -> false
-let get_normalization_params () = {
+let get_normalization_params () =
+ {
Normalization.unfold_arrow_active = unfold_arrow ();
force_alias_ite = alias_ite ();
force_alias_internal_fun = alias_internal_fun ();
}
-
(* Local Variables: *)
(* compile-command: "make -k -C .." *)
(* End: *)
diff --git a/src/basic_library.ml b/src/basic_library.ml
index 4317eaf5ad309aa200330bab0598ae8ac4d1ebfd..81b5c6bc27cdf9d7593867b24a67543e4604fda3 100644
--- a/src/basic_library.ml
+++ b/src/basic_library.ml
@@ -16,52 +16,74 @@ open Type_predef
open Clock_predef
open Delay_predef
open Dimension
-
module TE = Env
-let static_op ty =
- type_static (mkdim_var ()) ty
+let static_op ty = type_static (mkdim_var ()) ty
let type_env =
List.fold_left
(fun env (op, op_type) -> TE.add_value env op op_type)
TE.initial
[
- "true", (static_op type_bool);
- "false", (static_op type_bool);
- "+", (static_op type_bin_poly_op);
- "uminus", (static_op type_unary_poly_op);
- "-", (static_op type_bin_poly_op);
- "*", (static_op type_bin_poly_op);
- "/", (static_op type_bin_poly_op);
- "mod", (static_op type_bin_int_op);
- "&&", (static_op type_bin_bool_op);
- "||", (static_op type_bin_bool_op);
- "xor", (static_op type_bin_bool_op);
- "equi", (static_op type_bin_bool_op);
- "impl", (static_op type_bin_bool_op);
- "<", (static_op type_bin_comp_op);
- "<=", (static_op type_bin_comp_op);
- ">", (static_op type_bin_comp_op);
- ">=", (static_op type_bin_comp_op);
- "!=", (static_op type_bin_comp_op);
- "=", (static_op type_bin_comp_op);
- "not", (static_op type_unary_bool_op)
-]
+ "true", static_op type_bool;
+ "false", static_op type_bool;
+ "+", static_op type_bin_poly_op;
+ "uminus", static_op type_unary_poly_op;
+ "-", static_op type_bin_poly_op;
+ "*", static_op type_bin_poly_op;
+ "/", static_op type_bin_poly_op;
+ "mod", static_op type_bin_int_op;
+ "&&", static_op type_bin_bool_op;
+ "||", static_op type_bin_bool_op;
+ "xor", static_op type_bin_bool_op;
+ "equi", static_op type_bin_bool_op;
+ "impl", static_op type_bin_bool_op;
+ "<", static_op type_bin_comp_op;
+ "<=", static_op type_bin_comp_op;
+ ">", static_op type_bin_comp_op;
+ ">=", static_op type_bin_comp_op;
+ "!=", static_op type_bin_comp_op;
+ "=", static_op type_bin_comp_op;
+ "not", static_op type_unary_bool_op;
+ ]
module CE = Env
let clock_env =
let init_env = CE.initial in
let env' =
- List.fold_right (fun op env -> CE.add_value env op ck_nullary_univ)
- ["true"; "false"] init_env in
+ List.fold_right
+ (fun op env -> CE.add_value env op ck_nullary_univ)
+ [ "true"; "false" ] init_env
+ in
let env' =
- List.fold_right (fun op env -> CE.add_value env op ck_unary_univ)
- ["uminus"; "not"] env' in
+ List.fold_right
+ (fun op env -> CE.add_value env op ck_unary_univ)
+ [ "uminus"; "not" ] env'
+ in
let env' =
- List.fold_right (fun op env -> CE.add_value env op ck_bin_univ)
- ["+"; "-"; "*"; "/"; "mod"; "&&"; "||"; "xor"; "equi"; "impl"; "<"; "<="; ">"; ">="; "!="; "="] env' in
+ List.fold_right
+ (fun op env -> CE.add_value env op ck_bin_univ)
+ [
+ "+";
+ "-";
+ "*";
+ "/";
+ "mod";
+ "&&";
+ "||";
+ "xor";
+ "equi";
+ "impl";
+ "<";
+ "<=";
+ ">";
+ ">=";
+ "!=";
+ "=";
+ ]
+ env'
+ in
env'
module DE = Env
@@ -69,237 +91,301 @@ module DE = Env
let delay_env =
let init_env = DE.initial in
let env' =
- List.fold_right (fun op env -> DE.add_value env op delay_nullary_poly_op)
- ["true"; "false"] init_env in
+ List.fold_right
+ (fun op env -> DE.add_value env op delay_nullary_poly_op)
+ [ "true"; "false" ] init_env
+ in
let env' =
- List.fold_right (fun op env -> DE.add_value env op delay_unary_poly_op)
- ["uminus"; "not"] env' in
+ List.fold_right
+ (fun op env -> DE.add_value env op delay_unary_poly_op)
+ [ "uminus"; "not" ] env'
+ in
let env' =
- List.fold_right (fun op env -> DE.add_value env op delay_binary_poly_op)
- ["+"; "-"; "*"; "/"; "mod"; "&&"; "||"; "xor"; "equi"; "impl"; "<"; "<="; ">"; ">="; "!="; "="] env' in
+ List.fold_right
+ (fun op env -> DE.add_value env op delay_binary_poly_op)
+ [
+ "+";
+ "-";
+ "*";
+ "/";
+ "mod";
+ "&&";
+ "||";
+ "xor";
+ "equi";
+ "impl";
+ "<";
+ "<=";
+ ">";
+ ">=";
+ "!=";
+ "=";
+ ]
+ env'
+ in
let env' =
- List.fold_right (fun op env -> DE.add_value env op delay_ternary_poly_op)
- [] env' in
+ List.fold_right
+ (fun op env -> DE.add_value env op delay_ternary_poly_op)
+ [] env'
+ in
env'
module VE = Env
let eval_dim_env =
- let defs = [
- "uminus", (function [Dint a] -> Dint (-a) | _ -> assert false);
- "not", (function [Dbool b] -> Dbool (not b) | _ -> assert false);
- "+", (function [Dint a; Dint b] -> Dint (a+b) | _ -> assert false);
- "-", (function [Dint a; Dint b] -> Dint (a-b) | _ -> assert false);
- "*", (function [Dint a; Dint b] -> Dint (a*b) | _ -> assert false);
- "/", (function [Dint a; Dint b] -> Dint (a/b) | _ -> assert false);
- "mod", (function [Dint a; Dint b] -> Dint (a mod b) | _ -> assert false);
- "&&", (function [Dbool a; Dbool b] -> Dbool (a&&b) | _ -> assert false);
- "||", (function [Dbool a; Dbool b] -> Dbool (a||b) | _ -> assert false);
- "xor", (function [Dbool a; Dbool b] -> Dbool (a<>b) | _ -> assert false);
- "equi", (function [Dbool a; Dbool b] -> Dbool (a=b) | _ -> assert false);
- "impl", (function [Dbool a; Dbool b] -> Dbool (a<=b)| _ -> assert false);
- "<", (function [Dint a; Dint b] -> Dbool (a<b) | _ -> assert false);
- ">", (function [Dint a; Dint b] -> Dbool (a>b) | _ -> assert false);
- "<=", (function [Dint a; Dint b] -> Dbool (a<=b) | _ -> assert false);
- ">=", (function [Dint a; Dint b] -> Dbool (a>=b) | _ -> assert false);
- "!=", (function [a; b] -> Dbool (a<>b) | _ -> assert false);
- "=", (function [a; b] -> Dbool (a=b) | _ -> assert false);
- ]
+ let defs =
+ [
+ ("uminus", function [ Dint a ] -> Dint (-a) | _ -> assert false);
+ ("not", function [ Dbool b ] -> Dbool (not b) | _ -> assert false);
+ ("+", function [ Dint a; Dint b ] -> Dint (a + b) | _ -> assert false);
+ ("-", function [ Dint a; Dint b ] -> Dint (a - b) | _ -> assert false);
+ ("*", function [ Dint a; Dint b ] -> Dint (a * b) | _ -> assert false);
+ ("/", function [ Dint a; Dint b ] -> Dint (a / b) | _ -> assert false);
+ ( "mod",
+ function [ Dint a; Dint b ] -> Dint (a mod b) | _ -> assert false );
+ ( "&&",
+ function [ Dbool a; Dbool b ] -> Dbool (a && b) | _ -> assert false );
+ ( "||",
+ function [ Dbool a; Dbool b ] -> Dbool (a || b) | _ -> assert false );
+ ( "xor",
+ function [ Dbool a; Dbool b ] -> Dbool (a <> b) | _ -> assert false );
+ ( "equi",
+ function [ Dbool a; Dbool b ] -> Dbool (a = b) | _ -> assert false );
+ ( "impl",
+ function [ Dbool a; Dbool b ] -> Dbool (a <= b) | _ -> assert false );
+ ("<", function [ Dint a; Dint b ] -> Dbool (a < b) | _ -> assert false);
+ (">", function [ Dint a; Dint b ] -> Dbool (a > b) | _ -> assert false);
+ ("<=", function [ Dint a; Dint b ] -> Dbool (a <= b) | _ -> assert false);
+ (">=", function [ Dint a; Dint b ] -> Dbool (a >= b) | _ -> assert false);
+ ("!=", function [ a; b ] -> Dbool (a <> b) | _ -> assert false);
+ ("=", function [ a; b ] -> Dbool (a = b) | _ -> assert false);
+ ]
in
List.fold_left
(fun env (op, op_eval) -> VE.add_value env op op_eval)
- VE.initial
- defs
+ VE.initial defs
+
+let arith_funs = [ "+"; "-"; "*"; "/"; "mod"; "uminus" ]
-let arith_funs = ["+";"-";"*";"/";"mod"; "uminus"]
-let bool_funs = ["&&";"||";"xor";"equi";"impl"; "not"]
-let rel_funs = ["<";">";"<=";">=";"!=";"="]
+let bool_funs = [ "&&"; "||"; "xor"; "equi"; "impl"; "not" ]
+
+let rel_funs = [ "<"; ">"; "<="; ">="; "!="; "=" ]
+
+let internal_funs = arith_funs @ bool_funs @ rel_funs
-let internal_funs = arith_funs@bool_funs@rel_funs
-
let rec is_internal_fun x targs =
-(*Format.eprintf "is_internal_fun %s %a@." x Types.print_ty (List.hd targs);*)
+ (*Format.eprintf "is_internal_fun %s %a@." x Types.print_ty (List.hd targs);*)
match targs with
- | [] -> assert false
- | t::_ when Types.is_real_type t -> List.mem x internal_funs && not !Options.mpfr
- | t::_ when Types.is_array_type t -> is_internal_fun x [Types.array_element_type t]
- | _ -> List.mem x internal_funs
+ | [] ->
+ assert false
+ | t :: _ when Types.is_real_type t ->
+ List.mem x internal_funs && not !Options.mpfr
+ | t :: _ when Types.is_array_type t ->
+ is_internal_fun x [ Types.array_element_type t ]
+ | _ ->
+ List.mem x internal_funs
let is_expr_internal_fun expr =
let open Lustre_types in
match expr.expr_desc with
- | Expr_appl (f, e, _) -> is_internal_fun f (Types.type_list_of_type e.expr_type)
- | _ -> assert false
+ | Expr_appl (f, e, _) ->
+ is_internal_fun f (Types.type_list_of_type e.expr_type)
+ | _ ->
+ assert false
let is_value_internal_fun v =
let open Machine_code_types in
match v.value_desc with
- | Fun (f, vl) -> is_internal_fun f (List.map (fun v -> v.value_type) vl)
- | _ -> assert false
-
-let is_numeric_operator x =
- List.mem x arith_funs
+ | Fun (f, vl) ->
+ is_internal_fun f (List.map (fun v -> v.value_type) vl)
+ | _ ->
+ assert false
-let is_homomorphic_fun x =
- List.mem x internal_funs
+let is_numeric_operator x = List.mem x arith_funs
-let is_stateless_fun x =
- List.mem x internal_funs
+let is_homomorphic_fun x = List.mem x internal_funs
+let is_stateless_fun x = List.mem x internal_funs
(* let pp_java i pp_val fmt vl = *)
(* match i, vl with *)
-(* (\* | "ite", [v1; v2; v3] -> Format.fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *\) *)
+(* (\* | "ite", [v1; v2; v3] -> Format.fprintf fmt "(%a?(%a):(%a))" pp_val v1
+ pp_val v2 pp_val v3 *\) *)
(* | "uminus", [v] -> Format.fprintf fmt "(- %a)" pp_val v *)
(* | "not", [v] -> Format.fprintf fmt "(!%a)" pp_val v *)
-(* | "impl", [v1; v2] -> Format.fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2 *)
-(* | "=", [v1; v2] -> Format.fprintf fmt "(%a == %a)" pp_val v1 pp_val v2 *)
-(* | "mod", [v1; v2] -> Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 *)
-(* | "equi", [v1; v2] -> Format.fprintf fmt "(%a == %a)" pp_val v1 pp_val v2 *)
-(* | "xor", [v1; v2] -> Format.fprintf fmt "(%a != %a)" pp_val v1 pp_val v2 *)
-(* | _, [v1; v2] -> Format.fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2 *)
-(* | _ -> (Format.eprintf "internal error: Basic_library.pp_java %s@." i; assert false) *)
+(* | "impl", [v1; v2] -> Format.fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2 *)
+(* | "=", [v1; v2] -> Format.fprintf fmt "(%a == %a)" pp_val v1 pp_val v2 *)
+(* | "mod", [v1; v2] -> Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 *)
+(* | "equi", [v1; v2] -> Format.fprintf fmt "(%a == %a)" pp_val v1 pp_val v2 *)
+(* | "xor", [v1; v2] -> Format.fprintf fmt "(%a != %a)" pp_val v1 pp_val v2 *)
+(* | _, [v1; v2] -> Format.fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2 *)
+(* | _ -> (Format.eprintf "internal error: Basic_library.pp_java %s@." i; assert
+ false) *)
let partial_eval op e opt =
let open Lustre_types in
let is_zero e =
match e.expr_desc with
- | Expr_const (Const_int 0) -> true
- | Expr_const (Const_real r) when Real.is_zero r -> true
- | _ -> false
+ | Expr_const (Const_int 0) ->
+ true
+ | Expr_const (Const_real r) when Real.is_zero r ->
+ true
+ | _ ->
+ false
in
let is_one e =
match e.expr_desc with
- | Expr_const (Const_int 1) -> true
- | Expr_const (Const_real r) when Real.is_one r -> true
- | _ -> false
+ | Expr_const (Const_int 1) ->
+ true
+ | Expr_const (Const_real r) when Real.is_one r ->
+ true
+ | _ ->
+ false
in
let is_true, is_false =
let is_tag t e = e.expr_desc = Expr_const (Const_tag t) in
is_tag tag_true, is_tag tag_false
in
- let int_arith_op, real_arith_op=
- let assoc op=
+ let int_arith_op, real_arith_op =
+ let assoc op =
match op with
- | "+" -> (+), Real.add
- | "-" -> (-), Real.minus
- | "*" -> ( * ), Real.times
- | "/" -> (/), Real.div
- | "mod" -> (mod), (fun _ _ -> assert false)
- | _ -> assert false
+ | "+" ->
+ ( + ), Real.add
+ | "-" ->
+ ( - ), Real.minus
+ | "*" ->
+ ( * ), Real.times
+ | "/" ->
+ ( / ), Real.div
+ | "mod" ->
+ ( mod ), fun _ _ -> assert false
+ | _ ->
+ assert false
in
- (fun op -> fst(assoc op)), (fun op -> snd(assoc op))
+ (fun op -> fst (assoc op)), fun op -> snd (assoc op)
in
let int_rel_op, real_rel_op =
let assoc op =
match op with
- | "<" -> (<), Real.lt
- |">" -> (>), Real.gt
- |"<="-> (<=), Real.le
- | ">=" -> (>=), Real.ge
- |"!=" -> (!=), Real.diseq
- |"=" -> (=), Real.eq
- | _ -> assert false
+ | "<" ->
+ ( < ), Real.lt
+ | ">" ->
+ ( > ), Real.gt
+ | "<=" ->
+ ( <= ), Real.le
+ | ">=" ->
+ ( >= ), Real.ge
+ | "!=" ->
+ ( != ), Real.diseq
+ | "=" ->
+ ( = ), Real.eq
+ | _ ->
+ assert false
in
- (fun op -> fst(assoc op)), (fun op -> snd(assoc op))
+ (fun op -> fst (assoc op)), fun op -> snd (assoc op)
in
- let eval_bool_fun op e1 e2 =
- let s2b s = if s= tag_true then true else if s=tag_false then false else assert false in
+ let eval_bool_fun op e1 e2 =
+ let s2b s =
+ if s = tag_true then true
+ else if s = tag_false then false
+ else assert false
+ in
let e1, e2 = s2b e1, s2b e2 in
let r =
match op with
- "&&" -> e1 && e2
- | "||" -> e1 || e2
- | "xor" -> (e1 && e2) || ((not e1) && (not e2))
- | "impl" -> (not e1) || e2
- | "equi" -> ((not e1) || e2) && ((not e2) || e1)
- | _ -> assert false
+ | "&&" ->
+ e1 && e2
+ | "||" ->
+ e1 || e2
+ | "xor" ->
+ (e1 && e2) || ((not e1) && not e2)
+ | "impl" ->
+ (not e1) || e2
+ | "equi" ->
+ ((not e1) || e2) && ((not e2) || e1)
+ | _ ->
+ assert false
in
if r then Const_tag tag_true else Const_tag tag_false
- in
- let is_const e =
- match e.expr_desc with Expr_const _ -> true | _ -> false
in
+ let is_const e = match e.expr_desc with Expr_const _ -> true | _ -> false in
let deconst e =
- match e.expr_desc with
- | Expr_const c -> c
- | _ -> assert false
+ match e.expr_desc with Expr_const c -> c | _ -> assert false
in
- match op, (match e.expr_desc with Expr_tuple el -> el | _ -> [e]) with
- | _, el when List.for_all is_const el -> (
- let new_cst =
+ match op, match e.expr_desc with Expr_tuple el -> el | _ -> [ e ] with
+ | _, el when List.for_all is_const el ->
+ let new_cst =
match op, List.map deconst el with
- | ("+"|"-"|"*"|"/"|"mod"), [Const_int c1; Const_int c2] ->
- Const_int (int_arith_op op c1 c2)
- | ("+"|"-"|"*"|"/"), [Const_real c1; Const_real c2] ->
- Const_real (real_arith_op op c1 c2)
- | "uminus", [Const_int c] -> Const_int (-c)
- | "uminus", [Const_real c] -> Const_real (Real.uminus c)
- | rel_fun, [Const_int c1; Const_int c2]
- when List.mem rel_fun rel_funs ->
- if int_rel_op op c1 c2 then
- Const_tag tag_true
- else
- Const_tag tag_false
- | rel_fun, [Const_real c1; Const_real c2]
- when List.mem rel_fun rel_funs ->
- if real_rel_op op c1 c2 then
- Const_tag tag_true
- else
- Const_tag tag_false
- | "=", [Const_tag t1; Const_tag t2]
- ->
- if t1 = t2 then
- Const_tag tag_true
- else
- Const_tag tag_false
- | "!=", [Const_tag t1; Const_tag t2]
- ->
- if t1 = t2 then
- Const_tag tag_false
- else
- Const_tag tag_true
- | "not", [Const_tag c] -> Const_tag( if c = tag_true then tag_false else if c = tag_false then tag_true else assert false)
- | bool_fun, [Const_tag c1; Const_tag c2]
- when List.mem bool_fun bool_funs ->
- eval_bool_fun bool_fun c1 c2
- | _ -> let loc= e.expr_loc in
- let err =Error.Unbound_symbol (op ^ (string_of_bool (List.mem op rel_funs)) ^ " in basic library") in
- raise (Error.Error (loc, err))
+ | ("+" | "-" | "*" | "/" | "mod"), [ Const_int c1; Const_int c2 ] ->
+ Const_int (int_arith_op op c1 c2)
+ | ("+" | "-" | "*" | "/"), [ Const_real c1; Const_real c2 ] ->
+ Const_real (real_arith_op op c1 c2)
+ | "uminus", [ Const_int c ] ->
+ Const_int (-c)
+ | "uminus", [ Const_real c ] ->
+ Const_real (Real.uminus c)
+ | rel_fun, [ Const_int c1; Const_int c2 ] when List.mem rel_fun rel_funs
+ ->
+ if int_rel_op op c1 c2 then Const_tag tag_true else Const_tag tag_false
+ | rel_fun, [ Const_real c1; Const_real c2 ] when List.mem rel_fun rel_funs
+ ->
+ if real_rel_op op c1 c2 then Const_tag tag_true else Const_tag tag_false
+ | "=", [ Const_tag t1; Const_tag t2 ] ->
+ if t1 = t2 then Const_tag tag_true else Const_tag tag_false
+ | "!=", [ Const_tag t1; Const_tag t2 ] ->
+ if t1 = t2 then Const_tag tag_false else Const_tag tag_true
+ | "not", [ Const_tag c ] ->
+ Const_tag
+ (if c = tag_true then tag_false
+ else if c = tag_false then tag_true
+ else assert false)
+ | bool_fun, [ Const_tag c1; Const_tag c2 ]
+ when List.mem bool_fun bool_funs ->
+ eval_bool_fun bool_fun c1 c2
+ | _ ->
+ let loc = e.expr_loc in
+ let err =
+ Error.Unbound_symbol
+ (op ^ string_of_bool (List.mem op rel_funs) ^ " in basic library")
+ in
+ raise (Error.Error (loc, err))
in
- Expr_const new_cst
- )
- | op, el -> ( (* at least one of the arguments is non constant *)
+ Expr_const new_cst
+ | op, el -> (
+ (* at least one of the arguments is non constant *)
match op, el with
- | "+", [e0; e] when is_zero e0 ->
- e.expr_desc
- | "+", [e; e0] when is_zero e0 ->
- e.expr_desc
- | "-", [e; e0] when is_zero e0 ->
- e.expr_desc
- | "-", [e0; e] when is_zero e0 ->
- Expr_appl("uminus", e, None)
- | ("*"|"/"), [e0; _] when is_zero e0 -> e0.expr_desc
- | "*", [_; e0] when is_zero e0 -> e0.expr_desc
- | "*", [e1; e] when is_one e1 -> e.expr_desc
- | "/", [e; e1] when is_one e1 -> e.expr_desc
- | "&&", [efalse; _] when is_false efalse ->
- Expr_const (Const_tag tag_false)
- | "&&", [_; efalse] when is_false efalse ->
- Expr_const (Const_tag tag_false)
- | "||", [etrue; _] when is_true etrue ->
- Expr_const (Const_tag tag_true)
- | "||", [_; etrue] when is_true etrue ->
- Expr_const (Const_tag tag_true)
- | "impl", [efalse; _] when is_false efalse ->
- Expr_const (Const_tag tag_true)
+ | "+", [ e0; e ] when is_zero e0 ->
+ e.expr_desc
+ | "+", [ e; e0 ] when is_zero e0 ->
+ e.expr_desc
+ | "-", [ e; e0 ] when is_zero e0 ->
+ e.expr_desc
+ | "-", [ e0; e ] when is_zero e0 ->
+ Expr_appl ("uminus", e, None)
+ | ("*" | "/"), [ e0; _ ] when is_zero e0 ->
+ e0.expr_desc
+ | "*", [ _; e0 ] when is_zero e0 ->
+ e0.expr_desc
+ | "*", [ e1; e ] when is_one e1 ->
+ e.expr_desc
+ | "/", [ e; e1 ] when is_one e1 ->
+ e.expr_desc
+ | "&&", [ efalse; _ ] when is_false efalse ->
+ Expr_const (Const_tag tag_false)
+ | "&&", [ _; efalse ] when is_false efalse ->
+ Expr_const (Const_tag tag_false)
+ | "||", [ etrue; _ ] when is_true etrue ->
+ Expr_const (Const_tag tag_true)
+ | "||", [ _; etrue ] when is_true etrue ->
+ Expr_const (Const_tag tag_true)
+ | "impl", [ efalse; _ ] when is_false efalse ->
+ Expr_const (Const_tag tag_true)
| _ ->
- Expr_appl(op, e, opt)
- )
- (* Local Variables: *)
- (* compile-command:"make -C .." *)
- (* End: *)
+ Expr_appl (op, e, opt))
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
let _ =
(* Loading environement *)
diff --git a/src/causality.ml b/src/causality.ml
index 9e8696adb9006358460b5f55cbd62831d2dfa275..643f4fc4226210c9b6aa7e6ab3fa60a539803530 100644
--- a/src/causality.ml
+++ b/src/causality.ml
@@ -6,114 +6,102 @@
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)
(* under the terms of the GNU Lesser General Public License *)
(* version 2.1. *)
-(* *)
+(* *)
(* This file was originally from the Prelude compiler *)
-(* *)
+(* *)
(********************************************************************)
-
-(** Simple modular syntactic causality analysis. Can reject correct
- programs, especially if the program is not flattened first. *)
open Utils
+(** Simple modular syntactic causality analysis. Can reject correct programs,
+ especially if the program is not flattened first. *)
+
open Lustre_types
open Corelang
-
type identified_call = eq * tag
+
type error =
- | DataCycle of ident list list (* multiple failed partitions at once *)
+ | DataCycle of ident list list
+ (* multiple failed partitions at once *)
| NodeCycle of ident list
exception Error of error
+(* Dependency of mem variables on mem variables is cut off by duplication of
+ some mem vars into local node vars. Thus, cylic dependency errors may only
+ arise between no-mem vars. non-mem variables are: - constants/inputs: not
+ needed for causality/scheduling, needed only for detecting useless vars -
+ read mems (fake vars): same remark as above. - outputs: decoupled from mems,
+ if necessary - locals - instance vars (fake vars): simplify causality
+ analysis
-
-(* Dependency of mem variables on mem variables is cut off
- by duplication of some mem vars into local node vars.
- Thus, cylic dependency errors may only arise between no-mem vars.
- non-mem variables are:
- - constants/inputs: not needed for causality/scheduling, needed only for detecting useless vars
- - read mems (fake vars): same remark as above.
- - outputs: decoupled from mems, if necessary
- - locals
- - instance vars (fake vars): simplify causality analysis
-
global constants are not part of the dependency graph.
-
- no_mem' = combinational(no_mem, mem);
- => (mem -> no_mem' -> no_mem)
-
- mem' = pre(no_mem, mem);
- => (mem' -> no_mem), (mem -> mem')
-
- Global roadmap:
- - compute two dep graphs g (non-mem/non-mem&mem) and g' (mem/mem)
- - check cycles in g (a cycle means a dependency error)
- - break cycles in g' (it's legal !):
- - check cycles in g'
- - if any, introduce aux var to break cycle, then start afresh
- - insert g' into g
- - return g
-*)
+
+ no_mem' = combinational(no_mem, mem); => (mem -> no_mem' -> no_mem)
+
+ mem' = pre(no_mem, mem); => (mem' -> no_mem), (mem -> mem')
+
+ Global roadmap: - compute two dep graphs g (non-mem/non-mem&mem) and g'
+ (mem/mem) - check cycles in g (a cycle means a dependency error) - break
+ cycles in g' (it's legal !): - check cycles in g' - if any, introduce aux var
+ to break cycle, then start afresh - insert g' into g - return g *)
(* Tests whether [v] is a root of graph [g], i.e. a source *)
-let is_graph_root v g =
- IdentDepGraph.in_degree g v = 0
+let is_graph_root v g = IdentDepGraph.in_degree g v = 0
(* Computes the set of graph roots, i.e. the sources of acyclic graph [g] *)
let graph_roots g =
IdentDepGraph.fold_vertex
- (fun v roots -> if is_graph_root v g then v::roots else roots)
+ (fun v roots -> if is_graph_root v g then v :: roots else roots)
g []
let add_edges src tgt g =
- (*List.iter (fun s -> List.iter (fun t -> Format.eprintf "add %s -> %s@." s t) tgt) src;*)
- List.iter
- (fun s -> List.iter (IdentDepGraph.add_edge g s) tgt)
- src;
+ (*List.iter (fun s -> List.iter (fun t -> Format.eprintf "add %s -> %s@." s t)
+ tgt) src;*)
+ List.iter (fun s -> List.iter (IdentDepGraph.add_edge g s) tgt) src;
g
let add_vertices vtc g =
- (*List.iter (fun t -> Format.eprintf "add %s@." t) vtc;*)
+ (*List.iter (fun t -> Format.eprintf "add %s@." t) vtc;*)
List.iter (fun v -> IdentDepGraph.add_vertex g v) vtc;
g
-let new_graph () =
- IdentDepGraph.create ()
+let new_graph () = IdentDepGraph.create ()
(* keep subgraph of [gr] consisting of nodes accessible from node [v] *)
let slice_graph gr v =
- begin
- let gr' = new_graph () in
- IdentDepGraph.add_vertex gr' v;
- Bfs.iter_component (fun v -> IdentDepGraph.iter_succ (fun s -> IdentDepGraph.add_vertex gr' s; IdentDepGraph.add_edge gr' v s) gr v) gr v;
- gr'
- end
+ let gr' = new_graph () in
+ IdentDepGraph.add_vertex gr' v;
+ Bfs.iter_component
+ (fun v ->
+ IdentDepGraph.iter_succ
+ (fun s ->
+ IdentDepGraph.add_vertex gr' s;
+ IdentDepGraph.add_edge gr' v s)
+ gr v)
+ gr v;
+ gr'
-
module ExprDep = struct
let get_node_eqs nd =
let eqs, auts = get_node_eqs nd in
- if auts != [] then assert false (* No call on causality on a Lustre model
- with automaton. They should be expanded by now. *);
+ if auts != [] then assert false
+ (* No call on causality on a Lustre model with automaton. They should be
+ expanded by now. *);
eqs
-
+
let instance_var_cpt = ref 0
-(* read vars represent input/mem read-only vars,
- they are not part of the program/schedule,
- as they are not assigned,
- but used to compute useless inputs/mems.
- a mem read var represents a mem at the beginning of a cycle *)
- let mk_read_var id =
- Format.sprintf "#%s" id
-
-(* instance vars represent node instance calls,
- they are not part of the program/schedule,
- but used to simplify causality analysis
-*)
+ (* read vars represent input/mem read-only vars, they are not part of the
+ program/schedule, as they are not assigned, but used to compute useless
+ inputs/mems. a mem read var represents a mem at the beginning of a cycle *)
+ let mk_read_var id = Format.sprintf "#%s" id
+
+ (* instance vars represent node instance calls, they are not part of the
+ program/schedule, but used to simplify causality analysis *)
let mk_instance_var id =
- incr instance_var_cpt; Format.sprintf "!%s_%d" id !instance_var_cpt
+ incr instance_var_cpt;
+ Format.sprintf "!%s_%d" id !instance_var_cpt
let is_read_var v = v.[0] = '#'
@@ -132,230 +120,282 @@ module ExprDep = struct
let eq_memory_variables mems eq =
let rec match_mem lhs rhs mems =
match rhs.expr_desc with
- | Expr_fby _
- | Expr_pre _ -> List.fold_right ISet.add lhs mems
- | Expr_tuple tl ->
- let lhs' = (transpose_list [lhs]) in
- List.fold_right2 match_mem lhs' tl mems
- | _ -> mems in
+ | Expr_fby _ | Expr_pre _ ->
+ List.fold_right ISet.add lhs mems
+ | Expr_tuple tl ->
+ let lhs' = transpose_list [ lhs ] in
+ List.fold_right2 match_mem lhs' tl mems
+ | _ ->
+ mems
+ in
match_mem eq.eq_lhs eq.eq_rhs mems
let node_memory_variables nd =
List.fold_left eq_memory_variables ISet.empty (get_node_eqs nd)
let node_input_variables nd =
- List.fold_left (fun inputs v -> ISet.add v.var_id inputs) ISet.empty
- (if nd.node_iscontract then
- nd.node_inputs@nd.node_outputs
- else
- nd.node_inputs)
-
+ List.fold_left
+ (fun inputs v -> ISet.add v.var_id inputs)
+ ISet.empty
+ (if nd.node_iscontract then nd.node_inputs @ nd.node_outputs
+ else nd.node_inputs)
+
let node_output_variables nd =
- List.fold_left (fun outputs v -> ISet.add v.var_id outputs) ISet.empty
+ List.fold_left
+ (fun outputs v -> ISet.add v.var_id outputs)
+ ISet.empty
(if nd.node_iscontract then [] else nd.node_outputs)
let node_local_variables nd =
- List.fold_left (fun locals v -> ISet.add v.var_id locals) ISet.empty nd.node_locals
+ List.fold_left
+ (fun locals v -> ISet.add v.var_id locals)
+ ISet.empty nd.node_locals
let node_constant_variables nd =
- List.fold_left (fun locals v -> if v.var_dec_const then ISet.add v.var_id locals else locals) ISet.empty nd.node_locals
+ List.fold_left
+ (fun locals v ->
+ if v.var_dec_const then ISet.add v.var_id locals else locals)
+ ISet.empty nd.node_locals
let node_auxiliary_variables nd =
ISet.diff (node_local_variables nd) (node_memory_variables nd)
let node_variables nd =
let inputs = node_input_variables nd in
- let inoutputs = List.fold_left (fun inoutputs v -> ISet.add v.var_id inoutputs) inputs nd.node_outputs in
- List.fold_left (fun vars v -> ISet.add v.var_id vars) inoutputs nd.node_locals
+ let inoutputs =
+ List.fold_left
+ (fun inoutputs v -> ISet.add v.var_id inoutputs)
+ inputs nd.node_outputs
+ in
+ List.fold_left
+ (fun vars v -> ISet.add v.var_id vars)
+ inoutputs nd.node_locals
-(* computes the equivalence relation relating variables
- in the same equation lhs, under the form of a table
- of class representatives *)
+ (* computes the equivalence relation relating variables in the same equation
+ lhs, under the form of a table of class representatives *)
let eqs_eq_equiv eqs =
let eq_equiv = Hashtbl.create 23 in
- List.iter (fun eq ->
- let first = List.hd eq.eq_lhs in
- List.iter (fun v -> Hashtbl.add eq_equiv v first) eq.eq_lhs
- )
+ List.iter
+ (fun eq ->
+ let first = List.hd eq.eq_lhs in
+ List.iter (fun v -> Hashtbl.add eq_equiv v first) eq.eq_lhs)
eqs;
eq_equiv
-
- let node_eq_equiv nd = eqs_eq_equiv (get_node_eqs nd)
-
-(* Create a tuple of right dimension, according to [expr] type, *)
-(* filled with variable [v] *)
+
+ let node_eq_equiv nd = eqs_eq_equiv (get_node_eqs nd)
+
+ (* Create a tuple of right dimension, according to [expr] type, *)
+ (* filled with variable [v] *)
let adjust_tuple v expr =
match expr.expr_type.Types.tdesc with
- | Types.Ttuple tl -> duplicate v (List.length tl)
- | _ -> [v]
-
+ | Types.Ttuple tl ->
+ duplicate v (List.length tl)
+ | _ ->
+ [ v ]
(* Add dependencies from lhs to rhs in [g, g'], *)
(* no-mem/no-mem and mem/no-mem in g *)
(* mem/mem in g' *)
- (* match (lhs_is_mem, ISet.mem x mems) with
- | (false, true ) -> (add_edges [x] lhs g,
- g')
- | (false, false) -> (add_edges lhs [x] g,
- g')
- | (true , false) -> (add_edges lhs [x] g,
- g')
- | (true , true ) -> (g,
- add_edges [x] lhs g')
- *)
+ (* match (lhs_is_mem, ISet.mem x mems) with | (false, true ) -> (add_edges [x]
+ lhs g, g') | (false, false) -> (add_edges lhs [x] g, g') | (true , false)
+ -> (add_edges lhs [x] g, g') | (true , true ) -> (g, add_edges [x] lhs g') *)
let add_eq_dependencies mems inputs node_vars eq (g, g') =
let add_var lhs_is_mem lhs x (g, g') =
if is_instance_var x || ISet.mem x node_vars then
- if ISet.mem x mems
- then
- let g = add_edges lhs [mk_read_var x] g in
- if lhs_is_mem
- then
- (g, add_edges [x] lhs g')
- else
- (add_edges [x] lhs g, g')
+ if ISet.mem x mems then
+ let g = add_edges lhs [ mk_read_var x ] g in
+ if lhs_is_mem then g, add_edges [ x ] lhs g'
+ else add_edges [ x ] lhs g, g'
else
let x = if ISet.mem x inputs then mk_read_var x else x in
- (add_edges lhs [x] g, g')
- else (add_edges lhs [mk_read_var x] g, g') (* x is a global constant, treated as a read var *)
+ add_edges lhs [ x ] g, g'
+ else add_edges lhs [ mk_read_var x ] g, g'
+ (* x is a global constant, treated as a read var *)
in
(* Add dependencies from [lhs] to rhs clock [ck]. *)
let rec add_clock lhs_is_mem lhs ck g =
(*Format.eprintf "add_clock %a@." Clocks.print_ck ck;*)
match (Clocks.repr ck).Clocks.cdesc with
- | Clocks.Con (ck', cr, _) ->
- add_var lhs_is_mem lhs (Clocks.const_of_carrier cr)
+ | Clocks.Con (ck', cr, _) ->
+ add_var lhs_is_mem lhs
+ (Clocks.const_of_carrier cr)
(add_clock lhs_is_mem lhs ck' g)
| Clocks.Ccarrying (_, ck') ->
add_clock lhs_is_mem lhs ck' g
- | _ -> g
+ | _ ->
+ g
in
let rec add_dep lhs_is_mem lhs rhs g =
(* Add mashup dependencies for a user-defined node instance [lhs] = [f]([e]) *)
(* i.e every input is connected to every output, through a ghost var *)
let mashup_appl_dependencies f e g =
- let f_var = mk_instance_var (Format.sprintf "%s_%d" f (fst eq.eq_loc).Lexing.pos_lnum) in
- List.fold_right (fun rhs -> add_dep lhs_is_mem (adjust_tuple f_var rhs) rhs)
- (expr_list_of_expr e) (add_var lhs_is_mem lhs f_var g)
+ let f_var =
+ mk_instance_var
+ (Format.sprintf "%s_%d" f (fst eq.eq_loc).Lexing.pos_lnum)
+ in
+ List.fold_right
+ (fun rhs -> add_dep lhs_is_mem (adjust_tuple f_var rhs) rhs)
+ (expr_list_of_expr e)
+ (add_var lhs_is_mem lhs f_var g)
in
let g = add_clock lhs_is_mem lhs rhs.expr_clock g in
match rhs.expr_desc with
- | Expr_const _ -> g
- | Expr_fby (e1, e2) -> add_dep true lhs e2 (add_dep false lhs e1 g)
- | Expr_pre e -> add_dep true lhs e g
- | Expr_ident x -> add_var lhs_is_mem lhs x g
- | Expr_access (e1, d)
- | Expr_power (e1, d) -> add_dep lhs_is_mem lhs e1 (add_dep lhs_is_mem lhs (expr_of_dimension d) g)
- | Expr_array a -> List.fold_right (add_dep lhs_is_mem lhs) a g
- | Expr_tuple t -> List.fold_right2 (fun l r -> add_dep lhs_is_mem [l] r) lhs t g
- | Expr_merge (c, hl) -> add_var lhs_is_mem lhs c (List.fold_right (fun (_, h) -> add_dep lhs_is_mem lhs h) hl g)
- | Expr_ite (c, t, e) -> add_dep lhs_is_mem lhs c (add_dep lhs_is_mem lhs t (add_dep lhs_is_mem lhs e g))
- | Expr_arrow (e1, e2) -> add_dep lhs_is_mem lhs e2 (add_dep lhs_is_mem lhs e1 g)
- | Expr_when (e, c, _) -> add_dep lhs_is_mem lhs e (add_var lhs_is_mem lhs c g)
+ | Expr_const _ ->
+ g
+ | Expr_fby (e1, e2) ->
+ add_dep true lhs e2 (add_dep false lhs e1 g)
+ | Expr_pre e ->
+ add_dep true lhs e g
+ | Expr_ident x ->
+ add_var lhs_is_mem lhs x g
+ | Expr_access (e1, d) | Expr_power (e1, d) ->
+ add_dep lhs_is_mem lhs e1
+ (add_dep lhs_is_mem lhs (expr_of_dimension d) g)
+ | Expr_array a ->
+ List.fold_right (add_dep lhs_is_mem lhs) a g
+ | Expr_tuple t ->
+ List.fold_right2 (fun l r -> add_dep lhs_is_mem [ l ] r) lhs t g
+ | Expr_merge (c, hl) ->
+ add_var lhs_is_mem lhs c
+ (List.fold_right (fun (_, h) -> add_dep lhs_is_mem lhs h) hl g)
+ | Expr_ite (c, t, e) ->
+ add_dep lhs_is_mem lhs c
+ (add_dep lhs_is_mem lhs t (add_dep lhs_is_mem lhs e g))
+ | Expr_arrow (e1, e2) ->
+ add_dep lhs_is_mem lhs e2 (add_dep lhs_is_mem lhs e1 g)
+ | Expr_when (e, c, _) ->
+ add_dep lhs_is_mem lhs e (add_var lhs_is_mem lhs c g)
| Expr_appl (f, e, None) ->
- if Basic_library.is_expr_internal_fun rhs
- (* tuple component-wise dependency for internal operators *)
- then
- List.fold_right (add_dep lhs_is_mem lhs) (expr_list_of_expr e) g
+ if
+ Basic_library.is_expr_internal_fun rhs
+ (* tuple component-wise dependency for internal operators *)
+ then List.fold_right (add_dep lhs_is_mem lhs) (expr_list_of_expr e) g
(* mashed up dependency for user-defined operators *)
- else
- mashup_appl_dependencies f e g
+ else mashup_appl_dependencies f e g
| Expr_appl (f, e, Some c) ->
mashup_appl_dependencies f e (add_dep lhs_is_mem lhs c g)
in
- let g = List.fold_left (fun g lhs ->
- if ISet.mem lhs mems then
- add_vertices [lhs; mk_read_var lhs] g
- else
- add_vertices [lhs] g)
- g eq.eq_lhs
+ let g =
+ List.fold_left
+ (fun g lhs ->
+ if ISet.mem lhs mems then add_vertices [ lhs; mk_read_var lhs ] g
+ else add_vertices [ lhs ] g)
+ g eq.eq_lhs
in
add_dep false eq.eq_lhs eq.eq_rhs (g, g')
-
(* Returns the dependence graph for node [n] *)
let dependence_graph mems inputs node_vars n =
instance_var_cpt := 0;
let g = new_graph (), new_graph () in
(* Basic dependencies *)
- let g = List.fold_right (add_eq_dependencies mems inputs node_vars)
- (get_node_eqs n) g in
+ let g =
+ List.fold_right
+ (add_eq_dependencies mems inputs node_vars)
+ (get_node_eqs n) g
+ in
+
(* TODO Xavier: un essai ci dessous. Ca n'a pas l'air de résoudre le pb. Il
- faut imposer que les outputs dépendent des asserts pour identifier que les
- fcn calls des asserts sont évalués avant le noeuds *)
-
- (* (\* In order to introduce dependencies between assert expressions and the node, *)
- (* we build an artificial dependency between node output and each assert *)
- (* expr. While these are not valid equations, they should properly propage in *)
+ faut imposer que les outputs dépendent des asserts pour identifier que
+ les fcn calls des asserts sont évalués avant le noeuds *)
+
+ (* (\* In order to introduce dependencies between assert expressions and the
+ node, *)
+ (* we build an artificial dependency between node output and each assert *)
+ (* expr. While these are not valid equations, they should properly propage
+ in *)
(* function add_eq_dependencies *\) *)
(* let g = *)
(* let output_vars_as_lhs = ISet.elements (node_output_variables n) in *)
(* List.fold_left (fun g ae -> *)
- (* let fake_eq = mkeq Location.dummy_loc (output_vars_as_lhs, ae.assert_expr) in *)
+ (* let fake_eq = mkeq Location.dummy_loc (output_vars_as_lhs,
+ ae.assert_expr) in *)
(* add_eq_dependencies mems inputs node_vars fake_eq g *)
(* ) g n.node_asserts in *)
g
-
end
module NodeDep = struct
-
- module ExprModule =
- struct
+ module ExprModule = struct
type t = expr
+
let compare = compare
+
let hash n = Hashtbl.hash n
+
let equal n1 n2 = n1 = n2
end
- module ESet = Set.Make(ExprModule)
+ module ESet = Set.Make (ExprModule)
- let rec get_expr_calls prednode expr =
+ let rec get_expr_calls prednode expr =
match expr.expr_desc with
- | Expr_const _
- | Expr_ident _ -> ESet.empty
- | Expr_access (e, _)
- | Expr_power (e, _) -> get_expr_calls prednode e
- | Expr_array t
- | Expr_tuple t -> List.fold_right (fun x set -> ESet.union (get_expr_calls prednode x) set) t ESet.empty
- | Expr_merge (_,hl) -> List.fold_right (fun (_,h) set -> ESet.union (get_expr_calls prednode h) set) hl ESet.empty
- | Expr_fby (e1,e2)
- | Expr_arrow (e1,e2) -> ESet.union (get_expr_calls prednode e1) (get_expr_calls prednode e2)
- | Expr_ite (c, t, e) -> ESet.union (get_expr_calls prednode c) (ESet.union (get_expr_calls prednode t) (get_expr_calls prednode e))
- | Expr_pre e
- | Expr_when (e,_,_) -> get_expr_calls prednode e
- | Expr_appl (id,e, _) ->
- if not (Basic_library.is_expr_internal_fun expr) && prednode id
- then ESet.add expr (get_expr_calls prednode e)
- else (get_expr_calls prednode e)
-
- let get_eexpr_calls prednode ee =
- get_expr_calls prednode ee.eexpr_qfexpr
-
+ | Expr_const _ | Expr_ident _ ->
+ ESet.empty
+ | Expr_access (e, _) | Expr_power (e, _) ->
+ get_expr_calls prednode e
+ | Expr_array t | Expr_tuple t ->
+ List.fold_right
+ (fun x set -> ESet.union (get_expr_calls prednode x) set)
+ t ESet.empty
+ | Expr_merge (_, hl) ->
+ List.fold_right
+ (fun (_, h) set -> ESet.union (get_expr_calls prednode h) set)
+ hl ESet.empty
+ | Expr_fby (e1, e2) | Expr_arrow (e1, e2) ->
+ ESet.union (get_expr_calls prednode e1) (get_expr_calls prednode e2)
+ | Expr_ite (c, t, e) ->
+ ESet.union
+ (get_expr_calls prednode c)
+ (ESet.union (get_expr_calls prednode t) (get_expr_calls prednode e))
+ | Expr_pre e | Expr_when (e, _, _) ->
+ get_expr_calls prednode e
+ | Expr_appl (id, e, _) ->
+ if (not (Basic_library.is_expr_internal_fun expr)) && prednode id then
+ ESet.add expr (get_expr_calls prednode e)
+ else get_expr_calls prednode e
+
+ let get_eexpr_calls prednode ee = get_expr_calls prednode ee.eexpr_qfexpr
+
let get_callee expr =
match expr.expr_desc with
- | Expr_appl (id, args, _) -> Some (id, expr_list_of_expr args)
- | _ -> None
+ | Expr_appl (id, args, _) ->
+ Some (id, expr_list_of_expr args)
+ | _ ->
+ None
- let accu f init objl = List.fold_left (fun accu o -> ESet.union accu (f o)) init objl
+ let accu f init objl =
+ List.fold_left (fun accu o -> ESet.union accu (f o)) init objl
let get_eq_calls prednode eq = get_expr_calls prednode eq.eq_rhs
-
+
let rec get_stmt_calls prednode s =
- match s with Eq eq -> get_eq_calls prednode eq | Aut aut -> get_aut_calls prednode aut
+ match s with
+ | Eq eq ->
+ get_eq_calls prednode eq
+ | Aut aut ->
+ get_aut_calls prednode aut
+
and get_aut_calls prednode aut =
let get_handler_calls prednode h =
- let get_cond_calls c = accu (fun (_,e,_,_) -> get_expr_calls prednode e) ESet.empty c in
+ let get_cond_calls c =
+ accu (fun (_, e, _, _) -> get_expr_calls prednode e) ESet.empty c
+ in
let until = get_cond_calls h.hand_until in
let unless = get_cond_calls h.hand_unless in
- let calls = ESet.union until unless in
+ let calls = ESet.union until unless in
let calls = accu (get_stmt_calls prednode) calls h.hand_stmts in
- let calls = accu (fun a -> get_expr_calls prednode a.assert_expr) calls h.hand_asserts in
- (* let calls = accu xx calls h.hand_annots in *) (* TODO: search for calls in eexpr *)
+ let calls =
+ accu
+ (fun a -> get_expr_calls prednode a.assert_expr)
+ calls h.hand_asserts
+ in
+ (* let calls = accu xx calls h.hand_annots in *)
+ (* TODO: search for calls in eexpr *)
calls
in
accu (get_handler_calls prednode) ESet.empty aut.aut_handlers
-
+
let get_calls prednode nd =
let eqs, auts = get_node_eqs nd in
let deps = accu (get_eq_calls prednode) ESet.empty eqs in
@@ -364,343 +404,380 @@ module NodeDep = struct
let get_contract_calls prednode c =
let deps = accu (get_stmt_calls prednode) ESet.empty c.stmts in
- let deps = accu (get_eexpr_calls prednode) deps ( c.assume @ c.guarantees @ (List.fold_left (fun accu m -> accu @ m.require @ m.ensure ) [] c.modes)) in
- let id_deps = List.map (fun e -> fst (desome (get_callee e))) (ESet.elements deps) in
- let id_deps = (List.fold_left (fun accu imp -> imp.import_nodeid::accu) [] c.imports) @ id_deps in
+ let deps =
+ accu (get_eexpr_calls prednode) deps
+ (c.assume @ c.guarantees
+ @ List.fold_left (fun accu m -> accu @ m.require @ m.ensure) [] c.modes
+ )
+ in
+ let id_deps =
+ List.map (fun e -> fst (desome (get_callee e))) (ESet.elements deps)
+ in
+ let id_deps =
+ List.fold_left (fun accu imp -> imp.import_nodeid :: accu) [] c.imports
+ @ id_deps
+ in
id_deps
-
+
let dependence_graph prog =
let g = new_graph () in
- let g = List.fold_right
- (fun td accu -> (* for each node we add its dependencies *)
- match td.top_decl_desc with
- | Node nd ->
- (*Format.eprintf "Computing deps of node %s@.@?" nd.node_id; *)
- let accu = add_vertices [nd.node_id] accu in
- let deps = List.map
- (fun e -> fst (desome (get_callee e)))
- (get_calls (fun _ -> true) nd)
- in
- (* Adding assert expressions deps *)
- let deps_asserts =
- let prednode = (fun _ -> true) in (* what is this about? *)
- List.map
- (fun e -> fst (desome (get_callee e)))
- (ESet.elements
- (List.fold_left
- (fun accu assert_expr -> ESet.union accu (get_expr_calls prednode assert_expr))
- ESet.empty
- (List.map (fun _assert -> _assert.assert_expr) nd.node_asserts)
- )
- )
- in
- let deps_spec = match nd.node_spec with
- | None -> []
- | Some (NodeSpec id) -> [id]
- | Some (Contract c) -> get_contract_calls (fun _ -> true) c
-
- in
- (*Format.eprintf "%a@.@?" (Utils.fprintf_list ~sep:"@." Format.pp_print_string) deps; *)
- add_edges [nd.node_id] (deps@deps_asserts@deps_spec) accu
- | _ -> assert false (* should not happen *)
-
- ) prog g in
- g
-
+ let g =
+ List.fold_right
+ (fun td accu ->
+ (* for each node we add its dependencies *)
+ match td.top_decl_desc with
+ | Node nd ->
+ (*Format.eprintf "Computing deps of node %s@.@?" nd.node_id; *)
+ let accu = add_vertices [ nd.node_id ] accu in
+ let deps =
+ List.map
+ (fun e -> fst (desome (get_callee e)))
+ (get_calls (fun _ -> true) nd)
+ in
+ (* Adding assert expressions deps *)
+ let deps_asserts =
+ let prednode _ = true in
+ (* what is this about? *)
+ List.map
+ (fun e -> fst (desome (get_callee e)))
+ (ESet.elements
+ (List.fold_left
+ (fun accu assert_expr ->
+ ESet.union accu (get_expr_calls prednode assert_expr))
+ ESet.empty
+ (List.map
+ (fun _assert -> _assert.assert_expr)
+ nd.node_asserts)))
+ in
+ let deps_spec =
+ match nd.node_spec with
+ | None ->
+ []
+ | Some (NodeSpec id) ->
+ [ id ]
+ | Some (Contract c) ->
+ get_contract_calls (fun _ -> true) c
+ in
+
+ (*Format.eprintf "%a@.@?" (Utils.fprintf_list ~sep:"@."
+ Format.pp_print_string) deps; *)
+ add_edges [ nd.node_id ] (deps @ deps_asserts @ deps_spec) accu
+ | _ ->
+ assert false
+ (* should not happen *))
+ prog g
+ in
+ g
+
let rec filter_static_inputs inputs args =
match inputs, args with
- | [] , [] -> []
- | v::vq, a::aq -> if v.var_dec_const && Types.is_dimension_type v.var_type then (dimension_of_expr a) :: filter_static_inputs vq aq else filter_static_inputs vq aq
- | _ -> assert false
+ | [], [] ->
+ []
+ | v :: vq, a :: aq ->
+ if v.var_dec_const && Types.is_dimension_type v.var_type then
+ dimension_of_expr a :: filter_static_inputs vq aq
+ else filter_static_inputs vq aq
+ | _ ->
+ assert false
let compute_generic_calls prog =
List.iter
(fun td ->
- match td.top_decl_desc with
- | Node nd ->
- let prednode n = is_generic_node (node_from_name n) in
- nd.node_gencalls <- get_calls prednode nd
- | _ -> ()
-
- ) prog
-
+ match td.top_decl_desc with
+ | Node nd ->
+ let prednode n = is_generic_node (node_from_name n) in
+ nd.node_gencalls <- get_calls prednode nd
+ | _ ->
+ ())
+ prog
end
-
module CycleDetection = struct
-
(* ---- Look for cycles in a dependency graph *)
module Cycles = Graph.Components.Make (IdentDepGraph)
let mk_copy_var n id =
let used name =
- (List.exists (fun v -> v.var_id = name) n.node_locals)
- || (List.exists (fun v -> v.var_id = name) n.node_inputs)
- || (List.exists (fun v -> v.var_id = name) n.node_outputs)
- in mk_new_name used id
+ List.exists (fun v -> v.var_id = name) n.node_locals
+ || List.exists (fun v -> v.var_id = name) n.node_inputs
+ || List.exists (fun v -> v.var_id = name) n.node_outputs
+ in
+ mk_new_name used id
let mk_copy_eq n var =
let var_decl = get_node_var var n in
let cp_var = mk_copy_var n var in
let expr =
- { expr_tag = Utils.new_tag ();
- expr_desc = Expr_ident var;
- expr_type = var_decl.var_type;
- expr_clock = var_decl.var_clock;
- expr_delay = Delay.new_var ();
- expr_annot = None;
- expr_loc = var_decl.var_loc } in
- { var_decl with var_id = cp_var; var_orig = false },
- mkeq var_decl.var_loc ([cp_var], expr)
+ {
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_ident var;
+ expr_type = var_decl.var_type;
+ expr_clock = var_decl.var_clock;
+ expr_delay = Delay.new_var ();
+ expr_annot = None;
+ expr_loc = var_decl.var_loc;
+ }
+ in
+ ( { var_decl with var_id = cp_var; var_orig = false },
+ mkeq var_decl.var_loc ([ cp_var ], expr) )
let wrong_partition g partition =
match partition with
- | [id] -> IdentDepGraph.mem_edge g id id
- | _::_::_ -> true
- | [] -> assert false
+ | [ id ] ->
+ IdentDepGraph.mem_edge g id id
+ | _ :: _ :: _ ->
+ true
+ | [] ->
+ assert false
(* Checks that the dependency graph [g] does not contain a cycle. Raises
- [Cycle partition] if the succession of dependencies [partition] forms a cycle *)
+ [Cycle partition] if the succession of dependencies [partition] forms a
+ cycle *)
let check_cycles g =
let scc_l = Cycles.scc_list g in
let algebraic_loops = List.filter (wrong_partition g) scc_l in
if List.length algebraic_loops > 0 then
raise (Error (DataCycle algebraic_loops))
- (* We extract a hint to resolve the cycle: for each variable in the cycle
- which is defined by a call, we return the name of the node call and
- its specific id *)
+ (* We extract a hint to resolve the cycle: for each variable in the cycle
+ which is defined by a call, we return the name of the node call and its
+ specific id *)
(* Creates the sub-graph of [g] restricted to vertices and edges in partition *)
let copy_partition g partition =
let copy_g = IdentDepGraph.create () in
IdentDepGraph.iter_edges
(fun src tgt ->
- if List.mem src partition && List.mem tgt partition
- then IdentDepGraph.add_edge copy_g src tgt)
+ if List.mem src partition && List.mem tgt partition then
+ IdentDepGraph.add_edge copy_g src tgt)
g
-
- (* Breaks dependency cycles in a graph [g] by inserting aux variables.
- [head] is a head of a non-trivial scc of [g].
- In Lustre, this is legal only for mem/mem cycles *)
+ (* Breaks dependency cycles in a graph [g] by inserting aux variables. [head]
+ is a head of a non-trivial scc of [g]. In Lustre, this is legal only for
+ mem/mem cycles *)
let break_cycle head cp_head g =
let succs = IdentDepGraph.succ g head in
IdentDepGraph.add_edge g head cp_head;
IdentDepGraph.add_edge g cp_head (ExprDep.mk_read_var head);
List.iter
(fun s ->
- IdentDepGraph.remove_edge g head s;
- IdentDepGraph.add_edge g s cp_head)
+ IdentDepGraph.remove_edge g head s;
+ IdentDepGraph.add_edge g s cp_head)
succs
(* Breaks cycles of the dependency graph [g] of memory variables [mems]
- belonging in node [node]. Returns:
- - a list of new auxiliary variable declarations
- - a list of new equations
- - a modified acyclic version of [g]
- *)
+ belonging in node [node]. Returns: - a list of new auxiliary variable
+ declarations - a list of new equations - a modified acyclic version of [g] *)
let break_cycles node mems g =
- let eqs , auts = get_node_eqs node in
- assert (auts = []); (* TODO: check: For the moment we assume that auts are expanded by now *)
- let (mem_eqs, non_mem_eqs) = List.partition (fun eq -> List.exists (fun v -> ISet.mem v mems) eq.eq_lhs) eqs in
+ let eqs, auts = get_node_eqs node in
+ assert (auts = []);
+ (* TODO: check: For the moment we assume that auts are expanded by now *)
+ let mem_eqs, non_mem_eqs =
+ List.partition
+ (fun eq -> List.exists (fun v -> ISet.mem v mems) eq.eq_lhs)
+ eqs
+ in
let rec break vdecls mem_eqs g =
let scc_l = Cycles.scc_list g in
let wrong = List.filter (wrong_partition g) scc_l in
match wrong with
- | [] -> (vdecls, non_mem_eqs@mem_eqs, g)
- | [head]::_ ->
- begin
- IdentDepGraph.remove_edge g head head;
- break vdecls mem_eqs g
- end
- | (head::part)::_ ->
- begin
- let vdecl_cp_head, cp_eq = mk_copy_eq node head in
- let pvar v = List.mem v part in
- let fvar v = if v = head then vdecl_cp_head.var_id else v in
- let mem_eqs' = List.map (eq_replace_rhs_var pvar fvar) mem_eqs in
- break_cycle head vdecl_cp_head.var_id g;
- break (vdecl_cp_head::vdecls) (cp_eq::mem_eqs') g
- end
- | _ -> assert false
- in break [] mem_eqs g
-
+ | [] ->
+ vdecls, non_mem_eqs @ mem_eqs, g
+ | [ head ] :: _ ->
+ IdentDepGraph.remove_edge g head head;
+ break vdecls mem_eqs g
+ | (head :: part) :: _ ->
+ let vdecl_cp_head, cp_eq = mk_copy_eq node head in
+ let pvar v = List.mem v part in
+ let fvar v = if v = head then vdecl_cp_head.var_id else v in
+ let mem_eqs' = List.map (eq_replace_rhs_var pvar fvar) mem_eqs in
+ break_cycle head vdecl_cp_head.var_id g;
+ break (vdecl_cp_head :: vdecls) (cp_eq :: mem_eqs') g
+ | _ ->
+ assert false
+ in
+ break [] mem_eqs g
end
-(* Module used to compute static disjunction of variables based upon their clocks. *)
-module Disjunction =
-struct
- module ClockedIdentModule =
- struct
+(* Module used to compute static disjunction of variables based upon their
+ clocks. *)
+module Disjunction = struct
+ module ClockedIdentModule = struct
type t = var_decl
- let root_branch vdecl = Clocks.root vdecl.var_clock, Clocks.branch vdecl.var_clock
- let compare v1 v2 = compare (root_branch v2, v2.var_id) (root_branch v1, v1.var_id)
+
+ let root_branch vdecl =
+ Clocks.root vdecl.var_clock, Clocks.branch vdecl.var_clock
+
+ let compare v1 v2 =
+ compare (root_branch v2, v2.var_id) (root_branch v1, v1.var_id)
end
- module CISet = Set.Make(ClockedIdentModule)
+ module CISet = Set.Make (ClockedIdentModule)
- (* map: var |-> list of disjoint vars, sorted in increasing branch length order,
- maybe removing shorter branches *)
+ (* map: var |-> list of disjoint vars, sorted in increasing branch length
+ order, maybe removing shorter branches *)
type disjoint_map = (ident, CISet.t) Hashtbl.t
- let pp_ciset fmt t = let open Format in
+ let pp_ciset fmt t =
+ let open Format in
pp_print_braced' ~pp_sep:pp_print_space Printers.pp_var_name fmt
(CISet.elements t)
let clock_disjoint_map vdecls =
let map = Hashtbl.create 23 in
- begin
- List.iter
- (fun v1 -> let disj_v1 =
- List.fold_left
- (fun res v2 -> if Clocks.disjoint v1.var_clock v2.var_clock then CISet.add v2 res else res)
- CISet.empty
- vdecls in
- (* disjoint vdecls are stored in increasing branch length order *)
- Hashtbl.add map v1.var_id disj_v1)
- vdecls;
- (map : disjoint_map)
- end
-
- (* merge variables [v] and [v'] in disjunction [map]. Then:
- - the mapping v' becomes v' |-> (map v) inter (map v')
- - the mapping v |-> ... then disappears
- - other mappings become x |-> (map x) \ (if v in x then v else v')
- *)
+ List.iter
+ (fun v1 ->
+ let disj_v1 =
+ List.fold_left
+ (fun res v2 ->
+ if Clocks.disjoint v1.var_clock v2.var_clock then CISet.add v2 res
+ else res)
+ CISet.empty vdecls
+ in
+ (* disjoint vdecls are stored in increasing branch length order *)
+ Hashtbl.add map v1.var_id disj_v1)
+ vdecls;
+ (map : disjoint_map)
+
+ (* merge variables [v] and [v'] in disjunction [map]. Then: - the mapping v'
+ becomes v' |-> (map v) inter (map v') - the mapping v |-> ... then
+ disappears - other mappings become x |-> (map x) \ (if v in x then v else
+ v') *)
let merge_in_disjoint_map map v v' =
- begin
- Hashtbl.replace map v'.var_id (CISet.inter (Hashtbl.find map v.var_id) (Hashtbl.find map v'.var_id));
- Hashtbl.remove map v.var_id;
- Hashtbl.iter (fun x map_x -> Hashtbl.replace map x (CISet.remove (if CISet.mem v map_x then v else v') map_x)) map;
- end
-
- (* replace variable [v] by [v'] in disjunction [map].
- [v'] is a dead variable. Then:
- - the mapping v' becomes v' |-> (map v)
- - the mapping v |-> ... then disappears
- - all mappings become x |-> ((map x) \ { v}) union ({v'} if v in map x)
- *)
+ Hashtbl.replace map v'.var_id
+ (CISet.inter (Hashtbl.find map v.var_id) (Hashtbl.find map v'.var_id));
+ Hashtbl.remove map v.var_id;
+ Hashtbl.iter
+ (fun x map_x ->
+ Hashtbl.replace map x
+ (CISet.remove (if CISet.mem v map_x then v else v') map_x))
+ map
+
+ (* replace variable [v] by [v'] in disjunction [map]. [v'] is a dead variable.
+ Then: - the mapping v' becomes v' |-> (map v) - the mapping v |-> ... then
+ disappears - all mappings become x |-> ((map x) \ { v}) union ({v'} if v in
+ map x) *)
let replace_in_disjoint_map map v v' =
- begin
- Hashtbl.replace map v'.var_id (Hashtbl.find map v.var_id);
- Hashtbl.remove map v.var_id;
- Hashtbl.iter (fun x mapx -> Hashtbl.replace map x (if CISet.mem v mapx then CISet.add v' (CISet.remove v mapx) else CISet.remove v' mapx)) map;
- end
-
- (* remove variable [v] in disjunction [map]. Then:
- - the mapping v |-> ... then disappears
- - all mappings become x |-> (map x) \ { v}
- *)
+ Hashtbl.replace map v'.var_id (Hashtbl.find map v.var_id);
+ Hashtbl.remove map v.var_id;
+ Hashtbl.iter
+ (fun x mapx ->
+ Hashtbl.replace map x
+ (if CISet.mem v mapx then CISet.add v' (CISet.remove v mapx)
+ else CISet.remove v' mapx))
+ map
+
+ (* remove variable [v] in disjunction [map]. Then: - the mapping v |-> ...
+ then disappears - all mappings become x |-> (map x) \ { v} *)
let remove_in_disjoint_map map v =
- begin
- Hashtbl.remove map v.var_id;
- Hashtbl.iter (fun x mapx -> Hashtbl.replace map x (CISet.remove v mapx)) map;
- end
+ Hashtbl.remove map v.var_id;
+ Hashtbl.iter (fun x mapx -> Hashtbl.replace map x (CISet.remove v mapx)) map
let pp_disjoint_map fmt map =
- Format.(fprintf fmt "@[<v 2>{ /* disjoint map */%t@] }"
- (fun fmt ->
- Hashtbl.iter (fun k v ->
- fprintf fmt "@,%s # %a"
- k (pp_print_braced' Printers.pp_var_name)
- (CISet.elements v)) map))
+ Format.(
+ fprintf fmt "@[<v 2>{ /* disjoint map */%t@] }" (fun fmt ->
+ Hashtbl.iter
+ (fun k v ->
+ fprintf fmt "@,%s # %a" k
+ (pp_print_braced' Printers.pp_var_name)
+ (CISet.elements v))
+ map))
end
-
let pp_dep_graph fmt g =
- Format.fprintf fmt "@[<v 0>@[<v 2>{ /* graph */%t@]@ }@]"
- (fun fmt ->
- IdentDepGraph.iter_edges (fun s t -> Format.fprintf fmt "@ %s -> %s" s t) g)
+ Format.fprintf fmt "@[<v 0>@[<v 2>{ /* graph */%t@]@ }@]" (fun fmt ->
+ IdentDepGraph.iter_edges
+ (fun s t -> Format.fprintf fmt "@ %s -> %s" s t)
+ g)
let pp_error fmt err =
match err with
| NodeCycle trace ->
- Format.fprintf fmt "Causality error, cyclic node calls:@ @[<v 0>%a@]@ "
- (fprintf_list ~sep:",@ " Format.pp_print_string) trace
- | DataCycle traces -> (
- Format.fprintf fmt "Causality error, cyclic data dependencies:@ @[<v 0>%a@]@ "
- (fprintf_list ~sep:";@ "
- (fun fmt trace ->
- Format.fprintf fmt "@[<v 0>{%a}@]"
- (fprintf_list ~sep:",@ " Format.pp_print_string)
- trace
- )) traces
- )
-
+ Format.fprintf fmt "Causality error, cyclic node calls:@ @[<v 0>%a@]@ "
+ (fprintf_list ~sep:",@ " Format.pp_print_string)
+ trace
+ | DataCycle traces ->
+ Format.fprintf fmt
+ "Causality error, cyclic data dependencies:@ @[<v 0>%a@]@ "
+ (fprintf_list ~sep:";@ " (fun fmt trace ->
+ Format.fprintf fmt "@[<v 0>{%a}@]"
+ (fprintf_list ~sep:",@ " Format.pp_print_string)
+ trace))
+ traces
+
(* Merges elements of graph [g2] into graph [g1] *)
let merge_with g1 g2 =
- begin
- IdentDepGraph.iter_vertex (fun v -> IdentDepGraph.add_vertex g1 v) g2;
- IdentDepGraph.iter_edges (fun s t -> IdentDepGraph.add_edge g1 s t) g2
- end
+ IdentDepGraph.iter_vertex (fun v -> IdentDepGraph.add_vertex g1 v) g2;
+ IdentDepGraph.iter_edges (fun s t -> IdentDepGraph.add_edge g1 s t) g2
let world = "!!_world"
let add_external_dependency outputs mems g =
- begin
- IdentDepGraph.add_vertex g world;
- ISet.iter (fun o -> IdentDepGraph.add_edge g world o) outputs;
- ISet.iter (fun m -> IdentDepGraph.add_edge g world m) mems;
- end
+ IdentDepGraph.add_vertex g world;
+ ISet.iter (fun o -> IdentDepGraph.add_edge g world o) outputs;
+ ISet.iter (fun m -> IdentDepGraph.add_edge g world m) mems
-(* Takes a node and return a pair (node', graph) where node' is node
- rebuilt with the equations enriched with new ones introduced to
- "break cycles" *)
+(* Takes a node and return a pair (node', graph) where node' is node rebuilt
+ with the equations enriched with new ones introduced to "break cycles" *)
let global_dependency node =
let mems = ExprDep.node_memory_variables node in
let inputs =
ISet.union
(ExprDep.node_input_variables node)
- (ExprDep.node_constant_variables node) in
+ (ExprDep.node_constant_variables node)
+ in
let outputs = ExprDep.node_output_variables node in
let node_vars = ExprDep.node_variables node in
- let (g_non_mems, g_mems) = ExprDep.dependence_graph mems inputs node_vars node in
- (*Format.eprintf "g_non_mems: %a" pp_dep_graph g_non_mems;
- Format.eprintf "g_mems: %a" pp_dep_graph g_mems;*)
+ let g_non_mems, g_mems =
+ ExprDep.dependence_graph mems inputs node_vars node
+ in
+ (*Format.eprintf "g_non_mems: %a" pp_dep_graph g_non_mems; Format.eprintf
+ "g_mems: %a" pp_dep_graph g_mems;*)
try
CycleDetection.check_cycles g_non_mems;
- let (vdecls', eqs', g_mems') = CycleDetection.break_cycles node mems g_mems in
+ let vdecls', eqs', g_mems' = CycleDetection.break_cycles node mems g_mems in
(*Format.eprintf "g_mems': %a" pp_dep_graph g_mems';*)
- begin
- merge_with g_non_mems g_mems';
- add_external_dependency outputs mems g_non_mems;
- { node with
+ merge_with g_non_mems g_mems';
+ add_external_dependency outputs mems g_non_mems;
+ ( {
+ node with
node_stmts = List.map (fun eq -> Eq eq) eqs';
- node_locals = vdecls' @ node.node_locals },
- g_non_mems
- end
- with Error (DataCycle _ as exc) ->
- raise (Error (exc))
-
-(* A module to sort dependencies among local variables when relying on clocked declarations *)
-module VarClockDep =
-struct
+ node_locals = vdecls' @ node.node_locals;
+ },
+ g_non_mems )
+ with Error (DataCycle _ as exc) -> raise (Error exc)
+
+(* A module to sort dependencies among local variables when relying on clocked
+ declarations *)
+module VarClockDep = struct
let rec get_clock_dep ck =
match ck.Clocks.cdesc with
- | Clocks.Con (ck , _ ,l) -> l::(get_clock_dep ck)
- | Clocks.Clink ck'
- | Clocks.Ccarrying (_, ck') -> get_clock_dep ck'
- | _ -> []
-
+ | Clocks.Con (ck, _, l) ->
+ l :: get_clock_dep ck
+ | Clocks.Clink ck' | Clocks.Ccarrying (_, ck') ->
+ get_clock_dep ck'
+ | _ ->
+ []
+
let sort locals =
let g = new_graph () in
- let g = List.fold_left (
- fun g var_decl ->
- let deps = get_clock_dep var_decl.var_clock in
- add_edges [var_decl.var_id] deps g
- ) g locals
+ let g =
+ List.fold_left
+ (fun g var_decl ->
+ let deps = get_clock_dep var_decl.var_clock in
+ add_edges [ var_decl.var_id ] deps g)
+ g locals
in
let sorted, no_deps =
- TopologicalDepGraph.fold (fun vid (accu, remaining) -> (
- let select v = v.var_id = vid in
- let selected, not_selected = List.partition select remaining in
- selected@accu, not_selected
- )) g ([],locals)
+ TopologicalDepGraph.fold
+ (fun vid (accu, remaining) ->
+ let select v = v.var_id = vid in
+ let selected, not_selected = List.partition select remaining in
+ selected @ accu, not_selected)
+ g ([], locals)
in
no_deps @ sorted
-
end
-
+
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/checks/access.ml b/src/checks/access.ml
index 604e5c45171e1b7ec39ccdddcf9a2427c4638a46..f0b58fa920f6b6f03347970d9e3867e025107691 100644
--- a/src/checks/access.ml
+++ b/src/checks/access.ml
@@ -9,88 +9,105 @@
(* *)
(********************************************************************)
-(** Access checking module. Done after typing. Generates dimension constraints stored in nodes *)
+(** Access checking module. Done after typing. Generates dimension constraints
+ stored in nodes *)
-let debug _fmt _args = () (* Format.eprintf "%a" *)
-(* Though it shares similarities with the clock calculus module, no code
- is shared. Simple environments, very limited identifier scoping, no
- identifier redefinition allowed. *)
+let debug _fmt _args = ()
+
+(* Format.eprintf "%a" *)
+(* Though it shares similarities with the clock calculus module, no code is
+ shared. Simple environments, very limited identifier scoping, no identifier
+ redefinition allowed. *)
open Utils
-(* Yes, opening both modules is dirty as some type names will be
- overwritten, yet this makes notations far lighter.*)
+
+(* Yes, opening both modules is dirty as some type names will be overwritten,
+ yet this makes notations far lighter.*)
open Lustre_types
open Corelang
-module ConstraintModule =
-struct (* bool dimension module *)
+module ConstraintModule = struct
+ (* bool dimension module *)
type t = Dimension.dim_expr
+
let equal d1 d2 = Dimension.is_eq_dimension d1 d2
- let compare d1 d2 = if equal d1 d2 then 0 else compare d1.Dimension.dim_id d2.Dimension.dim_id
+
+ let compare d1 d2 =
+ if equal d1 d2 then 0 else compare d1.Dimension.dim_id d2.Dimension.dim_id
+
let hash n = Hashtbl.hash n
end
-module CSet = Set.Make(ConstraintModule)
+module CSet = Set.Make (ConstraintModule)
-(** [check_expr env expr] checks expression [expr] and gathers constraints
- in set [checks]. *)
+(** [check_expr env expr] checks expression [expr] and gathers constraints in
+ set [checks]. *)
let rec check_expr checks expr =
- (*Format.eprintf "check_expr %a with type %a@." Printers.pp_expr expr Types.print_ty expr.expr_type;*)
- let res =
- match expr.expr_desc with
- | Expr_const _
- | Expr_ident _ -> checks
- | Expr_array elist -> List.fold_left check_expr checks elist
- | Expr_access (e1, d) -> check_expr (CSet.add (Dimension.check_access expr.expr_loc (Types.array_type_dimension e1.expr_type) d) checks) e1
+ (*Format.eprintf "check_expr %a with type %a@." Printers.pp_expr expr
+ Types.print_ty expr.expr_type;*)
+ let res =
+ match expr.expr_desc with
+ | Expr_const _ | Expr_ident _ ->
+ checks
+ | Expr_array elist ->
+ List.fold_left check_expr checks elist
+ | Expr_access (e1, d) ->
+ check_expr
+ (CSet.add
+ (Dimension.check_access expr.expr_loc
+ (Types.array_type_dimension e1.expr_type)
+ d)
+ checks)
+ e1
(* TODO: check dimensions *)
-
- | Expr_power (e1, _) -> check_expr checks e1
-
- | Expr_tuple elist -> List.fold_left check_expr checks elist
-
- | Expr_ite (c, t, e) -> List.fold_left check_expr checks [c; t; e]
-
- | Expr_appl (_, args, _) -> check_expr checks args
-
- | Expr_fby (e1,e2)
- | Expr_arrow (e1,e2) -> check_expr (check_expr checks e1) e2
- | Expr_pre e1
- | Expr_when (e1,_,_) -> check_expr checks e1
-
- | Expr_merge (_,hl) -> List.fold_left (fun checks (_, h) -> check_expr checks h) checks hl
- in (*Format.eprintf "typing %B %a at %a = %a@." const Printers.pp_expr expr Location.pp_loc expr.expr_loc Types.print_ty res;*) res
+ | Expr_power (e1, _) ->
+ check_expr checks e1
+ | Expr_tuple elist ->
+ List.fold_left check_expr checks elist
+ | Expr_ite (c, t, e) ->
+ List.fold_left check_expr checks [ c; t; e ]
+ | Expr_appl (_, args, _) ->
+ check_expr checks args
+ | Expr_fby (e1, e2) | Expr_arrow (e1, e2) ->
+ check_expr (check_expr checks e1) e2
+ | Expr_pre e1 | Expr_when (e1, _, _) ->
+ check_expr checks e1
+ | Expr_merge (_, hl) ->
+ List.fold_left (fun checks (_, h) -> check_expr checks h) checks hl
+ in
+ (*Format.eprintf "typing %B %a at %a = %a@." const Printers.pp_expr expr
+ Location.pp_loc expr.expr_loc Types.print_ty res;*)
+ res
let rec check_var_decl_type loc checks ty =
- if Types.is_array_type ty
- then
+ if Types.is_array_type ty then
check_var_decl_type loc
- (CSet.add (Dimension.check_bound loc (Types.array_type_dimension ty)) checks)
- (Types.array_element_type ty)
+ (CSet.add
+ (Dimension.check_bound loc (Types.array_type_dimension ty))
+ checks)
+ (Types.array_element_type ty)
else checks
let check_var_decl checks vdecl =
check_var_decl_type vdecl.var_loc checks vdecl.var_type
-(** [check_node nd] checks node [nd].
- The resulting constraints are stored in nodes. *)
+(** [check_node nd] checks node [nd]. The resulting constraints are stored in
+ nodes. *)
let check_node nd =
let checks = CSet.empty in
- let checks =
- List.fold_left check_var_decl checks (get_node_vars nd) in
+ let checks = List.fold_left check_var_decl checks (get_node_vars nd) in
let checks =
let eqs, auts = get_node_eqs nd in
- assert (auts = []); (* Not checking automata yet . *)
- List.fold_left (fun checks eq -> check_expr checks eq.eq_rhs) checks eqs in
+ assert (auts = []);
+ (* Not checking automata yet . *)
+ List.fold_left (fun checks eq -> check_expr checks eq.eq_rhs) checks eqs
+ in
nd.node_checks <- CSet.elements checks
let check_top_decl decl =
- match decl.top_decl_desc with
- | Node nd -> check_node nd
- | _ -> ()
-
-let check_prog decls =
- List.iter check_top_decl decls
+ match decl.top_decl_desc with Node nd -> check_node nd | _ -> ()
+let check_prog decls = List.iter check_top_decl decls
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/checks/algebraicLoop.ml b/src/checks/algebraicLoop.ml
index f3b3359ba3fe8fc1bffeb69040325c79e1ee8c20..2a7dd24223cf59d9cf73965903eedc07933a3a5c 100644
--- a/src/checks/algebraicLoop.ml
+++ b/src/checks/algebraicLoop.ml
@@ -1,43 +1,41 @@
-(* We try to solve all algebraic loops (AL) from prog:
-each node is mapped to its own cycles
-each cycle is tentatively solved by inlining one of its component
+(* We try to solve all algebraic loops (AL) from prog: each node is mapped to
+ its own cycles each cycle is tentatively solved by inlining one of its
+ component
-When done, a report is generated.
+ When done, a report is generated.
-- for each initial AL, the cycle is presented
- - either it is solvable and we provide the set of inlines that solves it
- - or it is not and we write the AL as unsolvable by inlining
+ - for each initial AL, the cycle is presented - either it is solvable and we
+ provide the set of inlines that solves it - or it is not and we write the AL
+ as unsolvable by inlining
If the option solve_al is activated, the resulting partially inlined prog is
- propagated fur future processing Otherwise the compilation stops
-*)
+ propagated fur future processing Otherwise the compilation stops *)
open Lustre_types
open Corelang
open Utils
(* An single algebraic loop is defined (partition, node calls, inlined, status)
- ie
+ ie
1. the list of variables in the loop, ident list
-
+
2.the possible functions identifier to inline, and whether they have been
- inlined yet (ident * tag * bool) list and
+ inlined yet (ident * tag * bool) list and
+
+ 3. a status whether the inlining is enough bool *)
- 3. a status whether the inlining is enough bool
-*)
+type call = ident * expr * eq
+(* fun id, expression, and containing equation *)
-type call = ident * expr * eq (* fun id, expression, and containing equation *)
-
type algebraic_loop = ident list * (call * bool) list * bool
+
type report = (node_desc * algebraic_loop list) list
-exception Error of report
+exception Error of report
(* Module that extract from the DataCycle the set of node that could be inlined
to solve the problem. *)
-module CycleResolution =
-struct
-
+module CycleResolution = struct
(* We iter over calls in node defs. If the call defined on of the variable in
the cycle, we store it for future possible inline. *)
let resolve node partition : call list =
@@ -45,101 +43,117 @@ struct
(* Preprocessing calls: associate to each of them the eq.lhs associated *)
let calls_expr = Causality.NodeDep.get_calls (fun _ -> true) node in
let eqs, auts = get_node_eqs node in
- assert (auts = []); (* TODO voir si on peut acceder directement aux eqs qui font les calls *)
- let calls = List.map (
- fun expr ->
- let eq = List.find (fun eq ->
- Corelang.expr_contains_expr expr.expr_tag eq.eq_rhs
- ) eqs in
- let fun_name = match expr.expr_desc with
- | Expr_appl(fun_id, _, _) -> fun_id
- | _ -> assert false
- in
- fun_name, expr, eq
- ) calls_expr in
- List.fold_left (
- fun accu ((_, _, eq) as call) ->
- let shared_vars = ISet.inter (ISet.of_list eq.eq_lhs) partition in
- if not (ISet.is_empty shared_vars) then
- (* We have a match: keep the eq and the expr to inline *)
- call::accu
- else
- accu
- ) [] calls
+ assert (auts = []);
+ (* TODO voir si on peut acceder directement aux eqs qui font les calls *)
+ let calls =
+ List.map
+ (fun expr ->
+ let eq =
+ List.find
+ (fun eq -> Corelang.expr_contains_expr expr.expr_tag eq.eq_rhs)
+ eqs
+ in
+ let fun_name =
+ match expr.expr_desc with
+ | Expr_appl (fun_id, _, _) ->
+ fun_id
+ | _ ->
+ assert false
+ in
+ fun_name, expr, eq)
+ calls_expr
+ in
+ List.fold_left
+ (fun accu ((_, _, eq) as call) ->
+ let shared_vars = ISet.inter (ISet.of_list eq.eq_lhs) partition in
+ if not (ISet.is_empty shared_vars) then
+ (* We have a match: keep the eq and the expr to inline *)
+ call :: accu
+ else accu)
+ [] calls
end
+(* Format.fprintf fmt "@[<v 2>Possible resolution:@ %a@]" pp_resolution
+ resolution*)
-(* Format.fprintf fmt "@[<v 2>Possible resolution:@ %a@]" pp_resolution resolution*)
-
-
let pp_resolution fmt resolution =
- fprintf_list ~sep:"@ " (fun fmt (eq, _) ->
- Format.fprintf fmt "inlining: %a" Printers.pp_node_eq eq
- ) fmt resolution
-
+ fprintf_list ~sep:"@ "
+ (fun fmt (eq, _) ->
+ Format.fprintf fmt "inlining: %a" Printers.pp_node_eq eq)
+ fmt resolution
+
let al_is_solved (_, als) = List.for_all (fun (_, _, status) -> status) als
-
+
(**********************************************************************)
(* Functions to access or toggle the local inlining feature of a call *)
(* expression *)
(**********************************************************************)
let inline_annotation loc =
- Inliner.keyword,
- Corelang.mkeexpr loc
- (Corelang.mkexpr loc
- (Expr_const (Const_tag tag_true) ))
+ ( Inliner.keyword,
+ Corelang.mkeexpr loc (Corelang.mkexpr loc (Expr_const (Const_tag tag_true)))
+ )
let is_inlining_annot (key, status) =
-key = Inliner.keyword && (
+ key = Inliner.keyword
+ &&
match status.eexpr_qfexpr.expr_desc with
| Expr_const (Const_tag tag) when tag = tag_true ->
- true
+ true
| Expr_const (Const_tag tag) when tag = tag_false ->
- false
- | _ -> assert false (* expecting true or false value *)
-)
-
+ false
+ | _ ->
+ assert false
+(* expecting true or false value *)
+
let is_expr_inlined nd expr =
match expr.expr_annot with
- None -> false
+ | None ->
+ false
| Some anns -> (
- (* Sanity check: expr should have the annotation AND the annotation should be declared *)
- let local_ann = List.exists is_inlining_annot anns.annots in
- let all_expr_inlined = Hashtbl.find_all Annotations.expr_annotations Inliner.keyword in
- let registered =
- List.exists
- (fun (nd_id, expr_tag) -> nd_id = nd.node_id && expr_tag = expr.expr_tag)
- all_expr_inlined
- in
- match local_ann, registered with
- | true, true -> true (* Everythin' all righ' ! *)
- | false, false -> false (* idem *)
- | _ -> assert false
- )
+ (* Sanity check: expr should have the annotation AND the annotation should
+ be declared *)
+ let local_ann = List.exists is_inlining_annot anns.annots in
+ let all_expr_inlined =
+ Hashtbl.find_all Annotations.expr_annotations Inliner.keyword
+ in
+ let registered =
+ List.exists
+ (fun (nd_id, expr_tag) ->
+ nd_id = nd.node_id && expr_tag = expr.expr_tag)
+ all_expr_inlined
+ in
+ match local_ann, registered with
+ | true, true ->
+ true (* Everythin' all righ' ! *)
+ | false, false ->
+ false (* idem *)
+ | _ ->
+ assert false)
-let pp_calls nd fmt calls = Format.fprintf fmt "@[<v 0>%a@]"
- (fprintf_list ~sep:"@ " (fun fmt (funid,expr, _) -> Format.fprintf fmt "%s: %i (inlined:%b)"
- funid
- expr.expr_tag
- (is_expr_inlined nd expr)
- ))
- calls
+let pp_calls nd fmt calls =
+ Format.fprintf fmt "@[<v 0>%a@]"
+ (fprintf_list ~sep:"@ " (fun fmt (funid, expr, _) ->
+ Format.fprintf fmt "%s: %i (inlined:%b)" funid expr.expr_tag
+ (is_expr_inlined nd expr)))
+ calls
(* Inline the provided expression *)
let inline_expr node expr =
(* Format.eprintf "inlining %a@ @?" Printers.pp_expr expr; *)
let ann = inline_annotation expr.expr_loc in
- let ann = {annots = [ann]; annot_loc = expr.expr_loc} in
+ let ann = { annots = [ ann ]; annot_loc = expr.expr_loc } in
let res = update_expr_annot node.node_id expr ann in
(* assert (is_expr_inlined node res); *)
(* Format.eprintf "Is expression inlined? %b@." (is_expr_inlined node res); *)
res
-(* Perform the steps of stage1/stage2 to revalidate the schedulability of the program *)
+(* Perform the steps of stage1/stage2 to revalidate the schedulability of the
+ program *)
let fast_stages_processing prog =
- Log.report ~level:3
- (fun fmt -> Format.fprintf fmt "@[<v 2>Fast revalidation: normalization + schedulability@ ");
+ Log.report ~level:3 (fun fmt ->
+ Format.fprintf fmt
+ "@[<v 2>Fast revalidation: normalization + schedulability@ ");
Options.verbose_level := !Options.verbose_level - 2;
(* Mini stage 1 *)
@@ -150,12 +164,15 @@ let fast_stages_processing prog =
(* Checking stateless/stateful status *)
if Plugins.check_force_stateful () then
Compiler_common.force_stateful_decls prog
- else
- Compiler_common.check_stateless_decls prog;
+ else Compiler_common.check_stateless_decls prog;
(* Typing *)
- let _ (*computed_types_env*) = Compiler_common.type_decls !Global.type_env prog in
+ let _ (*computed_types_env*) =
+ Compiler_common.type_decls !Global.type_env prog
+ in
(* Clock calculus *)
- let _ (*computed_clocks_env*) = Compiler_common.clock_decls !Global.clock_env prog in
+ let _ (*computed_clocks_env*) =
+ Compiler_common.clock_decls !Global.clock_env prog
+ in
(* Normalization *)
let params = Backends.get_normalization_params () in
let prog = Normalization.normalize_prog params prog in
@@ -163,8 +180,7 @@ let fast_stages_processing prog =
let res = Scheduling.schedule_prog prog in
Options.verbose_level := !Options.verbose_level + 2;
- Log.report ~level:3
- (fun fmt -> Format.fprintf fmt "@]@ ");
+ Log.report ~level:3 (fun fmt -> Format.fprintf fmt "@]@ ");
res
(**********************)
@@ -172,215 +188,228 @@ let fast_stages_processing prog =
let rec solving_node max_inlines prog nd existing_al partitions =
(* let pp_calls = pp_calls nd in *)
(* For each partition, we identify the original one *)
- let rerun, max_inlines, al = List.fold_left (fun (rerun, _, _) part ->
- let part_vars = ISet.of_list part in
- (* Useful functions to filter list of elements *)
- let match_al (vars, _, _) =
- not (ISet.is_empty (ISet.inter (ISet.of_list vars) part_vars)) in
- (* Identifying previous alarms that could be associated to current conflict *)
- let matched, non_matched = List.partition match_al existing_al in
- let previous_calls =
- match matched with
- | [] -> []
- | [_ (*vars*), calls, _ (*status*)] -> List.map fst calls (* we just keep the calls *)
- | _ -> (* variable should not belong to two different algrebraic loops. At least I
- hope so! *)
- assert false
- in
- let match_previous (_, expr, _) =
- List.exists
- (fun (_, expr', _) -> expr'.expr_tag = expr.expr_tag)
- previous_calls
- in
- (* let match_inlined (_, expr, _) = is_expr_inlined nd expr in *)
-
- (* let previous_inlined, previous_no_inlined = List.partition match_inlined previous_calls in *)
- (* Format.eprintf "Previous calls: @[<v 0>inlined: {%a}@ no inlined: {%a}@ @]@ " *)
- (* pp_calls previous_inlined *)
- (* pp_calls previous_no_inlined *)
-
- (* ; *)
-
- let current_calls = CycleResolution.resolve nd part in
- (* Format.eprintf "Current calls: %a" pp_calls current_calls; *)
- (* Filter out calls from current_calls that were not already in previous calls *)
- let current_calls = List.filter (fun c -> not (match_previous c)) current_calls
- in
- (* Format.eprintf "Current new calls (no old ones): %a" pp_calls current_calls; *)
- let calls = previous_calls @ current_calls in
- (* Format.eprintf "All calls (previous + new): %a" pp_calls calls; *)
-
- (* Filter out already inlined calls: actually they should not appear
- ... since they were inlined. We keep it for safety. *)
- let _ (* already_inlined *), possible_resolution =
- List.partition (fun (_, expr, _) -> is_expr_inlined nd expr) calls in
- (* Inlining the first uninlined call *)
- match possible_resolution with
- | (fun_id, expr, _)::_ -> ((* One could inline expr *)
- Log.report ~level:2 (fun fmt-> Format.fprintf fmt "inlining call to %s@ " fun_id);
- (* Forcing the expr to be inlined *)
- let _ = inline_expr nd expr in
- (* Format.eprintf "Making sure that the inline list evolved: inlined = {%a}" *)
- (* pp_calls *)
- (* ; *)
- true, (* we have to rerun to see if the inlined expression solves the issue *)
- max_inlines - 1,
- (
- part,
- List.map (fun ((_, expr2, _) as call)-> call, (expr2.expr_tag = expr.expr_tag)) calls,
- true (* TODO was false. Should be put it true and expect a final
- scheduling to change it to false in case of failure ? *) (*
- Status is nok, LA is unsolved yet *)
-
- )::non_matched
- )
- | [] -> (* No more calls to inline: algebraic loop is not solvable *)
- rerun, (* we don't force rerun since the current node is not solvable *)
- max_inlines,
- (
- part, (* initial list of troublesogme variables *)
- List.map (fun call -> call, false) calls,
- false (* Status is nok, LA is unsolved *)
- )::non_matched
-
- ) (false, max_inlines, existing_al) partitions
+ let rerun, max_inlines, al =
+ List.fold_left
+ (fun (rerun, _, _) part ->
+ let part_vars = ISet.of_list part in
+ (* Useful functions to filter list of elements *)
+ let match_al (vars, _, _) =
+ not (ISet.is_empty (ISet.inter (ISet.of_list vars) part_vars))
+ in
+ (* Identifying previous alarms that could be associated to current
+ conflict *)
+ let matched, non_matched = List.partition match_al existing_al in
+ let previous_calls =
+ match matched with
+ | [] ->
+ []
+ | [ (_ (*vars*), calls, _) (*status*) ] ->
+ List.map fst calls
+ (* we just keep the calls *)
+ | _ ->
+ (* variable should not belong to two different algrebraic loops. At
+ least I hope so! *)
+ assert false
+ in
+ let match_previous (_, expr, _) =
+ List.exists
+ (fun (_, expr', _) -> expr'.expr_tag = expr.expr_tag)
+ previous_calls
+ in
+
+ (* let match_inlined (_, expr, _) = is_expr_inlined nd expr in *)
+
+ (* let previous_inlined, previous_no_inlined = List.partition
+ match_inlined previous_calls in *)
+ (* Format.eprintf "Previous calls: @[<v 0>inlined: {%a}@ no inlined:
+ {%a}@ @]@ " *)
+ (* pp_calls previous_inlined *)
+ (* pp_calls previous_no_inlined *)
+
+ (* ; *)
+ let current_calls = CycleResolution.resolve nd part in
+ (* Format.eprintf "Current calls: %a" pp_calls current_calls; *)
+ (* Filter out calls from current_calls that were not already in previous calls *)
+ let current_calls =
+ List.filter (fun c -> not (match_previous c)) current_calls
+ in
+ (* Format.eprintf "Current new calls (no old ones): %a" pp_calls
+ current_calls; *)
+ let calls = previous_calls @ current_calls in
+
+ (* Format.eprintf "All calls (previous + new): %a" pp_calls calls; *)
+
+ (* Filter out already inlined calls: actually they should not appear ...
+ since they were inlined. We keep it for safety. *)
+ let _ (* already_inlined *), possible_resolution =
+ List.partition (fun (_, expr, _) -> is_expr_inlined nd expr) calls
+ in
+ (* Inlining the first uninlined call *)
+ match possible_resolution with
+ | (fun_id, expr, _) :: _ ->
+ (* One could inline expr *)
+ Log.report ~level:2 (fun fmt ->
+ Format.fprintf fmt "inlining call to %s@ " fun_id);
+ (* Forcing the expr to be inlined *)
+ let _ = inline_expr nd expr in
+ (* Format.eprintf "Making sure that the inline list evolved: inlined = {%a}" *)
+ (* pp_calls *)
+ (* ; *)
+ ( true,
+ (* we have to rerun to see if the inlined expression solves the
+ issue *)
+ max_inlines - 1,
+ ( part,
+ List.map
+ (fun ((_, expr2, _) as call) ->
+ call, expr2.expr_tag = expr.expr_tag)
+ calls,
+ true
+ (* TODO was false. Should be put it true and expect a final
+ scheduling to change it to false in case of failure ? *)
+ (* Status is nok, LA is unsolved yet *) )
+ :: non_matched )
+ | [] ->
+ (* No more calls to inline: algebraic loop is not solvable *)
+ ( rerun,
+ (* we don't force rerun since the current node is not solvable *)
+ max_inlines,
+ ( part,
+ (* initial list of troublesogme variables *)
+ List.map (fun call -> call, false) calls,
+ false (* Status is nok, LA is unsolved *) )
+ :: non_matched ))
+ (false, max_inlines, existing_al)
+ partitions
in
(* if partition an already identified al ? *)
(* if ISet.of_list partition *)
- if rerun && max_inlines > 0 then
- (* At least one partition could be improved: we try to inline the calls and reschedule the node. *)
+ if rerun && max_inlines > 0 then (
+ (* At least one partition could be improved: we try to inline the calls and
+ reschedule the node. *)
try
- Log.report ~level:2 (fun fmt -> Format.fprintf fmt "rescheduling node with new inlined call@ ");
+ Log.report ~level:2 (fun fmt ->
+ Format.fprintf fmt "rescheduling node with new inlined call@ ");
let _ = fast_stages_processing prog in
(* If everything went up to here, the problem is solved! All associated
- alarms are mapped to valid status. *)
- let al = List.map (fun (v,c,_) -> v,c,true) al in
+ alarms are mapped to valid status. *)
+ let al = List.map (fun (v, c, _) -> v, c, true) al in
Log.report ~level:2 (fun fmt -> Format.fprintf fmt "AL solved@ ");
- Some(nd, al), max_inlines
- with Causality.Error (Causality.DataCycle partitions2) -> (
- Log.report ~level:3 (fun fmt -> Format.fprintf fmt "AL not solved yet. Further processing.@ ");
- solving_node max_inlines prog nd al partitions2
- )
- else ((* No rerun, we return the current node and computed alarms *)
- Log.report ~level:3 (fun fmt -> Format.fprintf fmt "AL not solved yet. Stopping.@ ");
- Some(nd, al), max_inlines
- )
-
-(** This function takes a prog and returns (prog', status, alarms)
- where prog' is a modified prog with some locally inlined calls
- status is true is the final prog' is schedulable, ie no algebraic loop
- In case of failure, ie. inlining does not solve the problem; the status is false.
- Alarms contain the list of inlining performed or advised for each node.
- This could be provided as a feedback to the user.
-*)
+ Some (nd, al), max_inlines
+ with Causality.Error (Causality.DataCycle partitions2) ->
+ Log.report ~level:3 (fun fmt ->
+ Format.fprintf fmt "AL not solved yet. Further processing.@ ");
+ solving_node max_inlines prog nd al partitions2)
+ else (
+ (* No rerun, we return the current node and computed alarms *)
+ Log.report ~level:3 (fun fmt ->
+ Format.fprintf fmt "AL not solved yet. Stopping.@ ");
+ Some (nd, al), max_inlines)
+
+(** This function takes a prog and returns (prog', status, alarms) where prog'
+ is a modified prog with some locally inlined calls status is true is the
+ final prog' is schedulable, ie no algebraic loop In case of failure, ie.
+ inlining does not solve the problem; the status is false. Alarms contain the
+ list of inlining performed or advised for each node. This could be provided
+ as a feedback to the user. *)
let clean_al prog : program_t * bool * report =
let max_inlines = !Options.al_nb_max in
-(* We iterate over each node *)
+ (* We iterate over each node *)
let _, prog, al_list =
- List.fold_right (
- fun top (max_inlines, prog_accu, al_list) ->
- match top.top_decl_desc with
- | Node nd -> (
- let error, max_inlines =
- try (* without exception the node is schedulable; nothing to declare *)
- let _ = Scheduling.schedule_node nd in
- None, max_inlines
- with Causality.Error (Causality.DataCycle partitions) -> (
- Log.report ~level:2 (fun fmt -> Format.fprintf fmt "@[<v 2>AL in node %s@ " nd.node_id);
- let error, max_inlines = solving_node max_inlines prog nd [] partitions in
- Log.report ~level:2 (fun fmt -> Format.fprintf fmt "@ @]");
- error, max_inlines
- )
- in
- match error with
- | None -> max_inlines, top::prog_accu, al_list (* keep it as is *)
- | Some (nd, al) ->
- (* returning the updated node, possible solved, as well as the
- generated alarms *)
- max_inlines,
- {top with top_decl_desc = Node nd}::prog_accu,
- (nd, al)::al_list
- )
- | _ -> max_inlines, top::prog_accu, al_list
- ) prog (max_inlines, [], [])
+ List.fold_right
+ (fun top (max_inlines, prog_accu, al_list) ->
+ match top.top_decl_desc with
+ | Node nd -> (
+ let error, max_inlines =
+ try
+ (* without exception the node is schedulable; nothing to declare *)
+ let _ = Scheduling.schedule_node nd in
+ None, max_inlines
+ with Causality.Error (Causality.DataCycle partitions) ->
+ Log.report ~level:2 (fun fmt ->
+ Format.fprintf fmt "@[<v 2>AL in node %s@ " nd.node_id);
+ let error, max_inlines =
+ solving_node max_inlines prog nd [] partitions
+ in
+ Log.report ~level:2 (fun fmt -> Format.fprintf fmt "@ @]");
+ error, max_inlines
+ in
+ match error with
+ | None ->
+ max_inlines, top :: prog_accu, al_list (* keep it as is *)
+ | Some (nd, al) ->
+ (* returning the updated node, possible solved, as well as the
+ generated alarms *)
+ ( max_inlines,
+ { top with top_decl_desc = Node nd } :: prog_accu,
+ (nd, al) :: al_list ))
+ | _ ->
+ max_inlines, top :: prog_accu, al_list)
+ prog (max_inlines, [], [])
in
prog, List.for_all al_is_solved al_list, al_list
-
(* (ident list * (ident * expr* bool) list * bool) *)
let pp_al nd fmt (partition, calls, _) =
let open Format in
fprintf fmt "@[<v 0>";
fprintf fmt "variables in the alg. loop: @[<hov 0>%a@]@ "
- (fprintf_list ~sep:",@ " pp_print_string) partition;
+ (fprintf_list ~sep:",@ " pp_print_string)
+ partition;
fprintf fmt "@ involved node calls: @[<v 0>%a@]@ "
- (fprintf_list ~sep:",@ "
- (fun fmt ((funid, expr, _), status) ->
- fprintf fmt "%s" funid;
- if status && is_expr_inlined nd expr then fprintf fmt " (inlining it solves the alg. loop)";
- )
- ) calls;
+ (fprintf_list ~sep:",@ " (fun fmt ((funid, expr, _), status) ->
+ fprintf fmt "%s" funid;
+ if status && is_expr_inlined nd expr then
+ fprintf fmt " (inlining it solves the alg. loop)"))
+ calls;
fprintf fmt "@]"
- (* TODO ploc:
- First analyse the cycle and identify a list of nodes to be inlined, or node instances
- Then two behaviors:
- - print that list instead of the unreadable cyclic dependency comment
- - modify the node by adding the inline information
- - recall the subset of stage1 but restricted to a single node:
- - inline locally, typing, clocking (may have to reset the tables first), normalization of the node, mpfr injection
- - recall stage2
- *)
-
-
+(* TODO ploc: First analyse the cycle and identify a list of nodes to be
+ inlined, or node instances Then two behaviors: - print that list instead of
+ the unreadable cyclic dependency comment - modify the node by adding the
+ inline information - recall the subset of stage1 but restricted to a single
+ node: - inline locally, typing, clocking (may have to reset the tables
+ first), normalization of the node, mpfr injection - recall stage2 *)
+
let pp_report fmt report =
let open Format in
fprintf_list ~sep:"@."
(fun _ (nd, als) ->
- let top = Corelang.node_from_name (nd.node_id) in
+ let top = Corelang.node_from_name nd.node_id in
let pp =
- if not !Options.solve_al || List.exists (fun (_,_,valid) -> not valid) als then
- Error.pp_error (* at least one failure: erroneous node *)
- else
- Error.pp_warning (* solvable cases: warning only *)
+ if
+ (not !Options.solve_al)
+ || List.exists (fun (_, _, valid) -> not valid) als
+ then Error.pp_error (* at least one failure: erroneous node *)
+ else Error.pp_warning
+ (* solvable cases: warning only *)
in
- pp top.top_decl_loc
- (fun fmt ->
- fprintf fmt "algebraic loop in node %s: {@[<v 0>%a@]}"
- nd.node_id
- (fprintf_list ~sep:"@ " (pp_al nd)) als
- )
- ) fmt report;
+ pp top.top_decl_loc (fun fmt ->
+ fprintf fmt "algebraic loop in node %s: {@[<v 0>%a@]}" nd.node_id
+ (fprintf_list ~sep:"@ " (pp_al nd))
+ als))
+ fmt report;
fprintf fmt "@."
-
-
let analyze cpt prog =
Log.report ~level:1 (fun fmt ->
- Format.fprintf fmt "@[<v 2>Algebraic loop detected: ";
- if !Options.solve_al then Format.fprintf fmt "solving mode actived";
- Format.fprintf fmt "@ ";
- );
+ Format.fprintf fmt "@[<v 2>Algebraic loop detected: ";
+ if !Options.solve_al then Format.fprintf fmt "solving mode actived";
+ Format.fprintf fmt "@ ");
let prog, status_ok, report = clean_al prog in
-
+
let res =
- if cpt > 0 && !Options.solve_al && status_ok then (
- try
- fast_stages_processing prog
- with _ -> assert false (* Should not happen since the error has been
- catched already *)
- )
+ if cpt > 0 && !Options.solve_al && status_ok then
+ try fast_stages_processing prog with _ -> assert false
+ (* Should not happen since the error has been catched already *)
else (
- (* We stop with unresolved AL *)(* TODO create a report *)
+ (* We stop with unresolved AL *)
+ (* TODO create a report *)
(* Printing the report on stderr *)
Format.eprintf "%a" pp_report report;
- raise (Error.Error (Location.dummy_loc, Error.AlgebraicLoop))
- )
+ raise (Error.Error (Location.dummy_loc, Error.AlgebraicLoop)))
in
(* Printing the report on stderr *)
Format.eprintf "%a" pp_report report;
res
-
-let analyze prog =
- analyze !Options.al_nb_max prog
-
-
+
+let analyze prog = analyze !Options.al_nb_max prog
diff --git a/src/checks/init_calculus.ml b/src/checks/init_calculus.ml
index 7872e0a55302df2ebccf78641f1f81c472c19b7c..75da0d5435c84189c4171ddd7fc4b01d5727bb64 100644
--- a/src/checks/init_calculus.ml
+++ b/src/checks/init_calculus.ml
@@ -12,262 +12,273 @@
(** Main typing module. Classic inference algorithm with destructive
unification. *)
-(* Though it shares similarities with the clock calculus module, no code
- is shared. Simple environments, very limited identifier scoping, no
- identifier redefinition allowed. *)
+(* Though it shares similarities with the clock calculus module, no code is
+ shared. Simple environments, very limited identifier scoping, no identifier
+ redefinition allowed. *)
open Utils
-(* Yes, opening both modules is dirty as some type names will be
- overwritten, yet this makes notations far lighter.*)
+
+(* Yes, opening both modules is dirty as some type names will be overwritten,
+ yet this makes notations far lighter.*)
open Corelang
open Init
open Format
-(** [occurs tvar ty] returns true if the type variable [tvar] occurs in
- type [ty]. False otherwise. *)
+(** [occurs tvar ty] returns true if the type variable [tvar] occurs in type
+ [ty]. False otherwise. *)
let rec occurs tvar ty =
let ty = repr ty in
match ty.tdesc with
- | Ivar -> ty=tvar
+ | Ivar ->
+ ty = tvar
| Iarrow (t1, t2) ->
- (occurs tvar t1) || (occurs tvar t2)
+ occurs tvar t1 || occurs tvar t2
| Ituple tl ->
- List.exists (occurs tvar) tl
- | Ilink t -> occurs tvar t
- | Isucc t -> occurs tvar t
- | Iunivar -> false
+ List.exists (occurs tvar) tl
+ | Ilink t ->
+ occurs tvar t
+ | Isucc t ->
+ occurs tvar t
+ | Iunivar ->
+ false
-(** Promote monomorphic type variables to polymorphic type variables. *)
(* Generalize by side-effects *)
+
+(** Promote monomorphic type variables to polymorphic type variables. *)
let rec generalize ty =
match ty.tdesc with
| Ivar ->
- (* No scopes, always generalize *)
- ty.idesc <- Iunivar
- | Iarrow (t1,t2) ->
- generalize t1; generalize t2
+ (* No scopes, always generalize *)
+ ty.idesc <- Iunivar
+ | Iarrow (t1, t2) ->
+ generalize t1;
+ generalize t2
| Ituple tlist ->
- List.iter generalize tlist
+ List.iter generalize tlist
| Ilink t ->
- generalize t
+ generalize t
| Isucc t ->
- generalize t
- | Tunivar -> ()
+ generalize t
+ | Tunivar ->
+ ()
(** Downgrade polymorphic type variables to monomorphic type variables *)
let rec instanciate inst_vars ty =
let ty = repr ty in
match ty.idesc with
- | Ivar -> ty
- | Iarrow (t1,t2) ->
- {ty with idesc =
- Iarrow ((instanciate inst_vars t1), (instanciate inst_vars t2))}
+ | Ivar ->
+ ty
+ | Iarrow (t1, t2) ->
+ {
+ ty with
+ idesc = Iarrow (instanciate inst_vars t1, instanciate inst_vars t2);
+ }
| Ituple tlist ->
- {ty with idesc = Ituple (List.map (instanciate inst_vars) tlist)}
+ { ty with idesc = Ituple (List.map (instanciate inst_vars) tlist) }
| Isucc t ->
- (* should not happen *)
- {ty with idesc = Isucc (instanciate inst_vars t)}
+ (* should not happen *)
+ { ty with idesc = Isucc (instanciate inst_vars t) }
| Ilink t ->
- (* should not happen *)
- {ty with idesc = Ilink (instanciate inst_vars t)}
- | Iunivar ->
- try
- List.assoc ty.iid !inst_vars
- with Not_found ->
- let var = new_var () in
- inst_vars := (ty.iid, var)::!inst_vars;
- var
+ (* should not happen *)
+ { ty with idesc = Ilink (instanciate inst_vars t) }
+ | Iunivar -> (
+ try List.assoc ty.iid !inst_vars
+ with Not_found ->
+ let var = new_var () in
+ inst_vars := (ty.iid, var) :: !inst_vars;
+ var)
-(** [unify env t1 t2] unifies types [t1] and [t2]. Raises [Unify
- (t1,t2)] if the types are not unifiable.*)
+(** [unify env t1 t2] unifies types [t1] and [t2]. Raises [Unify (t1,t2)] if the
+ types are not unifiable.*)
(* Standard destructive unification *)
(* may loop for omega types *)
let rec unify t1 t2 =
let t1 = repr t1 in
let t2 = repr t2 in
- if t1=t2 then
- ()
+ if t1 = t2 then ()
else
(* No type abbreviations resolution for now *)
- match t1.idesc,t2.idesc with
- (* This case is not mandory but will keep "older" types *)
+ match t1.idesc, t2.idesc with
+ (* This case is not mandory but will keep "older" types *)
| Ivar, Ivar ->
- if t1.iid < t2.iid then
- t2.idesc <- Ilink t1
- else
- t1.idesc <- Ilink t2
- | (Ivar, _) when (not (occurs t1 t2)) ->
- t1.idesc <- Ilink t2
- | (_,Ivar) when (not (occurs t2 t1)) ->
- t2.idesc <- Ilink t1
- | Isucc t1, Isucc t1' -> unify t1 t1'
- | Iarrow (t1,t2), Iarrow (t1',t2') ->
- unify t1 t1'; unify t2 t2'
+ if t1.iid < t2.iid then t2.idesc <- Ilink t1 else t1.idesc <- Ilink t2
+ | Ivar, _ when not (occurs t1 t2) ->
+ t1.idesc <- Ilink t2
+ | _, Ivar when not (occurs t2 t1) ->
+ t2.idesc <- Ilink t1
+ | Isucc t1, Isucc t1' ->
+ unify t1 t1'
+ | Iarrow (t1, t2), Iarrow (t1', t2') ->
+ unify t1 t1';
+ unify t2 t2'
| Ituple tlist1, Ituple tlist2 ->
- if (List.length tlist1) <> (List.length tlist2) then
- raise (Unify (t1, t2))
- else
- List.iter2 unify tlist1 tlist2
- | Iunivar,_ | _, Iunivar ->
- ()
- | _,_ -> raise (Unify (t1, t2))
+ if List.length tlist1 <> List.length tlist2 then raise (Unify (t1, t2))
+ else List.iter2 unify tlist1 tlist2
+ | Iunivar, _ | _, Iunivar ->
+ ()
+ | _, _ ->
+ raise (Unify (t1, t2))
-let init_of_const c =
- Init_predef.init_zero
+let init_of_const c = Init_predef.init_zero
let rec init_expect env in_main expr ty =
let texpr = init_expr env in_main expr in
- try
- unify texpr ty
- with Unify (t1,t2) ->
- raise (Error (expr.expr_loc, Init_clash (t1,t2)))
+ try unify texpr ty
+ with Unify (t1, t2) -> raise (Error (expr.expr_loc, Init_clash (t1, t2)))
-and init_ident env in_main id loc =
- init_expr env in_main (expr_of_ident id loc)
+and init_ident env in_main id loc = init_expr env in_main (expr_of_ident id loc)
-(** [type_expr env in_main expr] types expression [expr] in environment
- [env]. *)
+(** [type_expr env in_main expr] types expression [expr] in environment [env]. *)
and init_expr env in_main expr =
match expr.expr_desc with
| Expr_const c ->
- let ty = init_of_const c in
- expr.expr_init <- ty;
- ty
+ let ty = init_of_const c in
+ expr.expr_init <- ty;
+ ty
| Expr_ident v ->
- let tyv =
- try
- Env.lookup_value env v
- with Not_found ->
- raise (Error (expr.expr_loc, Unbound_value v))
- in
- let ty = instanciate (ref []) tyv in
- expr.expr_init <- ty;
- ty
+ let tyv =
+ try Env.lookup_value env v
+ with Not_found -> raise (Error (expr.expr_loc, Unbound_value v))
+ in
+ let ty = instanciate (ref []) tyv in
+ expr.expr_init <- ty;
+ ty
| Expr_tuple elist ->
- let ty = new_ty (Ttuple (List.map (type_expr env in_main) elist)) in
- expr.expr_init <- ty;
- ty
+ let ty = new_ty (Ttuple (List.map (type_expr env in_main) elist)) in
+ expr.expr_init <- ty;
+ ty
| Expr_appl (id, args, r) ->
(match r with
- | None -> ()
- | Some x -> let expr_x = expr_of_ident x expr.expr_loc in
- init_expect env in_main expr_x Init_predef.init_zero);
- let tfun = type_ident env in_main id expr.expr_loc in
- let tins,touts= split_arrow tfun in
- type_expect env in_main args tins;
- expr.expr_type <- touts;
- touts
- | Expr_arrow (e1,e2) ->
- let ty = type_expr env in_main e1 in
- type_expect env in_main e2 ty;
- expr.expr_type <- ty;
- ty
- | Expr_fby (init,e) ->
- let ty = type_of_const init in
- type_expect env in_main e ty;
- expr.expr_type <- ty;
- ty
- | Expr_concat (hd,e) ->
- let ty = type_of_const hd in
- type_expect env in_main e ty;
- expr.expr_type <- ty;
- ty
+ | None ->
+ ()
+ | Some x ->
+ let expr_x = expr_of_ident x expr.expr_loc in
+ init_expect env in_main expr_x Init_predef.init_zero);
+ let tfun = type_ident env in_main id expr.expr_loc in
+ let tins, touts = split_arrow tfun in
+ type_expect env in_main args tins;
+ expr.expr_type <- touts;
+ touts
+ | Expr_arrow (e1, e2) ->
+ let ty = type_expr env in_main e1 in
+ type_expect env in_main e2 ty;
+ expr.expr_type <- ty;
+ ty
+ | Expr_fby (init, e) ->
+ let ty = type_of_const init in
+ type_expect env in_main e ty;
+ expr.expr_type <- ty;
+ ty
+ | Expr_concat (hd, e) ->
+ let ty = type_of_const hd in
+ type_expect env in_main e ty;
+ expr.expr_type <- ty;
+ ty
| Expr_tail e ->
- let ty = type_expr env in_main e in
- expr.expr_type <- ty;
- ty
+ let ty = type_expr env in_main e in
+ expr.expr_type <- ty;
+ ty
| Expr_pre e ->
- let ty = type_expr env in_main e in
- expr.expr_type <- ty;
- ty
- | Expr_when (e1,c) | Expr_whennot (e1,c) ->
- let expr_c = expr_of_ident c expr.expr_loc in
- type_expect env in_main expr_c Type_predef.type_bool;
- let tlarg = type_expr env in_main e1 in
- expr.expr_type <- tlarg;
- tlarg
- | Expr_merge (c,e2,e3) ->
- let expr_c = expr_of_ident c expr.expr_loc in
- type_expect env in_main expr_c Type_predef.type_bool;
- let te2 = type_expr env in_main e2 in
- type_expect env in_main e3 te2;
- expr.expr_type <- te2;
- te2
- | Expr_uclock (e,k) | Expr_dclock (e,k) ->
- let ty = type_expr env in_main e in
- expr.expr_type <- ty;
- ty
- | Expr_phclock (e,q) ->
- let ty = type_expr env in_main e in
- expr.expr_type <- ty;
- ty
+ let ty = type_expr env in_main e in
+ expr.expr_type <- ty;
+ ty
+ | Expr_when (e1, c) | Expr_whennot (e1, c) ->
+ let expr_c = expr_of_ident c expr.expr_loc in
+ type_expect env in_main expr_c Type_predef.type_bool;
+ let tlarg = type_expr env in_main e1 in
+ expr.expr_type <- tlarg;
+ tlarg
+ | Expr_merge (c, e2, e3) ->
+ let expr_c = expr_of_ident c expr.expr_loc in
+ type_expect env in_main expr_c Type_predef.type_bool;
+ let te2 = type_expr env in_main e2 in
+ type_expect env in_main e3 te2;
+ expr.expr_type <- te2;
+ te2
+ | Expr_uclock (e, k) | Expr_dclock (e, k) ->
+ let ty = type_expr env in_main e in
+ expr.expr_type <- ty;
+ ty
+ | Expr_phclock (e, q) ->
+ let ty = type_expr env in_main e in
+ expr.expr_type <- ty;
+ ty
(** [type_eq env eq] types equation [eq] in environment [env] *)
let type_eq env in_main undefined_vars eq =
(* Check multiple variable definitions *)
let define_var id uvars =
try
- ignore(IMap.find id uvars);
+ ignore (IMap.find id uvars);
IMap.remove id uvars
- with Not_found ->
- raise (Error (eq.eq_loc, Already_defined id))
+ with Not_found -> raise (Error (eq.eq_loc, Already_defined id))
in
let undefined_vars =
- List.fold_left (fun uvars v -> define_var v uvars) undefined_vars eq.eq_lhs in
+ List.fold_left (fun uvars v -> define_var v uvars) undefined_vars eq.eq_lhs
+ in
(* Type lhs *)
let get_value_type id =
- try
- Env.lookup_value env id
- with Not_found ->
- raise (Error (eq.eq_loc, Unbound_value id))
+ try Env.lookup_value env id
+ with Not_found -> raise (Error (eq.eq_loc, Unbound_value id))
in
let tyl_lhs = List.map get_value_type eq.eq_lhs in
let ty_lhs = type_of_type_list tyl_lhs in
- (* Type rhs *)
+ (* Type rhs *)
type_expect env in_main eq.eq_rhs ty_lhs;
undefined_vars
(* [type_coretype cty] types the type declaration [cty] *)
let type_coretype cty =
match cty with
- | Tydec_any -> new_var ()
- | Tydec_int -> Type_predef.type_int
- | Tydec_real -> Type_predef.type_real
- | Tydec_float -> Type_predef.type_real
- | Tydec_bool -> Type_predef.type_bool
- | Tydec_clock -> Type_predef.type_clock
+ | Tydec_any ->
+ new_var ()
+ | Tydec_int ->
+ Type_predef.type_int
+ | Tydec_real ->
+ Type_predef.type_real
+ | Tydec_float ->
+ Type_predef.type_real
+ | Tydec_bool ->
+ Type_predef.type_bool
+ | Tydec_clock ->
+ Type_predef.type_clock
-(* [type_coreclock env ck id loc] types the type clock declaration [ck]
- in environment [env] *)
+(* [type_coreclock env ck id loc] types the type clock declaration [ck] in
+ environment [env] *)
let type_coreclock env ck id loc =
match ck.ck_dec_desc with
- | Ckdec_any | Ckdec_pclock (_,_) -> ()
+ | Ckdec_any | Ckdec_pclock (_, _) ->
+ ()
| Ckdec_bool cl ->
- let dummy_id_expr = expr_of_ident id loc in
- let when_expr =
- List.fold_left
- (fun expr c ->
- match c with
- | Wtrue id ->
- {expr_tag = new_tag ();
- expr_desc=Expr_when (expr,id);
- expr_type = new_var ();
- expr_clock = Clocks.new_var true;
- expr_loc=loc}
- | Wfalse id ->
- {expr_tag = new_tag ();
- expr_desc=Expr_whennot (expr,id);
- expr_type = new_var ();
- expr_clock = Clocks.new_var true;
- expr_loc=loc})
- dummy_id_expr cl
- in
- ignore (type_expr env false when_expr)
+ let dummy_id_expr = expr_of_ident id loc in
+ let when_expr =
+ List.fold_left
+ (fun expr c ->
+ match c with
+ | Wtrue id ->
+ {
+ expr_tag = new_tag ();
+ expr_desc = Expr_when (expr, id);
+ expr_type = new_var ();
+ expr_clock = Clocks.new_var true;
+ expr_loc = loc;
+ }
+ | Wfalse id ->
+ {
+ expr_tag = new_tag ();
+ expr_desc = Expr_whennot (expr, id);
+ expr_type = new_var ();
+ expr_clock = Clocks.new_var true;
+ expr_loc = loc;
+ })
+ dummy_id_expr cl
+ in
+ ignore (type_expr env false when_expr)
let type_var_decl env vdecl =
- if (Env.exists_value env vdecl.var_id) then
- raise (Error (vdecl.var_loc,Already_bound vdecl.var_id))
+ if Env.exists_value env vdecl.var_id then
+ raise (Error (vdecl.var_loc, Already_bound vdecl.var_id))
else
let ty = type_coretype vdecl.var_dec_type.ty_dec_desc in
let new_env = Env.add_value env vdecl.var_id ty in
@@ -275,15 +286,14 @@ let type_var_decl env vdecl =
vdecl.var_type <- ty;
new_env
-let type_var_decl_list env l =
- List.fold_left type_var_decl env l
+let type_var_decl_list env l = List.fold_left type_var_decl env l
let type_of_vlist vars =
let tyl = List.map (fun v -> v.var_type) vars in
type_of_type_list tyl
-
-(** [type_node env nd loc] types node [nd] in environment env. The
- location is used for error reports. *)
+
+(** [type_node env nd loc] types node [nd] in environment env. The location is
+ used for error reports. *)
let type_node env nd loc =
let is_main = nd.node_id = !Options.main_node in
let delta_env = type_var_decl_list IMap.empty nd.node_inputs in
@@ -293,16 +303,18 @@ let type_node env nd loc =
let undefined_vars_init =
List.fold_left
(fun uvs v -> IMap.add v.var_id () uvs)
- IMap.empty (nd.node_outputs@nd.node_locals) in
+ IMap.empty
+ (nd.node_outputs @ nd.node_locals)
+ in
let undefined_vars =
List.fold_left (type_eq new_env is_main) undefined_vars_init nd.node_eqs
in
(* check that table is empty *)
- if (not (IMap.is_empty undefined_vars)) then
- raise (Error (loc,Undefined_var undefined_vars));
+ if not (IMap.is_empty undefined_vars) then
+ raise (Error (loc, Undefined_var undefined_vars));
let ty_ins = type_of_vlist nd.node_inputs in
let ty_outs = type_of_vlist nd.node_outputs in
- let ty_node = new_ty (Tarrow (ty_ins,ty_outs)) in
+ let ty_node = new_ty (Tarrow (ty_ins, ty_outs)) in
generalize ty_node;
(* TODO ? Check that no node in the hierarchy remains polymorphic ? *)
nd.node_type <- ty_node;
@@ -310,12 +322,12 @@ let type_node env nd loc =
let type_imported_node env nd loc =
let new_env = type_var_decl_list env nd.nodei_inputs in
- ignore(type_var_decl_list new_env nd.nodei_outputs);
+ ignore (type_var_decl_list new_env nd.nodei_outputs);
let ty_ins = type_of_vlist nd.nodei_inputs in
let ty_outs = type_of_vlist nd.nodei_outputs in
- let ty_node = new_ty (Tarrow (ty_ins,ty_outs)) in
+ let ty_node = new_ty (Tarrow (ty_ins, ty_outs)) in
generalize ty_node;
- if (is_polymorphic ty_node) then
+ if is_polymorphic ty_node then
raise (Error (loc, Poly_imported_node nd.nodei_id));
let new_env = Env.add_value env nd.nodei_id ty_node in
nd.nodei_type <- ty_node;
@@ -323,24 +335,27 @@ let type_imported_node env nd loc =
let type_top_decl env decl =
match decl.top_decl_desc with
- | Node nd ->
- type_node env nd decl.top_decl_loc
+ | Node nd ->
+ type_node env nd decl.top_decl_loc
| ImportedNode nd ->
- type_imported_node env nd decl.top_decl_loc
- | SensorDecl _ | ActuatorDecl _ | Consts _ -> env
+ type_imported_node env nd decl.top_decl_loc
+ | SensorDecl _ | ActuatorDecl _ | Consts _ ->
+ env
let type_top_consts env decl =
match decl.top_decl_desc with
- | Consts clist ->
- List.fold_left (fun env (id, c) ->
- let ty = type_of_const c in
- Env.add_value env id ty
- ) env clist
- | Node _ | ImportedNode _ | SensorDecl _ | ActuatorDecl _ -> env
+ | Consts clist ->
+ List.fold_left
+ (fun env (id, c) ->
+ let ty = type_of_const c in
+ Env.add_value env id ty)
+ env clist
+ | Node _ | ImportedNode _ | SensorDecl _ | ActuatorDecl _ ->
+ env
let type_prog env decls =
let new_env = List.fold_left type_top_consts env decls in
- ignore(List.fold_left type_top_decl new_env decls)
+ ignore (List.fold_left type_top_decl new_env decls)
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/checks/liveness.ml b/src/checks/liveness.ml
index 5cf14a3bf19167460f751e11375a974b480dccd0..3db48059a052b495b74869d97967beed46a8aa28 100644
--- a/src/checks/liveness.ml
+++ b/src/checks/liveness.ml
@@ -1,291 +1,305 @@
-(********************************************************************)
-(* *)
-(* 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 Lustre_types
-open Corelang
-open Causality
-
-type context =
-{
- mutable evaluated : Disjunction.CISet.t;
- dep_graph : IdentDepGraph.t;
- disjoint : (ident, Disjunction.CISet.t) Hashtbl.t;
- policy : (ident, var_decl) Hashtbl.t;
-}
-
-(* computes the in-degree for each local variable of node [n], according to dep graph [g].
-*)
-let compute_fanin n g =
- let locals = ISet.diff (ExprDep.node_local_variables n) (ExprDep.node_memory_variables n) in
- let inputs = ExprDep.node_input_variables n in
- let fanin = Hashtbl.create 23 in
- begin
- IdentDepGraph.iter_vertex
- (fun v ->
- if ISet.mem v locals
- then Hashtbl.add fanin v (IdentDepGraph.in_degree g v) else
- if ExprDep.is_read_var v && not (ISet.mem v inputs)
- then Hashtbl.add fanin (ExprDep.undo_read_var v) (IdentDepGraph.in_degree g v)) g;
- fanin
- end
-
-let pp_fanin fmt fanin =
- Format.fprintf fmt "@[<v 0>@[<v 2>{ /* locals fanin: */";
- Hashtbl.iter (fun s t -> Format.fprintf fmt "@ %s -> %d" s t) fanin;
- Format.fprintf fmt "@]@ }@]"
-
-(* computes the cone of influence of a given [var] wrt a dependency graph [g].
-*)
-let cone_of_influence g var =
- (*Format.printf "DEBUG coi: %s@." var;*)
- let frontier = ref (ISet.add var ISet.empty) in
- let explored = ref ISet.empty in
- let coi = ref ISet.empty in
- while not (ISet.is_empty !frontier)
- do
- let head = ISet.min_elt !frontier in
- (*Format.printf "DEBUG head: %s@." head;*)
- frontier := ISet.remove head !frontier;
- explored := ISet.add head !explored;
- if ExprDep.is_read_var head then coi := ISet.add (ExprDep.undo_read_var head) !coi;
- List.iter (fun s -> if not (ISet.mem s !explored) then frontier := ISet.add s !frontier) (IdentDepGraph.succ g head);
- done;
- !coi
-
-let compute_unused_variables n g =
- let inputs = ExprDep.node_input_variables n in
- let mems = ExprDep.node_memory_variables n in
- let outputs = ExprDep.node_output_variables n in
- ISet.fold
- (fun var unused -> ISet.diff unused (cone_of_influence g var))
- (ISet.union outputs mems)
- (ISet.union inputs mems)
-
-(* computes the set of potentially reusable variables.
- We don't reuse input variables, due to possible aliasing *)
-let node_reusable_variables node =
- let mems = ExprDep.node_memory_variables node in
- List.fold_left
- (fun acc l ->
- if ISet.mem l.var_id mems then acc else Disjunction.CISet.add l acc)
- Disjunction.CISet.empty
- node.node_locals
-
-let kill_instance_variables ctx inst =
- IdentDepGraph.remove_vertex ctx.dep_graph inst
-
-let kill_root ctx head =
- IdentDepGraph.iter_succ (IdentDepGraph.remove_edge ctx.dep_graph head.var_id) ctx.dep_graph head.var_id
-
-(* Recursively removes useless variables,
- i.e. [ctx.evaluated] variables that are current roots of the dep graph [ctx.dep_graph]
- - [evaluated] is the set of already evaluated variables,
- wrt the scheduling
- - does only remove edges, not variables themselves
- - yet, instance variables are removed
-*)
-let remove_roots ctx =
- let rem = ref true in
- let remaining = ref ctx.evaluated in
- while !rem
- do
- rem := false;
- let all_roots = graph_roots ctx.dep_graph in
- let inst_roots, var_roots = List.partition (fun v -> ExprDep.is_instance_var v && v <> Causality.world) all_roots in
- let frontier_roots = Disjunction.CISet.filter (fun v -> List.mem v.var_id var_roots) !remaining in
- if not (Disjunction.CISet.is_empty frontier_roots && inst_roots = []) then
- begin
- rem := true;
- List.iter (kill_instance_variables ctx) inst_roots;
- Disjunction.CISet.iter (kill_root ctx) frontier_roots;
- remaining := Disjunction.CISet.diff !remaining frontier_roots
- end
- done
-
-(* checks whether a variable is aliasable,
- depending on its (address) type *)
-let is_aliasable var =
- (not (!Options.mpfr && Types.is_real_type var.var_type)) && Types.is_address_type var.var_type
-
-(* checks whether a variable [v] is an input of the [var] equation, with an address type.
- if so, [var] could not safely reuse/alias [v], should [v] be dead in the caller node,
- because [v] may not be dead in the callee node when [var] is assigned *)
-let is_aliasable_input node var =
- let eq_var = get_node_eq var node in
- let inputs_var =
- match NodeDep.get_callee eq_var.eq_rhs with
- | None -> []
- | Some (_, args) -> List.fold_right (fun e r -> match e.expr_desc with Expr_ident id -> id::r | _ -> r) args [] in
- fun v -> is_aliasable v && List.mem v.var_id inputs_var
-
-(* replace variable [v] by [v'] in graph [g].
- [v'] is a dead variable
-*)
-let replace_in_dep_graph v v' g =
- begin
- IdentDepGraph.add_vertex g v';
- IdentDepGraph.iter_succ (fun s -> IdentDepGraph.add_edge g v' s) g v;
- IdentDepGraph.iter_pred (fun p -> IdentDepGraph.add_edge g p v') g v;
- IdentDepGraph.remove_vertex g v
- end
-
-let pp_reuse_policy fmt policy =
- Format.(fprintf fmt "@[<v 2>{ /* reuse policy */%t@] }"
- (fun fmt -> Hashtbl.iter (fun s t -> fprintf fmt "@,%s -> %s" s t.var_id) policy))
-
-let pp_context fmt ctx =
- Format.fprintf fmt
- "@[<v 2>{ /*BEGIN context */@,\
- eval = %a;@,\
- graph = %a;@,\
- disjoint = %a;@,\
- policy = %a;@,\
- /* END context */ }@]"
- Disjunction.pp_ciset ctx.evaluated
- pp_dep_graph ctx.dep_graph
- Disjunction.pp_disjoint_map ctx.disjoint
- pp_reuse_policy ctx.policy
-
-(* computes the reusable dependencies of variable [var] in graph [g],
- once [var] has been evaluated
- - [locals] is the set of potentially reusable variables
- - [evaluated] is the set of evaluated variables
- - [quasi] is the set of quasi-reusable variables
- - [reusable] is the set of dead/reusable dependencies of [var] in graph [g]
- - [policy] is the reuse map (which domain is [evaluated])
-*)
-let compute_dependencies heads ctx =
- begin
- (*Log.report ~level:6 (fun fmt -> Format.fprintf fmt "compute_reusable_dependencies %a %a %a@." Disjunction.pp_ciset locals Printers.pp_var_name var pp_context ctx);*)
- List.iter (kill_root ctx) heads;
- remove_roots ctx;
- end
-
-let compute_evaluated heads ctx =
- begin
- List.iter (fun head -> ctx.evaluated <- Disjunction.CISet.add head ctx.evaluated) heads;
- end
-
-(* tests whether a variable [v] may be (re)used instead of [var]. The conditions are:
- - [v] has been really used ([v] is its own representative)
- - same type
- - [v] is not an aliasable input of the equation defining [var]
- - [v] is not one of the current heads (which contain [var])
- - [v] is not currently in use
- *)
-let eligible node ctx heads var v =
- Hashtbl.find ctx.policy v.var_id == v
- && Typing.eq_ground (Types.unclock_type var.var_type) (Types.unclock_type v.var_type)
- && not (is_aliasable_input node var.var_id v)
- && not (List.exists (fun h -> h.var_id = v.var_id) heads)
- && (*let repr_v = Hashtbl.find ctx.policy v.var_id*)
- not (Disjunction.CISet.exists (fun p -> IdentDepGraph.mem_edge ctx.dep_graph p.var_id v.var_id) ctx.evaluated)
-
-let compute_reuse node ctx heads var =
- let disjoint = Hashtbl.find ctx.disjoint var.var_id in
- let locally_reusable v =
- IdentDepGraph.fold_pred (fun p r -> r && Disjunction.CISet.exists (fun d -> p = d.var_id) disjoint) ctx.dep_graph v.var_id true in
- let eligibles =
- if ISet.mem var.var_id (ExprDep.node_memory_variables node)
- then Disjunction.CISet.empty
- else Disjunction.CISet.filter (eligible node ctx heads var) ctx.evaluated in
- let quasi_dead, live = Disjunction.CISet.partition locally_reusable eligibles in
- let disjoint_live = Disjunction.CISet.inter disjoint live in
- let dead = Disjunction.CISet.filter (fun v -> is_graph_root v.var_id ctx.dep_graph) quasi_dead in
- Log.report ~level:7 (fun fmt ->
- Format.fprintf fmt
- "@[<v>\
- eligibles : %a@,\
- live : %a@,\
- disjoint live: %a@,\
- dead : %a@,@]"
- Disjunction.pp_ciset eligibles
- Disjunction.pp_ciset live
- Disjunction.pp_ciset disjoint_live
- Disjunction.pp_ciset dead);
- begin try
- let reuse = match Disjunction.CISet.max_elt_opt disjoint_live with
- | Some reuse -> reuse
- | None -> Disjunction.CISet.choose dead in
- IdentDepGraph.add_edge ctx.dep_graph var.var_id reuse.var_id;
- Hashtbl.add ctx.policy var.var_id reuse
- with Not_found -> Hashtbl.add ctx.policy var.var_id var
- end;
- ctx.evaluated <- Disjunction.CISet.add var ctx.evaluated
-
-let compute_reuse_policy node schedule disjoint g =
- let ctx = { evaluated = Disjunction.CISet.empty;
- dep_graph = g;
- disjoint = disjoint;
- policy = Hashtbl.create 23; } in
- List.iter (fun heads ->
- let heads = List.map (fun v -> get_node_var v node) heads in
- Log.report ~level:6 (fun fmt ->
- Format.(fprintf fmt
- "@[<v>@[<v 2>new context:@,%a@]@,NEW HEADS:%a@,COMPUTE_DEPENDENCIES@,@]"
- pp_context ctx
- (pp_print_list
- ~pp_open_box:pp_open_hbox
- ~pp_sep:pp_print_space
- (fun fmt head ->
- fprintf fmt "%s (%a)"
- head.var_id Printers.pp_node_eq
- (get_node_eq head.var_id node)))
- heads));
- compute_dependencies heads ctx;
- Log.report ~level:6 (fun fmt ->
- Format.fprintf fmt "@[<v>@[<v 2>new context:@,%a@]@,COMPUTE_REUSE@,@]" pp_context ctx);
- List.iter (compute_reuse node ctx heads) heads;
- (*compute_evaluated heads ctx;*)
- Log.report ~level:6 (fun fmt ->
- Format.(fprintf fmt "@[<v>%a@,@]"
- (pp_print_list
- ~pp_open_box:pp_open_vbox0
- (fun fmt head -> fprintf fmt "reuse %s instead of %s"
- (Hashtbl.find ctx.policy head.var_id).var_id head.var_id))
- heads)))
- schedule;
- IdentDepGraph.clear ctx.dep_graph;
- ctx.policy
-
-(* Reuse policy:
- - could reuse variables with the same type exactly only (simple).
- - reusing variables with different types would involve:
- - either dirty castings
- - or complex inclusion expression (for instance: array <-> array cell, struct <-> struct field) to be able to reuse only some parts of structured data.
- ... it seems too complex and potentially unsafe
- - for node instance calls: output variables could NOT reuse aliasable input variables,
- even if inputs become dead, because the correctness would depend on the scheduling
- of the callee (so, the compiling strategy could NOT be modular anymore).
- - once a policy is set, we need to:
- - replace each variable by its reuse alias.
- - simplify resulting equations, as we may now have:
- x = x; --> ; for scalar vars
- or:
- x = &{ f1 = x->f1; f2 = t; } --> x->f2 = t; for struct vars
- *)
-
-
-(* the reuse policy seeks to use less local variables
- by replacing local variables, applying the rules
- in the following order:
- 1) use another clock disjoint still live variable,
- with the greatest possible disjoint clock
- 2) reuse a dead variable
- For the sake of safety, we replace variables by others:
- - with the same type
- - not aliasable (i.e. address type)
-*)
-
-(* Local Variables: *)
-(* compile-command:"make -C .." *)
-(* End: *)
+(********************************************************************)
+(* *)
+(* 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 Lustre_types
+open Corelang
+open Causality
+
+type context = {
+ mutable evaluated : Disjunction.CISet.t;
+ dep_graph : IdentDepGraph.t;
+ disjoint : (ident, Disjunction.CISet.t) Hashtbl.t;
+ policy : (ident, var_decl) Hashtbl.t;
+}
+
+(* computes the in-degree for each local variable of node [n], according to dep
+ graph [g]. *)
+let compute_fanin n g =
+ let locals =
+ ISet.diff (ExprDep.node_local_variables n) (ExprDep.node_memory_variables n)
+ in
+ let inputs = ExprDep.node_input_variables n in
+ let fanin = Hashtbl.create 23 in
+ IdentDepGraph.iter_vertex
+ (fun v ->
+ if ISet.mem v locals then
+ Hashtbl.add fanin v (IdentDepGraph.in_degree g v)
+ else if ExprDep.is_read_var v && not (ISet.mem v inputs) then
+ Hashtbl.add fanin (ExprDep.undo_read_var v)
+ (IdentDepGraph.in_degree g v))
+ g;
+ fanin
+
+let pp_fanin fmt fanin =
+ Format.fprintf fmt "@[<v 0>@[<v 2>{ /* locals fanin: */";
+ Hashtbl.iter (fun s t -> Format.fprintf fmt "@ %s -> %d" s t) fanin;
+ Format.fprintf fmt "@]@ }@]"
+
+(* computes the cone of influence of a given [var] wrt a dependency graph [g]. *)
+let cone_of_influence g var =
+ (*Format.printf "DEBUG coi: %s@." var;*)
+ let frontier = ref (ISet.add var ISet.empty) in
+ let explored = ref ISet.empty in
+ let coi = ref ISet.empty in
+ while not (ISet.is_empty !frontier) do
+ let head = ISet.min_elt !frontier in
+ (*Format.printf "DEBUG head: %s@." head;*)
+ frontier := ISet.remove head !frontier;
+ explored := ISet.add head !explored;
+ if ExprDep.is_read_var head then
+ coi := ISet.add (ExprDep.undo_read_var head) !coi;
+ List.iter
+ (fun s ->
+ if not (ISet.mem s !explored) then frontier := ISet.add s !frontier)
+ (IdentDepGraph.succ g head)
+ done;
+ !coi
+
+let compute_unused_variables n g =
+ let inputs = ExprDep.node_input_variables n in
+ let mems = ExprDep.node_memory_variables n in
+ let outputs = ExprDep.node_output_variables n in
+ ISet.fold
+ (fun var unused -> ISet.diff unused (cone_of_influence g var))
+ (ISet.union outputs mems) (ISet.union inputs mems)
+
+(* computes the set of potentially reusable variables. We don't reuse input
+ variables, due to possible aliasing *)
+let node_reusable_variables node =
+ let mems = ExprDep.node_memory_variables node in
+ List.fold_left
+ (fun acc l ->
+ if ISet.mem l.var_id mems then acc else Disjunction.CISet.add l acc)
+ Disjunction.CISet.empty node.node_locals
+
+let kill_instance_variables ctx inst =
+ IdentDepGraph.remove_vertex ctx.dep_graph inst
+
+let kill_root ctx head =
+ IdentDepGraph.iter_succ
+ (IdentDepGraph.remove_edge ctx.dep_graph head.var_id)
+ ctx.dep_graph head.var_id
+
+(* Recursively removes useless variables, i.e. [ctx.evaluated] variables that
+ are current roots of the dep graph [ctx.dep_graph] - [evaluated] is the set
+ of already evaluated variables, wrt the scheduling - does only remove edges,
+ not variables themselves - yet, instance variables are removed *)
+let remove_roots ctx =
+ let rem = ref true in
+ let remaining = ref ctx.evaluated in
+ while !rem do
+ rem := false;
+ let all_roots = graph_roots ctx.dep_graph in
+ let inst_roots, var_roots =
+ List.partition
+ (fun v -> ExprDep.is_instance_var v && v <> Causality.world)
+ all_roots
+ in
+ let frontier_roots =
+ Disjunction.CISet.filter (fun v -> List.mem v.var_id var_roots) !remaining
+ in
+ if not (Disjunction.CISet.is_empty frontier_roots && inst_roots = []) then (
+ rem := true;
+ List.iter (kill_instance_variables ctx) inst_roots;
+ Disjunction.CISet.iter (kill_root ctx) frontier_roots;
+ remaining := Disjunction.CISet.diff !remaining frontier_roots)
+ done
+
+(* checks whether a variable is aliasable, depending on its (address) type *)
+let is_aliasable var =
+ (not (!Options.mpfr && Types.is_real_type var.var_type))
+ && Types.is_address_type var.var_type
+
+(* checks whether a variable [v] is an input of the [var] equation, with an
+ address type. if so, [var] could not safely reuse/alias [v], should [v] be
+ dead in the caller node, because [v] may not be dead in the callee node when
+ [var] is assigned *)
+let is_aliasable_input node var =
+ let eq_var = get_node_eq var node in
+ let inputs_var =
+ match NodeDep.get_callee eq_var.eq_rhs with
+ | None ->
+ []
+ | Some (_, args) ->
+ List.fold_right
+ (fun e r -> match e.expr_desc with Expr_ident id -> id :: r | _ -> r)
+ args []
+ in
+ fun v -> is_aliasable v && List.mem v.var_id inputs_var
+
+(* replace variable [v] by [v'] in graph [g]. [v'] is a dead variable *)
+let replace_in_dep_graph v v' g =
+ IdentDepGraph.add_vertex g v';
+ IdentDepGraph.iter_succ (fun s -> IdentDepGraph.add_edge g v' s) g v;
+ IdentDepGraph.iter_pred (fun p -> IdentDepGraph.add_edge g p v') g v;
+ IdentDepGraph.remove_vertex g v
+
+let pp_reuse_policy fmt policy =
+ Format.(
+ fprintf fmt "@[<v 2>{ /* reuse policy */%t@] }" (fun fmt ->
+ Hashtbl.iter (fun s t -> fprintf fmt "@,%s -> %s" s t.var_id) policy))
+
+let pp_context fmt ctx =
+ Format.fprintf fmt
+ "@[<v 2>{ /*BEGIN context */@,\
+ eval = %a;@,\
+ graph = %a;@,\
+ disjoint = %a;@,\
+ policy = %a;@,\
+ /* END context */ }@]" Disjunction.pp_ciset ctx.evaluated pp_dep_graph
+ ctx.dep_graph Disjunction.pp_disjoint_map ctx.disjoint pp_reuse_policy
+ ctx.policy
+
+(* computes the reusable dependencies of variable [var] in graph [g], once [var]
+ has been evaluated - [locals] is the set of potentially reusable variables -
+ [evaluated] is the set of evaluated variables - [quasi] is the set of
+ quasi-reusable variables - [reusable] is the set of dead/reusable
+ dependencies of [var] in graph [g] - [policy] is the reuse map (which domain
+ is [evaluated]) *)
+let compute_dependencies heads ctx =
+ (*Log.report ~level:6 (fun fmt -> Format.fprintf fmt
+ "compute_reusable_dependencies %a %a %a@." Disjunction.pp_ciset locals
+ Printers.pp_var_name var pp_context ctx);*)
+ List.iter (kill_root ctx) heads;
+ remove_roots ctx
+
+let compute_evaluated heads ctx =
+ List.iter
+ (fun head -> ctx.evaluated <- Disjunction.CISet.add head ctx.evaluated)
+ heads
+
+(* tests whether a variable [v] may be (re)used instead of [var]. The conditions
+ are: - [v] has been really used ([v] is its own representative) - same type -
+ [v] is not an aliasable input of the equation defining [var] - [v] is not one
+ of the current heads (which contain [var]) - [v] is not currently in use *)
+let eligible node ctx heads var v =
+ Hashtbl.find ctx.policy v.var_id == v
+ && Typing.eq_ground
+ (Types.unclock_type var.var_type)
+ (Types.unclock_type v.var_type)
+ && (not (is_aliasable_input node var.var_id v))
+ && (not (List.exists (fun h -> h.var_id = v.var_id) heads))
+ && (*let repr_v = Hashtbl.find ctx.policy v.var_id*)
+ not
+ (Disjunction.CISet.exists
+ (fun p -> IdentDepGraph.mem_edge ctx.dep_graph p.var_id v.var_id)
+ ctx.evaluated)
+
+let compute_reuse node ctx heads var =
+ let disjoint = Hashtbl.find ctx.disjoint var.var_id in
+ let locally_reusable v =
+ IdentDepGraph.fold_pred
+ (fun p r ->
+ r && Disjunction.CISet.exists (fun d -> p = d.var_id) disjoint)
+ ctx.dep_graph v.var_id true
+ in
+ let eligibles =
+ if ISet.mem var.var_id (ExprDep.node_memory_variables node) then
+ Disjunction.CISet.empty
+ else Disjunction.CISet.filter (eligible node ctx heads var) ctx.evaluated
+ in
+ let quasi_dead, live =
+ Disjunction.CISet.partition locally_reusable eligibles
+ in
+ let disjoint_live = Disjunction.CISet.inter disjoint live in
+ let dead =
+ Disjunction.CISet.filter
+ (fun v -> is_graph_root v.var_id ctx.dep_graph)
+ quasi_dead
+ in
+ Log.report ~level:7 (fun fmt ->
+ Format.fprintf fmt
+ "@[<v>eligibles : %a@,\
+ live : %a@,\
+ disjoint live: %a@,\
+ dead : %a@,\
+ @]"
+ Disjunction.pp_ciset eligibles Disjunction.pp_ciset live
+ Disjunction.pp_ciset disjoint_live Disjunction.pp_ciset dead);
+ (try
+ let reuse =
+ match Disjunction.CISet.max_elt_opt disjoint_live with
+ | Some reuse ->
+ reuse
+ | None ->
+ Disjunction.CISet.choose dead
+ in
+ IdentDepGraph.add_edge ctx.dep_graph var.var_id reuse.var_id;
+ Hashtbl.add ctx.policy var.var_id reuse
+ with Not_found -> Hashtbl.add ctx.policy var.var_id var);
+ ctx.evaluated <- Disjunction.CISet.add var ctx.evaluated
+
+let compute_reuse_policy node schedule disjoint g =
+ let ctx =
+ {
+ evaluated = Disjunction.CISet.empty;
+ dep_graph = g;
+ disjoint;
+ policy = Hashtbl.create 23;
+ }
+ in
+ List.iter
+ (fun heads ->
+ let heads = List.map (fun v -> get_node_var v node) heads in
+ Log.report ~level:6 (fun fmt ->
+ Format.(
+ fprintf fmt
+ "@[<v>@[<v 2>new context:@,\
+ %a@]@,\
+ NEW HEADS:%a@,\
+ COMPUTE_DEPENDENCIES@,\
+ @]"
+ pp_context ctx
+ (pp_print_list ~pp_open_box:pp_open_hbox ~pp_sep:pp_print_space
+ (fun fmt head ->
+ fprintf fmt "%s (%a)" head.var_id Printers.pp_node_eq
+ (get_node_eq head.var_id node)))
+ heads));
+ compute_dependencies heads ctx;
+ Log.report ~level:6 (fun fmt ->
+ Format.fprintf fmt "@[<v>@[<v 2>new context:@,%a@]@,COMPUTE_REUSE@,@]"
+ pp_context ctx);
+ List.iter (compute_reuse node ctx heads) heads;
+ (*compute_evaluated heads ctx;*)
+ Log.report ~level:6 (fun fmt ->
+ Format.(
+ fprintf fmt "@[<v>%a@,@]"
+ (pp_print_list ~pp_open_box:pp_open_vbox0 (fun fmt head ->
+ fprintf fmt "reuse %s instead of %s"
+ (Hashtbl.find ctx.policy head.var_id).var_id head.var_id))
+ heads)))
+ schedule;
+ IdentDepGraph.clear ctx.dep_graph;
+ ctx.policy
+
+(* Reuse policy: - could reuse variables with the same type exactly only
+ (simple). - reusing variables with different types would involve: - either
+ dirty castings - or complex inclusion expression (for instance: array <->
+ array cell, struct <-> struct field) to be able to reuse only some parts of
+ structured data. ... it seems too complex and potentially unsafe - for node
+ instance calls: output variables could NOT reuse aliasable input variables,
+ even if inputs become dead, because the correctness would depend on the
+ scheduling of the callee (so, the compiling strategy could NOT be modular
+ anymore). - once a policy is set, we need to: - replace each variable by its
+ reuse alias. - simplify resulting equations, as we may now have: x = x; --> ;
+ for scalar vars or: x = &{ f1 = x->f1; f2 = t; } --> x->f2 = t; for struct
+ vars *)
+
+(* the reuse policy seeks to use less local variables by replacing local
+ variables, applying the rules in the following order: 1) use another clock
+ disjoint still live variable, with the greatest possible disjoint clock 2)
+ reuse a dead variable For the sake of safety, we replace variables by others:
+ - with the same type - not aliasable (i.e. address type) *)
+
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
diff --git a/src/checks/stateless.ml b/src/checks/stateless.ml
index 4fee77e713288aea47563495805fd519e8e47ac1..3d4cc7b39fbb79964d42a152db152298ccba0cc9 100644
--- a/src/checks/stateless.ml
+++ b/src/checks/stateless.ml
@@ -13,124 +13,129 @@ open Lustre_types
open Corelang
type error =
-| Stateful_kwd of ident
-| Stateful_imp of ident
-| Stateful_ext_C of ident
+ | Stateful_kwd of ident
+ | Stateful_imp of ident
+ | Stateful_ext_C of ident
exception Error of Location.t * error
let rec check_expr expr =
match expr.expr_desc with
- | Expr_const _
- | Expr_ident _ -> true
- | Expr_tuple el
- | Expr_array el -> List.for_all check_expr el
- | Expr_access (e1, _)
- | Expr_power (e1, _) -> check_expr e1
- | Expr_ite (c, t, e) -> check_expr c && check_expr t && check_expr e
- | Expr_arrow _
- | Expr_fby _
- | Expr_pre _ -> false
- | Expr_when (e', _, _)-> check_expr e'
- | Expr_merge (_, hl) -> List.for_all (fun (_, h) -> check_expr h) hl
+ | Expr_const _ | Expr_ident _ ->
+ true
+ | Expr_tuple el | Expr_array el ->
+ List.for_all check_expr el
+ | Expr_access (e1, _) | Expr_power (e1, _) ->
+ check_expr e1
+ | Expr_ite (c, t, e) ->
+ check_expr c && check_expr t && check_expr e
+ | Expr_arrow _ | Expr_fby _ | Expr_pre _ ->
+ false
+ | Expr_when (e', _, _) ->
+ check_expr e'
+ | Expr_merge (_, hl) ->
+ List.for_all (fun (_, h) -> check_expr h) hl
| Expr_appl (i, e', i') ->
- let reset_opt = (match i' with None -> true | Some e'' -> check_expr e'') in
- let stateless_node =
- (Basic_library.is_stateless_fun i || (
- try
- check_node (node_from_name i)
- with Not_found ->
- let loc = expr.expr_loc in
- Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unable to find node %s in expression %a" i Printers.pp_expr expr);
- raise (Error.Error (loc, Error.Unbound_symbol i))
- ))
- in
- (* Warning message when trying to reset a stateless node *)
- if stateless_node && not reset_opt then
- Error.pp_warning expr.expr_loc (fun fmt -> Format.fprintf fmt "Trying to reset call the stateless node or op %s" i)
- ;
- check_expr e' && reset_opt && stateless_node
-
-and compute_node nd = (* returns true iff the node is stateless.*)
+ let reset_opt = match i' with None -> true | Some e'' -> check_expr e'' in
+ let stateless_node =
+ Basic_library.is_stateless_fun i
+ ||
+ try check_node (node_from_name i)
+ with Not_found ->
+ let loc = expr.expr_loc in
+ Error.pp_error loc (fun fmt ->
+ Format.fprintf fmt "Unable to find node %s in expression %a" i
+ Printers.pp_expr expr);
+ raise (Error.Error (loc, Error.Unbound_symbol i))
+ in
+ (* Warning message when trying to reset a stateless node *)
+ if stateless_node && not reset_opt then
+ Error.pp_warning expr.expr_loc (fun fmt ->
+ Format.fprintf fmt "Trying to reset call the stateless node or op %s"
+ i);
+ check_expr e' && reset_opt && stateless_node
+
+and compute_node nd =
+ (* returns true iff the node is stateless.*)
let eqs, aut = get_node_eqs nd in
- aut = [] && (* A node containinig an automaton will be stateful *)
- List.for_all (fun eq -> check_expr eq.eq_rhs) eqs
+ aut = []
+ && (* A node containinig an automaton will be stateful *)
+ List.for_all (fun eq -> check_expr eq.eq_rhs) eqs
+
and check_node td =
- match td.top_decl_desc with
- | Node nd -> (
+ match td.top_decl_desc with
+ | Node nd -> (
match nd.node_stateless with
- | None ->
- begin
- let stateless = compute_node nd in
- nd.node_stateless <- Some stateless;
- if nd.node_dec_stateless && (not stateless)
- then raise (Error (td.top_decl_loc, Stateful_kwd nd.node_id))
- else (nd.node_dec_stateless <- stateless; stateless)
- end
- | Some stl -> stl)
+ | None ->
+ let stateless = compute_node nd in
+ nd.node_stateless <- Some stateless;
+ if nd.node_dec_stateless && not stateless then
+ raise (Error (td.top_decl_loc, Stateful_kwd nd.node_id))
+ else (
+ nd.node_dec_stateless <- stateless;
+ stateless)
+ | Some stl ->
+ stl)
| ImportedNode nd ->
- begin
- (if nd.nodei_prototype = Some "C" && not nd.nodei_stateless
- then raise (Error (td.top_decl_loc, Stateful_ext_C nd.nodei_id)));
- nd.nodei_stateless
- end
- | _ -> true
-
-let check_prog decls =
- List.iter (fun td -> ignore (check_node td)) decls
+ if nd.nodei_prototype = Some "C" && not nd.nodei_stateless then
+ raise (Error (td.top_decl_loc, Stateful_ext_C nd.nodei_id));
+ nd.nodei_stateless
+ | _ ->
+ true
+let check_prog decls = List.iter (fun td -> ignore (check_node td)) decls
let force_prog decls =
let force_node td =
- match td.top_decl_desc with
- | Node nd -> (
+ match td.top_decl_desc with
+ | Node nd ->
nd.node_dec_stateless <- false;
- nd.node_stateless <- Some false)
- | _ -> ()
+ nd.node_stateless <- Some false
+ | _ ->
+ ()
in
List.iter (fun td -> ignore (force_node td)) decls
let check_compat_decl decl =
match decl.top_decl_desc with
- | ImportedNode nd -> (* A node declared in the header (lusi) shall
- be locally defined with compatible stateless
- flag *)
- begin
- let td = Corelang.node_from_name nd.nodei_id in
- (match td.top_decl_desc with
- | Node nd' -> let stateless = check_node td in
- if nd.nodei_stateless && (not stateless)
- then raise (Error (td.top_decl_loc, Stateful_imp nd.nodei_id))
- else nd'.node_dec_stateless <- nd.nodei_stateless
- | _ -> assert false)
- end
+ | ImportedNode nd -> (
+ (* A node declared in the header (lusi) shall be locally defined with
+ compatible stateless flag *)
+ let td = Corelang.node_from_name nd.nodei_id in
+ match td.top_decl_desc with
+ | Node nd' ->
+ let stateless = check_node td in
+ if nd.nodei_stateless && not stateless then
+ raise (Error (td.top_decl_loc, Stateful_imp nd.nodei_id))
+ else nd'.node_dec_stateless <- nd.nodei_stateless
+ | _ ->
+ assert false)
| Node nd -> (
- match nd.node_spec with
- Some (Contract _) -> (* A contract element in a header does not
- need to be provided in the associed lus
- file *)
- ()
- | _ -> assert false)
-
- | _ -> ()
+ match nd.node_spec with
+ | Some (Contract _) ->
+ (* A contract element in a header does not need to be provided in the
+ associed lus file *)
+ ()
+ | _ ->
+ assert false)
+ | _ ->
+ ()
-let check_compat header =
- List.iter check_compat_decl header
+let check_compat header = List.iter check_compat_decl header
let pp_error fmt err =
match err with
| Stateful_kwd nd ->
- Format.fprintf fmt
- "node %s should be stateless but is actually stateful.@."
- nd
+ Format.fprintf fmt "node %s should be stateless but is actually stateful.@."
+ nd
| Stateful_imp nd ->
- Format.fprintf fmt
- "node %s is declared stateless but is actually stateful.@."
- nd
+ Format.fprintf fmt
+ "node %s is declared stateless but is actually stateful.@." nd
| Stateful_ext_C nd ->
- Format.fprintf fmt
- "node %s with declared prototype C cannot be stateful, it has to be a function.@."
- nd
+ Format.fprintf fmt
+ "node %s with declared prototype C cannot be stateful, it has to be a \
+ function.@."
+ nd
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/clock_calculus.ml b/src/clock_calculus.ml
index 8bdd03cacbce3bc7e117d2e88969f687528c5270..dd72307c06bd63e5b64ca703e358ece71265caf4 100644
--- a/src/clock_calculus.ml
+++ b/src/clock_calculus.ml
@@ -6,18 +6,17 @@
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)
(* under the terms of the GNU Lesser General Public License *)
(* version 2.1. *)
-(* *)
+(* *)
(* This file was originally from the Prelude compiler *)
-(* *)
+(* *)
(********************************************************************)
-
(** Main clock-calculus module. Based on type inference algorithms with
- destructive unification. Uses a bit of subtyping for periodic clocks. *)
+ destructive unification. Uses a bit of subtyping for periodic clocks. *)
-(* Though it shares similarities with the typing module, no code
- is shared. Simple environments, very limited identifier scoping, no
- identifier redefinition allowed. *)
+(* Though it shares similarities with the typing module, no code is shared.
+ Simple environments, very limited identifier scoping, no identifier
+ redefinition allowed. *)
open Utils
open Lustre_types
open Corelang
@@ -25,59 +24,67 @@ open Clocks
let loc_of_cond (_s, e) id =
let pos_start =
- { e with Lexing.pos_cnum = e.Lexing.pos_cnum - (String.length id) }
+ { e with Lexing.pos_cnum = e.Lexing.pos_cnum - String.length id }
in
pos_start, e
-(** [occurs cvar ck] returns true if the clock variable [cvar] occurs in
- clock [ck]. False otherwise. *)
+(** [occurs cvar ck] returns true if the clock variable [cvar] occurs in clock
+ [ck]. False otherwise. *)
let rec occurs cvar ck =
let ck = repr ck in
match ck.cdesc with
| Carrow (ck1, ck2) ->
- (occurs cvar ck1) || (occurs cvar ck2)
+ occurs cvar ck1 || occurs cvar ck2
| Ctuple ckl ->
- List.exists (occurs cvar) ckl
- | Con (ck',_,_) -> occurs cvar ck'
- | Cvar -> ck=cvar
- | Cunivar -> false
- | Clink ck' -> occurs cvar ck'
- | Ccarrying (_,ck') -> occurs cvar ck'
+ List.exists (occurs cvar) ckl
+ | Con (ck', _, _) ->
+ occurs cvar ck'
+ | Cvar ->
+ ck = cvar
+ | Cunivar ->
+ false
+ | Clink ck' ->
+ occurs cvar ck'
+ | Ccarrying (_, ck') ->
+ occurs cvar ck'
(* Clocks generalization *)
let rec generalize_carrier cr =
match cr.carrier_desc with
- | Carry_const _
- | Carry_name ->
- if cr.carrier_scoped then
- raise (Scope_carrier cr);
+ | Carry_const _ | Carry_name ->
+ if cr.carrier_scoped then raise (Scope_carrier cr);
cr.carrier_desc <- Carry_var
- | Carry_var -> ()
- | Carry_link cr' -> generalize_carrier cr'
+ | Carry_var ->
+ ()
+ | Carry_link cr' ->
+ generalize_carrier cr'
-(** Promote monomorphic clock variables to polymorphic clock variables. *)
(* Generalize by side-effects *)
+
+(** Promote monomorphic clock variables to polymorphic clock variables. *)
let rec generalize ck =
match ck.cdesc with
- | Carrow (ck1,ck2) ->
- generalize ck1; generalize ck2
+ | Carrow (ck1, ck2) ->
+ generalize ck1;
+ generalize ck2
| Ctuple clist ->
List.iter generalize clist
- | Con (ck',cr,_) -> generalize ck'; generalize_carrier cr
+ | Con (ck', cr, _) ->
+ generalize ck';
+ generalize_carrier cr
| Cvar ->
- if ck.cscoped then
- raise (Scope_clock ck);
+ if ck.cscoped then raise (Scope_clock ck);
ck.cdesc <- Cunivar
- | Cunivar -> ()
+ | Cunivar ->
+ ()
| Clink ck' ->
generalize ck'
- | Ccarrying (cr,ck') ->
- generalize_carrier cr; generalize ck'
+ | Ccarrying (cr, ck') ->
+ generalize_carrier cr;
+ generalize ck'
let try_generalize ck_node loc =
- try
- generalize ck_node
- with
+ try generalize ck_node with
| Scope_carrier cr ->
raise (Error (loc, Carrier_extrusion (ck_node, cr)))
| Scope_clock ck ->
@@ -87,408 +94,389 @@ let try_generalize ck_node loc =
let instantiate_carrier cr inst_cr_vars =
let cr = carrier_repr cr in
match cr.carrier_desc with
- | Carry_const _
- | Carry_name -> cr
+ | Carry_const _ | Carry_name ->
+ cr
| Carry_link _ ->
- failwith "Internal error"
- | Carry_var ->
- try
- List.assoc cr.carrier_id !inst_cr_vars
- with Not_found ->
- let cr_var = new_carrier Carry_name true in
- inst_cr_vars := (cr.carrier_id,cr_var)::!inst_cr_vars;
- cr_var
+ failwith "Internal error"
+ | Carry_var -> (
+ try List.assoc cr.carrier_id !inst_cr_vars
+ with Not_found ->
+ let cr_var = new_carrier Carry_name true in
+ inst_cr_vars := (cr.carrier_id, cr_var) :: !inst_cr_vars;
+ cr_var)
+
+(* inst_ck_vars ensures that a polymorphic variable is instanciated with the
+ same monomorphic variable if it occurs several times in the same type.
+ inst_cr_vars is the same for carriers. *)
(** Downgrade polymorphic clock variables to monomorphic clock variables *)
-(* inst_ck_vars ensures that a polymorphic variable is instanciated with
- the same monomorphic variable if it occurs several times in the same
- type. inst_cr_vars is the same for carriers. *)
let rec instantiate inst_ck_vars inst_cr_vars ck =
match ck.cdesc with
- | Carrow (ck1,ck2) ->
- {ck with cdesc =
- Carrow ((instantiate inst_ck_vars inst_cr_vars ck1),
- (instantiate inst_ck_vars inst_cr_vars ck2))}
+ | Carrow (ck1, ck2) ->
+ {
+ ck with
+ cdesc =
+ Carrow
+ ( instantiate inst_ck_vars inst_cr_vars ck1,
+ instantiate inst_ck_vars inst_cr_vars ck2 );
+ }
| Ctuple cklist ->
- {ck with cdesc = Ctuple
- (List.map (instantiate inst_ck_vars inst_cr_vars) cklist)}
- | Con (ck',c,l) ->
- let c' = instantiate_carrier c inst_cr_vars in
- {ck with cdesc = Con ((instantiate inst_ck_vars inst_cr_vars ck'),c',l)}
- | Cvar -> ck
+ {
+ ck with
+ cdesc = Ctuple (List.map (instantiate inst_ck_vars inst_cr_vars) cklist);
+ }
+ | Con (ck', c, l) ->
+ let c' = instantiate_carrier c inst_cr_vars in
+ { ck with cdesc = Con (instantiate inst_ck_vars inst_cr_vars ck', c', l) }
+ | Cvar ->
+ ck
| Clink ck' ->
- {ck with cdesc = Clink (instantiate inst_ck_vars inst_cr_vars ck')}
- | Ccarrying (cr,ck') ->
- let cr' = instantiate_carrier cr inst_cr_vars in
- {ck with cdesc =
- Ccarrying (cr',instantiate inst_ck_vars inst_cr_vars ck')}
- | Cunivar ->
- try
- List.assoc ck.cid !inst_ck_vars
- with Not_found ->
- let var = new_ck Cvar true in
- inst_ck_vars := (ck.cid, var)::!inst_ck_vars;
- var
-
+ { ck with cdesc = Clink (instantiate inst_ck_vars inst_cr_vars ck') }
+ | Ccarrying (cr, ck') ->
+ let cr' = instantiate_carrier cr inst_cr_vars in
+ {
+ ck with
+ cdesc = Ccarrying (cr', instantiate inst_ck_vars inst_cr_vars ck');
+ }
+ | Cunivar -> (
+ try List.assoc ck.cid !inst_ck_vars
+ with Not_found ->
+ let var = new_ck Cvar true in
+ inst_ck_vars := (ck.cid, var) :: !inst_ck_vars;
+ var)
let rec update_scope_carrier scoped cr =
- if (not scoped) then
- begin
- cr.carrier_scoped <- scoped;
- match cr.carrier_desc with
- | Carry_const _ | Carry_name | Carry_var -> ()
- | Carry_link cr' -> update_scope_carrier scoped cr'
- end
+ if not scoped then (
+ cr.carrier_scoped <- scoped;
+ match cr.carrier_desc with
+ | Carry_const _ | Carry_name | Carry_var ->
+ ()
+ | Carry_link cr' ->
+ update_scope_carrier scoped cr')
let rec update_scope scoped ck =
- if (not scoped) then
- begin
- ck.cscoped <- scoped;
- match ck.cdesc with
- | Carrow (ck1,ck2) ->
- update_scope scoped ck1; update_scope scoped ck2
- | Ctuple clist ->
- List.iter (update_scope scoped) clist
- | Con (ck', _, _) -> update_scope scoped ck'(*; update_scope_carrier scoped cr*)
- | Cvar | Cunivar -> ()
- | Clink ck' ->
- update_scope scoped ck'
- | Ccarrying (cr,ck') ->
- update_scope_carrier scoped cr; update_scope scoped ck'
- end
-
+ if not scoped then (
+ ck.cscoped <- scoped;
+ match ck.cdesc with
+ | Carrow (ck1, ck2) ->
+ update_scope scoped ck1;
+ update_scope scoped ck2
+ | Ctuple clist ->
+ List.iter (update_scope scoped) clist
+ | Con (ck', _, _) ->
+ update_scope scoped ck' (*; update_scope_carrier scoped cr*)
+ | Cvar | Cunivar ->
+ ()
+ | Clink ck' ->
+ update_scope scoped ck'
+ | Ccarrying (cr, ck') ->
+ update_scope_carrier scoped cr;
+ update_scope scoped ck')
(* Unifies two clock carriers *)
let unify_carrier cr1 cr2 =
let cr1 = carrier_repr cr1 in
let cr2 = carrier_repr cr2 in
- if cr1==cr2 then ()
+ if cr1 == cr2 then ()
else
match cr1.carrier_desc, cr2.carrier_desc with
| Carry_const id1, Carry_const id2 ->
if id1 <> id2 then raise (Mismatch (cr1, cr2))
| Carry_const _, Carry_name ->
- begin
- cr2.carrier_desc <- Carry_link cr1;
- update_scope_carrier cr2.carrier_scoped cr1
- end
+ cr2.carrier_desc <- Carry_link cr1;
+ update_scope_carrier cr2.carrier_scoped cr1
| Carry_name, Carry_const _ ->
- begin
- cr1.carrier_desc <- Carry_link cr2;
- update_scope_carrier cr1.carrier_scoped cr2
- end
+ cr1.carrier_desc <- Carry_link cr2;
+ update_scope_carrier cr1.carrier_scoped cr2
| Carry_name, Carry_name ->
- if cr1.carrier_id < cr2.carrier_id then
- begin
- cr2.carrier_desc <- Carry_link cr1;
- update_scope_carrier cr2.carrier_scoped cr1
- end
- else
- begin
- cr1.carrier_desc <- Carry_link cr2;
- update_scope_carrier cr1.carrier_scoped cr2
- end
- | _,_ -> assert false
+ if cr1.carrier_id < cr2.carrier_id then (
+ cr2.carrier_desc <- Carry_link cr1;
+ update_scope_carrier cr2.carrier_scoped cr1)
+ else (
+ cr1.carrier_desc <- Carry_link cr2;
+ update_scope_carrier cr1.carrier_scoped cr2)
+ | _, _ ->
+ assert false
(* Semi-unifies two clock carriers *)
let semi_unify_carrier cr1 cr2 =
let cr1 = carrier_repr cr1 in
let cr2 = carrier_repr cr2 in
- if cr1==cr2 then ()
+ if cr1 == cr2 then ()
else
match cr1.carrier_desc, cr2.carrier_desc with
| Carry_const id1, Carry_const id2 ->
if id1 <> id2 then raise (Mismatch (cr1, cr2))
| Carry_const _, Carry_name ->
- begin
- cr2.carrier_desc <- Carry_link cr1;
- update_scope_carrier cr2.carrier_scoped cr1
- end
- | Carry_name, Carry_const _ -> raise (Mismatch (cr1, cr2))
+ cr2.carrier_desc <- Carry_link cr1;
+ update_scope_carrier cr2.carrier_scoped cr1
+ | Carry_name, Carry_const _ ->
+ raise (Mismatch (cr1, cr2))
| Carry_name, Carry_name ->
- if cr1.carrier_id < cr2.carrier_id then
- begin
- cr2.carrier_desc <- Carry_link cr1;
- update_scope_carrier cr2.carrier_scoped cr1
- end
- else
- begin
- cr1.carrier_desc <- Carry_link cr2;
- update_scope_carrier cr1.carrier_scoped cr2
- end
- | _,_ -> assert false
+ if cr1.carrier_id < cr2.carrier_id then (
+ cr2.carrier_desc <- Carry_link cr1;
+ update_scope_carrier cr2.carrier_scoped cr1)
+ else (
+ cr1.carrier_desc <- Carry_link cr2;
+ update_scope_carrier cr1.carrier_scoped cr2)
+ | _, _ ->
+ assert false
let try_unify_carrier ck1 ck2 loc =
- try
- unify_carrier ck1 ck2
- with
- | Unify (ck1',ck2') ->
- raise (Error (loc, Clock_clash (ck1',ck2')))
- | Mismatch (cr1,cr2) ->
- raise (Error (loc, Carrier_mismatch (cr1,cr2)))
-
-(** [unify ck1 ck2] unifies clocks [ck1] and [ck2]. Raises [Unify
- (ck1,ck2)] if the clocks are not unifiable.*)
+ try unify_carrier ck1 ck2 with
+ | Unify (ck1', ck2') ->
+ raise (Error (loc, Clock_clash (ck1', ck2')))
+ | Mismatch (cr1, cr2) ->
+ raise (Error (loc, Carrier_mismatch (cr1, cr2)))
+
+(** [unify ck1 ck2] unifies clocks [ck1] and [ck2]. Raises [Unify (ck1,ck2)] if
+ the clocks are not unifiable.*)
let rec unify ck1 ck2 =
let ck1 = repr ck1 in
let ck2 = repr ck2 in
- if ck1==ck2 then
- ()
+ if ck1 == ck2 then ()
else
- match ck1.cdesc,ck2.cdesc with
+ match ck1.cdesc, ck2.cdesc with
| Cvar, Cvar ->
- if ck1.cid < ck2.cid then
- begin
- ck2.cdesc <- Clink (simplify ck1);
- update_scope ck2.cscoped ck1
- end
- else
- begin
- ck1.cdesc <- Clink (simplify ck2);
- update_scope ck1.cscoped ck2
- end
- | (Cvar, _) when (not (occurs ck1 ck2)) ->
+ if ck1.cid < ck2.cid then (
+ ck2.cdesc <- Clink (simplify ck1);
+ update_scope ck2.cscoped ck1)
+ else (
+ ck1.cdesc <- Clink (simplify ck2);
+ update_scope ck1.cscoped ck2)
+ | Cvar, _ when not (occurs ck1 ck2) ->
update_scope ck1.cscoped ck2;
ck1.cdesc <- Clink (simplify ck2)
- | (_, Cvar) when (not (occurs ck2 ck1)) ->
+ | _, Cvar when not (occurs ck2 ck1) ->
update_scope ck2.cscoped ck1;
ck2.cdesc <- Clink (simplify ck1)
- | Ccarrying (cr1,ck1'),Ccarrying (cr2,ck2') ->
+ | Ccarrying (cr1, ck1'), Ccarrying (cr2, ck2') ->
unify_carrier cr1 cr2;
unify ck1' ck2'
- | Ccarrying (_,_),_ | _,Ccarrying (_,_) ->
- raise (Unify (ck1,ck2))
- | Carrow (c1,c2), Carrow (c1',c2') ->
- unify c1 c1'; unify c2 c2'
+ | Ccarrying (_, _), _ | _, Ccarrying (_, _) ->
+ raise (Unify (ck1, ck2))
+ | Carrow (c1, c2), Carrow (c1', c2') ->
+ unify c1 c1';
+ unify c2 c2'
| Ctuple ckl1, Ctuple ckl2 ->
- if (List.length ckl1) <> (List.length ckl2) then
- raise (Unify (ck1,ck2));
+ if List.length ckl1 <> List.length ckl2 then raise (Unify (ck1, ck2));
List.iter2 unify ckl1 ckl2
- | Con (ck',c1,l1), Con (ck'',c2,l2) when l1=l2 ->
+ | Con (ck', c1, l1), Con (ck'', c2, l2) when l1 = l2 ->
unify_carrier c1 c2;
unify ck' ck''
- | Cunivar, _ | _, Cunivar -> ()
- | _,_ -> raise (Unify (ck1,ck2))
+ | Cunivar, _ | _, Cunivar ->
+ ()
+ | _, _ ->
+ raise (Unify (ck1, ck2))
(** [unify ck1 ck2] semi-unifies clocks [ck1] and [ck2]. Raises [Unify
(ck1,ck2)] if the clocks are not semi-unifiable.*)
let rec semi_unify ck1 ck2 =
let ck1 = repr ck1 in
let ck2 = repr ck2 in
- if ck1==ck2 then
- ()
+ if ck1 == ck2 then ()
else
- match ck1.cdesc,ck2.cdesc with
- | Cvar, Cvar ->
- if ck1.cid < ck2.cid then
- begin
- ck2.cdesc <- Clink (simplify ck1);
- update_scope ck2.cscoped ck1
- end
- else
- begin
- ck1.cdesc <- Clink (simplify ck2);
- update_scope ck1.cscoped ck2
- end
- | (Cvar, _) -> raise (Unify (ck1,ck2))
- | (_, Cvar) when (not (occurs ck2 ck1)) ->
- update_scope ck2.cscoped ck1;
- ck2.cdesc <- Clink (simplify ck1)
- | Ccarrying (cr1,ck1'),Ccarrying (cr2,ck2') ->
- semi_unify_carrier cr1 cr2;
- semi_unify ck1' ck2'
- | Ccarrying (_,_),_ | _,Ccarrying (_,_) ->
- raise (Unify (ck1,ck2))
- | Carrow (c1,c2), Carrow (c1',c2') ->
- begin
- semi_unify c1 c1';
- semi_unify c2 c2'
- end
- | Ctuple ckl1, Ctuple ckl2 ->
- if (List.length ckl1) <> (List.length ckl2) then
- raise (Unify (ck1,ck2));
- List.iter2 semi_unify ckl1 ckl2
- | Con (ck',c1,l1), Con (ck'',c2,l2) when l1=l2 ->
- semi_unify_carrier c1 c2;
- semi_unify ck' ck''
- | Cunivar, _ | _, Cunivar -> ()
- | _,_ -> raise (Unify (ck1,ck2))
-
-(* Returns the value corresponding to a pclock (integer) factor
- expression. Expects a constant expression (checked by typing). *)
+ match ck1.cdesc, ck2.cdesc with
+ | Cvar, Cvar ->
+ if ck1.cid < ck2.cid then (
+ ck2.cdesc <- Clink (simplify ck1);
+ update_scope ck2.cscoped ck1)
+ else (
+ ck1.cdesc <- Clink (simplify ck2);
+ update_scope ck1.cscoped ck2)
+ | Cvar, _ ->
+ raise (Unify (ck1, ck2))
+ | _, Cvar when not (occurs ck2 ck1) ->
+ update_scope ck2.cscoped ck1;
+ ck2.cdesc <- Clink (simplify ck1)
+ | Ccarrying (cr1, ck1'), Ccarrying (cr2, ck2') ->
+ semi_unify_carrier cr1 cr2;
+ semi_unify ck1' ck2'
+ | Ccarrying (_, _), _ | _, Ccarrying (_, _) ->
+ raise (Unify (ck1, ck2))
+ | Carrow (c1, c2), Carrow (c1', c2') ->
+ semi_unify c1 c1';
+ semi_unify c2 c2'
+ | Ctuple ckl1, Ctuple ckl2 ->
+ if List.length ckl1 <> List.length ckl2 then raise (Unify (ck1, ck2));
+ List.iter2 semi_unify ckl1 ckl2
+ | Con (ck', c1, l1), Con (ck'', c2, l2) when l1 = l2 ->
+ semi_unify_carrier c1 c2;
+ semi_unify ck' ck''
+ | Cunivar, _ | _, Cunivar ->
+ ()
+ | _, _ ->
+ raise (Unify (ck1, ck2))
+
+(* Returns the value corresponding to a pclock (integer) factor expression.
+ Expects a constant expression (checked by typing). *)
let int_factor_of_expr e =
- match e.expr_desc with
- | Expr_const
- (Const_int i) -> i
- | _ -> failwith "Internal error: int_factor_of_expr"
+ match e.expr_desc with
+ | Expr_const (Const_int i) ->
+ i
+ | _ ->
+ failwith "Internal error: int_factor_of_expr"
(** [clock_uncarry ck] drops the possible carrier(s) name(s) from clock [ck] *)
let rec clock_uncarry ck =
let ck = repr ck in
match ck.cdesc with
- | Ccarrying (_, ck') -> ck'
- | Con(ck', cr, l) -> clock_on (clock_uncarry ck') cr l
- | Ctuple ckl -> clock_of_clock_list (List.map clock_uncarry ckl)
- | _ -> ck
+ | Ccarrying (_, ck') ->
+ ck'
+ | Con (ck', cr, l) ->
+ clock_on (clock_uncarry ck') cr l
+ | Ctuple ckl ->
+ clock_of_clock_list (List.map clock_uncarry ckl)
+ | _ ->
+ ck
let try_unify ck1 ck2 loc =
- try
- unify ck1 ck2
- with
- | Unify (ck1',ck2') ->
- raise (Error (loc, Clock_clash (ck1',ck2')))
- | Mismatch (cr1,cr2) ->
- raise (Error (loc, Carrier_mismatch (cr1,cr2)))
+ try unify ck1 ck2 with
+ | Unify (ck1', ck2') ->
+ raise (Error (loc, Clock_clash (ck1', ck2')))
+ | Mismatch (cr1, cr2) ->
+ raise (Error (loc, Carrier_mismatch (cr1, cr2)))
let try_semi_unify ck1 ck2 loc =
- try
- semi_unify ck1 ck2
- with
- | Unify (ck1',ck2') ->
- raise (Error (loc, Clock_clash (ck1',ck2')))
- | Mismatch (cr1,cr2) ->
- raise (Error (loc, Carrier_mismatch (cr1,cr2)))
+ try semi_unify ck1 ck2 with
+ | Unify (ck1', ck2') ->
+ raise (Error (loc, Clock_clash (ck1', ck2')))
+ | Mismatch (cr1, cr2) ->
+ raise (Error (loc, Carrier_mismatch (cr1, cr2)))
(* ck2 is a subtype of ck1 *)
let rec sub_unify sub ck1 ck2 =
match (repr ck1).cdesc, (repr ck2).cdesc with
- | Ctuple cl1 , Ctuple cl2 ->
- if List.length cl1 <> List.length cl2
- then raise (Unify (ck1, ck2))
+ | Ctuple cl1, Ctuple cl2 ->
+ if List.length cl1 <> List.length cl2 then raise (Unify (ck1, ck2))
else List.iter2 (sub_unify sub) cl1 cl2
- | Ctuple [c1] , _ -> sub_unify sub c1 ck2
- | _ , Ctuple [c2] -> sub_unify sub ck1 c2
- | Con (c1, cr1, t1) , Con (c2, cr2, t2) when t1=t2 ->
- begin
- unify_carrier cr1 cr2;
- sub_unify sub c1 c2
- end
- | Ccarrying (cr1, c1), Ccarrying (cr2, c2)->
- begin
- unify_carrier cr1 cr2;
- sub_unify sub c1 c2
- end
- | _, Ccarrying (_, c2) when sub -> sub_unify sub ck1 c2
- | _ -> unify ck1 ck2
+ | Ctuple [ c1 ], _ ->
+ sub_unify sub c1 ck2
+ | _, Ctuple [ c2 ] ->
+ sub_unify sub ck1 c2
+ | Con (c1, cr1, t1), Con (c2, cr2, t2) when t1 = t2 ->
+ unify_carrier cr1 cr2;
+ sub_unify sub c1 c2
+ | Ccarrying (cr1, c1), Ccarrying (cr2, c2) ->
+ unify_carrier cr1 cr2;
+ sub_unify sub c1 c2
+ | _, Ccarrying (_, c2) when sub ->
+ sub_unify sub ck1 c2
+ | _ ->
+ unify ck1 ck2
let try_sub_unify sub ck1 ck2 loc =
- try
- sub_unify sub ck1 ck2
- with
- | Unify (ck1',ck2') ->
- raise (Error (loc, Clock_clash (ck1',ck2')))
- | Mismatch (cr1,cr2) ->
- raise (Error (loc, Carrier_mismatch (cr1,cr2)))
-
-(* Unifies all the clock variables in the clock type of a tuple
- expression, so that the clock type only uses at most one clock variable *)
+ try sub_unify sub ck1 ck2 with
+ | Unify (ck1', ck2') ->
+ raise (Error (loc, Clock_clash (ck1', ck2')))
+ | Mismatch (cr1, cr2) ->
+ raise (Error (loc, Carrier_mismatch (cr1, cr2)))
+
+(* Unifies all the clock variables in the clock type of a tuple expression, so
+ that the clock type only uses at most one clock variable *)
let unify_tuple_clock ref_ck_opt ck loc =
-(*(match ref_ck_opt with
-| None -> Format.eprintf "unify_tuple_clock None %a@." Clocks.print_ck ck
- | Some ck' -> Format.eprintf "unify_tuple_clock (Some %a) %a@." Clocks.print_ck ck' Clocks.print_ck ck);*)
+ (*(match ref_ck_opt with | None -> Format.eprintf "unify_tuple_clock None
+ %a@." Clocks.print_ck ck | Some ck' -> Format.eprintf "unify_tuple_clock
+ (Some %a) %a@." Clocks.print_ck ck' Clocks.print_ck ck);*)
let ck_var = ref ref_ck_opt in
let rec aux ck =
match (repr ck).cdesc with
- | Con _
- | Cvar ->
- begin
- match !ck_var with
- | None ->
- ck_var:=Some ck
- | Some v ->
- (* may fail *)
- try_unify ck v loc
- end
+ | Con _ | Cvar -> (
+ match !ck_var with
+ | None ->
+ ck_var := Some ck
+ | Some v ->
+ (* may fail *)
+ try_unify ck v loc)
| Ctuple cl ->
- List.iter aux cl
- | Carrow _ -> assert false (* should not occur *)
+ List.iter aux cl
+ | Carrow _ ->
+ assert false (* should not occur *)
| Ccarrying (_, ck1) ->
- aux ck1
- | _ -> ()
- in aux ck
+ aux ck1
+ | _ ->
+ ()
+ in
+ aux ck
-(* Unifies all the clock variables in the clock type of an imported
- node, so that the clock type only uses at most one base clock variable,
- that is, the activation clock of the node *)
+(* Unifies all the clock variables in the clock type of an imported node, so
+ that the clock type only uses at most one base clock variable, that is, the
+ activation clock of the node *)
let unify_imported_clock ref_ck_opt ck loc =
let ck_var = ref ref_ck_opt in
let rec aux ck =
match (repr ck).cdesc with
- | Cvar ->
- begin
- match !ck_var with
- | None ->
- ck_var := Some ck
- | Some v ->
- (* cannot fail *)
- try_unify ck v loc
- end
+ | Cvar -> (
+ match !ck_var with
+ | None ->
+ ck_var := Some ck
+ | Some v ->
+ (* cannot fail *)
+ try_unify ck v loc)
| Ctuple cl ->
List.iter aux cl
- | Carrow (ck1,ck2) ->
- aux ck1; aux ck2
+ | Carrow (ck1, ck2) ->
+ aux ck1;
+ aux ck2
| Ccarrying (_, ck1) ->
aux ck1
- | Con (ck1, _, _) -> aux ck1
- | _ -> ()
+ | Con (ck1, _, _) ->
+ aux ck1
+ | _ ->
+ ()
in
aux ck
-(* Computes the root clock of a tuple or a node clock,
- which is not the same as the base clock.
- Root clock will be used as the call clock
- of a given node instance *)
+(* Computes the root clock of a tuple or a node clock, which is not the same as
+ the base clock. Root clock will be used as the call clock of a given node
+ instance *)
let compute_root_clock ck =
let root = Clocks.root ck in
let branch = ref None in
let rec aux ck =
match (repr ck).cdesc with
| Ctuple cl ->
- List.iter aux cl
- | Carrow (ck1,ck2) ->
- aux ck1; aux ck2
- | _ ->
- begin
- match !branch with
- | None ->
- branch := Some (Clocks.branch ck)
- | Some br ->
- (* cannot fail *)
- branch := Some (Clocks.common_prefix br (Clocks.branch ck))
- end
+ List.iter aux cl
+ | Carrow (ck1, ck2) ->
+ aux ck1;
+ aux ck2
+ | _ -> (
+ match !branch with
+ | None ->
+ branch := Some (Clocks.branch ck)
+ | Some br ->
+ (* cannot fail *)
+ branch := Some (Clocks.common_prefix br (Clocks.branch ck)))
in
- begin
- aux ck;
- Clocks.clock_of_root_branch root (Utils.desome !branch)
- end
-
-(* Clocks a list of arguments of Lustre builtin operators:
- - type each expression, remove carriers of clocks as
- carriers may only denote variables, not arbitrary expr.
- - try to unify these clocks altogether
-*)
+ aux ck;
+ Clocks.clock_of_root_branch root (Utils.desome !branch)
+
+(* Clocks a list of arguments of Lustre builtin operators: - type each
+ expression, remove carriers of clocks as carriers may only denote variables,
+ not arbitrary expr. - try to unify these clocks altogether *)
let rec clock_standard_args env expr_list =
- let ck_list = List.map (fun e -> clock_uncarry (clock_expr env e)) expr_list in
+ let ck_list =
+ List.map (fun e -> clock_uncarry (clock_expr env e)) expr_list
+ in
let ck_res = new_var true in
List.iter2 (fun e ck -> try_unify ck ck_res e.expr_loc) expr_list ck_list;
ck_res
-(* emulates a subtyping relation between clocks c and (cr : c),
- used during node application only *)
-and clock_subtyping_arg env ?(sub=true) real_arg formal_clock =
+(* emulates a subtyping relation between clocks c and (cr : c), used during node
+ application only *)
+and clock_subtyping_arg env ?(sub = true) real_arg formal_clock =
let loc = real_arg.expr_loc in
let real_clock = clock_expr env real_arg in
try_sub_unify sub formal_clock real_clock loc
(* computes clocks for node application *)
and clock_appl env f args clock_reset loc =
- let args = expr_list_of_expr args in
- if Basic_library.is_homomorphic_fun f && List.exists is_tuple_expr args
- then
- let args = Utils.transpose_list (List.map expr_list_of_expr args) in
- Clocks.clock_of_clock_list (List.map (fun args -> clock_call env f args clock_reset loc) args)
- else
- clock_call env f args clock_reset loc
+ let args = expr_list_of_expr args in
+ if Basic_library.is_homomorphic_fun f && List.exists is_tuple_expr args then
+ let args = Utils.transpose_list (List.map expr_list_of_expr args) in
+ Clocks.clock_of_clock_list
+ (List.map (fun args -> clock_call env f args clock_reset loc) args)
+ else clock_call env f args clock_reset loc
and clock_call env f args clock_reset loc =
(* Format.eprintf "Clocking call %s@." f; *)
@@ -500,7 +488,7 @@ and clock_call env f args clock_reset loc =
couts
and clock_ident nocarrier env id loc =
- clock_expr ~nocarrier:nocarrier env (expr_of_ident id loc)
+ clock_expr ~nocarrier env (expr_of_ident id loc)
and clock_carrier env c loc ce =
let expr_c = expr_of_ident c loc in
@@ -514,8 +502,8 @@ and clock_carrier env c loc ce =
(** [clock_expr env expr] performs the clock calculus for expression [expr] in
environment [env] *)
-and clock_expr ?(nocarrier=true) env expr =
- let resulting_ck =
+and clock_expr ?(nocarrier = true) env expr =
+ let resulting_ck =
match expr.expr_desc with
| Expr_const _ ->
let ck = new_var true in
@@ -523,10 +511,9 @@ and clock_expr ?(nocarrier=true) env expr =
ck
| Expr_ident v ->
let ckv =
- try
- Env.lookup_value env v
- with Not_found ->
- failwith ("Internal error, variable \""^v^"\" not found")
+ try Env.lookup_value env v
+ with Not_found ->
+ failwith ("Internal error, variable \"" ^ v ^ "\" not found")
in
let ck = instantiate (ref []) (ref []) ckv in
expr.expr_clock <- ck;
@@ -537,12 +524,12 @@ and clock_expr ?(nocarrier=true) env expr =
ck
| Expr_access (e1, _) ->
(* dimension, being a static value, doesn't need to be clocked *)
- let ck = clock_standard_args env [e1] in
+ let ck = clock_standard_args env [ e1 ] in
expr.expr_clock <- ck;
ck
| Expr_power (e1, _) ->
(* dimension, being a static value, doesn't need to be clocked *)
- let ck = clock_standard_args env [e1] in
+ let ck = clock_standard_args env [ e1 ] in
expr.expr_clock <- ck;
ck
| Expr_tuple elist ->
@@ -550,40 +537,41 @@ and clock_expr ?(nocarrier=true) env expr =
expr.expr_clock <- ck;
ck
| Expr_ite (c, t, e) ->
- let ck_c = clock_standard_args env [c] in
- let ck = clock_standard_args env [t; e] in
+ let ck_c = clock_standard_args env [ c ] in
+ let ck = clock_standard_args env [ t; e ] in
(* Here, the branches may exhibit a tuple clock, not the condition *)
unify_tuple_clock (Some ck_c) ck expr.expr_loc;
expr.expr_clock <- ck;
ck
- | Expr_appl (id, args, r) ->
- (try
- (* for a modular compilation scheme, all inputs/outputs must share the same clock !
- this is also the reset clock !
- *)
- let cr =
- match r with
- | None -> new_var true
- | Some c -> clock_standard_args env [c] in
- let couts = clock_appl env id args (clock_uncarry cr) expr.expr_loc in
- expr.expr_clock <- couts;
- couts
- with exn -> (
- Format.eprintf "Current expr: %a@." Printers.pp_expr expr;
- raise exn
- ))
- | Expr_fby (e1,e2)
- | Expr_arrow (e1,e2) ->
- let ck = clock_standard_args env [e1; e2] in
+ | Expr_appl (id, args, r) -> (
+ try
+ (* for a modular compilation scheme, all inputs/outputs must share the
+ same clock ! this is also the reset clock ! *)
+ let cr =
+ match r with
+ | None ->
+ new_var true
+ | Some c ->
+ clock_standard_args env [ c ]
+ in
+ let couts = clock_appl env id args (clock_uncarry cr) expr.expr_loc in
+ expr.expr_clock <- couts;
+ couts
+ with exn ->
+ Format.eprintf "Current expr: %a@." Printers.pp_expr expr;
+ raise exn)
+ | Expr_fby (e1, e2) | Expr_arrow (e1, e2) ->
+ let ck = clock_standard_args env [ e1; e2 ] in
unify_tuple_clock None ck expr.expr_loc;
expr.expr_clock <- ck;
ck
- | Expr_pre e -> (* todo : deal with phases as in tail ? *)
- let ck = clock_standard_args env [e] in
+ | Expr_pre e ->
+ (* todo : deal with phases as in tail ? *)
+ let ck = clock_standard_args env [ e ] in
expr.expr_clock <- ck;
ck
- | Expr_when (e,c,l) ->
- let ce = clock_standard_args env [e] in
+ | Expr_when (e, c, l) ->
+ let ce = clock_standard_args env [ e ] in
let c_loc = loc_of_cond expr.expr_loc c in
let cr = clock_carrier env c c_loc ce in
let ck = clock_on ce cr l in
@@ -591,20 +579,25 @@ and clock_expr ?(nocarrier=true) env expr =
let ck' = clock_on ce cr' l in
expr.expr_clock <- ck';
ck
- | Expr_merge (c,hl) ->
+ | Expr_merge (c, hl) ->
let cvar = new_var true in
let crvar = new_carrier Carry_name true in
- List.iter (fun (t, h) ->
+ List.iter
+ (fun (t, h) ->
let ckh = clock_uncarry (clock_expr env h) in
- unify_tuple_clock (Some (new_ck (Con (cvar,crvar,t)) true)) ckh h.expr_loc) hl;
+ unify_tuple_clock
+ (Some (new_ck (Con (cvar, crvar, t)) true))
+ ckh h.expr_loc)
+ hl;
let cr = clock_carrier env c expr.expr_loc cvar in
try_unify_carrier cr crvar expr.expr_loc;
- let cres = clock_current ((snd (List.hd hl)).expr_clock) in
+ let cres = clock_current (snd (List.hd hl)).expr_clock in
expr.expr_clock <- cres;
cres
in
- Log.report ~level:4 (fun fmt -> Format.fprintf fmt "Clock of expr %a: %a@ "
- Printers.pp_expr expr Clocks.print_ck resulting_ck);
+ Log.report ~level:4 (fun fmt ->
+ Format.fprintf fmt "Clock of expr %a: %a@ " Printers.pp_expr expr
+ Clocks.print_ck resulting_ck);
resulting_ck
let clock_of_vlist vars =
@@ -614,55 +607,58 @@ let clock_of_vlist vars =
(** [clock_eq env eq] performs the clock-calculus for equation [eq] in
environment [env] *)
let clock_eq env eq =
- let expr_lhs = expr_of_expr_list eq.eq_loc
- (List.map (fun v -> expr_of_ident v eq.eq_loc) eq.eq_lhs) in
+ let expr_lhs =
+ expr_of_expr_list eq.eq_loc
+ (List.map (fun v -> expr_of_ident v eq.eq_loc) eq.eq_lhs)
+ in
let ck_rhs = clock_expr env eq.eq_rhs in
clock_subtyping_arg env expr_lhs ck_rhs
(* [clock_coreclock cck] returns the clock_expr corresponding to clock
- declaration [cck] *)
+ declaration [cck] *)
let clock_coreclock env cck id loc scoped =
match cck.ck_dec_desc with
- | Ckdec_any -> new_var scoped
+ | Ckdec_any ->
+ new_var scoped
| Ckdec_bool cl ->
- let temp_env = Env.add_value env id (new_var true) in
- (* We just want the id to be present in the environment *)
- let dummy_id_expr = expr_of_ident id loc in
- let when_expr =
- List.fold_left
- (fun expr (x,l) ->
- {expr_tag = new_tag ();
- expr_desc = Expr_when (expr,x,l);
- expr_type = Types.new_var ();
- expr_clock = new_var scoped;
- expr_delay = Delay.new_var ();
- expr_loc = loc;
- expr_annot = None})
- dummy_id_expr cl
- in
- clock_expr temp_env when_expr
+ let temp_env = Env.add_value env id (new_var true) in
+ (* We just want the id to be present in the environment *)
+ let dummy_id_expr = expr_of_ident id loc in
+ let when_expr =
+ List.fold_left
+ (fun expr (x, l) ->
+ {
+ expr_tag = new_tag ();
+ expr_desc = Expr_when (expr, x, l);
+ expr_type = Types.new_var ();
+ expr_clock = new_var scoped;
+ expr_delay = Delay.new_var ();
+ expr_loc = loc;
+ expr_annot = None;
+ })
+ dummy_id_expr cl
+ in
+ clock_expr temp_env when_expr
(* Clocks a variable declaration *)
let clock_var_decl scoped env vdecl =
- let ck = clock_coreclock env vdecl.var_dec_clock vdecl.var_id vdecl.var_loc scoped in
let ck =
-(* WTF ????
- if vdecl.var_dec_const
- then
- (try_generalize ck vdecl.var_loc; ck)
- else
- *)
- if Types.get_clock_base_type vdecl.var_type <> None
- then new_ck (Ccarrying (new_carrier Carry_name scoped, ck)) scoped
- else ck in
- (if vdecl.var_dec_const
- then match vdecl.var_dec_value with
- | None -> ()
+ clock_coreclock env vdecl.var_dec_clock vdecl.var_id vdecl.var_loc scoped
+ in
+ let ck =
+ (* WTF ???? if vdecl.var_dec_const then (try_generalize ck vdecl.var_loc;
+ ck) else *)
+ if Types.get_clock_base_type vdecl.var_type <> None then
+ new_ck (Ccarrying (new_carrier Carry_name scoped, ck)) scoped
+ else ck
+ in
+ (if vdecl.var_dec_const then
+ match vdecl.var_dec_value with
+ | None ->
+ ()
| Some v ->
- begin
- let ck_static = clock_expr env v in
- try_unify ck ck_static v.expr_loc
- end);
+ let ck_static = clock_expr env v in
+ try_unify ck ck_static v.expr_loc);
try_unify ck vdecl.var_clock vdecl.var_loc;
Env.add_value env vdecl.var_id ck
@@ -670,84 +666,88 @@ let clock_var_decl scoped env vdecl =
let clock_var_decl_list env scoped l =
List.fold_left (clock_var_decl scoped) env l
-(** [clock_node env nd] performs the clock-calculus for node [nd] in
- environment [env].
- Generalization of clocks wrt scopes follows this rule:
- - generalize inputs (unscoped).
- - generalize outputs. As they are scoped, only clocks coming from inputs
- are allowed to be generalized.
- - generalize locals. As outputs don't depend on them (checked the step before),
- they can be generalized.
- *)
+(** [clock_node env nd] performs the clock-calculus for node [nd] in environment
+ [env]. Generalization of clocks wrt scopes follows this rule: - generalize
+ inputs (unscoped). - generalize outputs. As they are scoped, only clocks
+ coming from inputs are allowed to be generalized. - generalize locals. As
+ outputs don't depend on them (checked the step before), they can be
+ generalized. *)
let clock_node env loc nd =
(* let is_main = nd.node_id = !Options.main_node in *)
let new_env = clock_var_decl_list env false nd.node_inputs in
let new_env = clock_var_decl_list new_env true nd.node_outputs in
let new_env = clock_var_decl_list new_env true nd.node_locals in
- let eqs, _ = get_node_eqs nd in (* TODO XXX: perform the clocking on auts.
- For the moment, it is ignored *)
+ let eqs, _ = get_node_eqs nd in
+ (* TODO XXX: perform the clocking on auts. For the moment, it is ignored *)
List.iter (clock_eq new_env) eqs;
let ck_ins = clock_of_vlist nd.node_inputs in
let ck_outs = clock_of_vlist nd.node_outputs in
let ck_node = new_ck (Carrow (ck_ins, ck_outs)) false in
unify_imported_clock None ck_node loc;
- Log.report ~level:3 (fun fmt -> Format.fprintf fmt "Clock of %s: %a@ " nd.node_id print_ck ck_node);
- (* Local variables may contain first-order carrier variables that should be generalized.
- That's not the case for types. *)
+ Log.report ~level:3 (fun fmt ->
+ Format.fprintf fmt "Clock of %s: %a@ " nd.node_id print_ck ck_node);
+ (* Local variables may contain first-order carrier variables that should be
+ generalized. That's not the case for types. *)
try_generalize ck_node loc;
- (*
- List.iter (fun vdecl -> try_generalize vdecl.var_clock vdecl.var_loc) nd.node_inputs;
- List.iter (fun vdecl -> try_generalize vdecl.var_clock vdecl.var_loc) nd.node_outputs;*)
- (*List.iter (fun vdecl -> try_generalize vdecl.var_clock vdecl.var_loc) nd.node_locals;*)
+ (* List.iter (fun vdecl -> try_generalize vdecl.var_clock vdecl.var_loc)
+ nd.node_inputs; List.iter (fun vdecl -> try_generalize vdecl.var_clock
+ vdecl.var_loc) nd.node_outputs;*)
+ (*List.iter (fun vdecl -> try_generalize vdecl.var_clock vdecl.var_loc)
+ nd.node_locals;*)
(* TODO : Xavier pourquoi ai je cette erreur ? *)
- (* if (is_main && is_polymorphic ck_node) then
- raise (Error (loc,(Cannot_be_polymorphic ck_node)));
- *)
- Log.report ~level:3 (fun fmt -> Format.fprintf fmt "Generalized clock of %s: %a@ @ " nd.node_id print_ck ck_node);
+ (* if (is_main && is_polymorphic ck_node) then raise (Error
+ (loc,(Cannot_be_polymorphic ck_node))); *)
+ Log.report ~level:3 (fun fmt ->
+ Format.fprintf fmt "Generalized clock of %s: %a@ @ " nd.node_id print_ck
+ ck_node);
nd.node_clock <- ck_node;
Env.add_value env nd.node_id ck_node
-
let check_imported_pclocks loc ck_node =
let pck = ref None in
let rec aux ck =
match ck.cdesc with
- | Carrow (ck1,ck2) -> aux ck1; aux ck2
- | Ctuple cl -> List.iter aux cl
- | Con (ck',_,_) -> aux ck'
- | Clink ck' -> aux ck'
- | Ccarrying (_,ck') -> aux ck'
- | Cvar | Cunivar ->
- match !pck with
- | None -> ()
- | Some (_,_) ->
- raise (Error (loc, (Invalid_imported_clock ck_node)))
+ | Carrow (ck1, ck2) ->
+ aux ck1;
+ aux ck2
+ | Ctuple cl ->
+ List.iter aux cl
+ | Con (ck', _, _) ->
+ aux ck'
+ | Clink ck' ->
+ aux ck'
+ | Ccarrying (_, ck') ->
+ aux ck'
+ | Cvar | Cunivar -> (
+ match !pck with
+ | None ->
+ ()
+ | Some (_, _) ->
+ raise (Error (loc, Invalid_imported_clock ck_node)))
in
aux ck_node
let clock_imported_node env loc nd =
let new_env = clock_var_decl_list env false nd.nodei_inputs in
- ignore(clock_var_decl_list new_env false nd.nodei_outputs);
+ ignore (clock_var_decl_list new_env false nd.nodei_outputs);
let ck_ins = clock_of_vlist nd.nodei_inputs in
let ck_outs = clock_of_vlist nd.nodei_outputs in
- let ck_node = new_ck (Carrow (ck_ins,ck_outs)) false in
+ let ck_node = new_ck (Carrow (ck_ins, ck_outs)) false in
unify_imported_clock None ck_node loc;
check_imported_pclocks loc ck_node;
try_generalize ck_node loc;
nd.nodei_clock <- ck_node;
Env.add_value env nd.nodei_id ck_node
-
let new_env = clock_var_decl_list
-
-let clock_top_const env cdecl=
+
+let clock_top_const env cdecl =
let ck = new_var false in
try_generalize ck cdecl.const_loc;
Env.add_value env cdecl.const_id ck
-let clock_top_consts env clist =
- List.fold_left clock_top_const env clist
-
+let clock_top_consts env clist = List.fold_left clock_top_const env clist
+
let rec clock_top_decl env decl =
match decl.top_decl_desc with
| Node nd ->
@@ -756,58 +756,60 @@ let rec clock_top_decl env decl =
clock_imported_node env decl.top_decl_loc nd
| Const c ->
clock_top_const env c
- | TypeDef _ -> List.fold_left clock_top_decl env (consts_of_enum_type decl)
- | Include _ | Open _ -> env
+ | TypeDef _ ->
+ List.fold_left clock_top_decl env (consts_of_enum_type decl)
+ | Include _ | Open _ ->
+ env
-let clock_prog env decls =
- List.fold_left clock_top_decl env decls
+let clock_prog env decls = List.fold_left clock_top_decl env decls
-(* Once the Lustre program is fully clocked,
- we must get back to the original description of clocks,
- with constant parameters, instead of unifiable internal variables. *)
+(* Once the Lustre program is fully clocked, we must get back to the original
+ description of clocks, with constant parameters, instead of unifiable
+ internal variables. *)
-(* The following functions aims at 'unevaluating' carriers occuring in clock expressions,
- i.e. replacing unifiable second_order variables with the original carrier names.
- Once restored in this formulation, clocks may be meaningfully printed.
-*)
+(* The following functions aims at 'unevaluating' carriers occuring in clock
+ expressions, i.e. replacing unifiable second_order variables with the
+ original carrier names. Once restored in this formulation, clocks may be
+ meaningfully printed. *)
let uneval_vdecl_generics vdecl =
- (*Format.eprintf "Clock_calculus.uneval_vdecl_generics %a@." Printers.pp_node_var vdecl;*)
- if Types.get_clock_base_type vdecl.var_type <> None
- then
- match get_carrier_name vdecl.var_clock with
- | None -> (Format.eprintf "internal error: %a@." print_ck vdecl.var_clock; assert false)
- | Some cr -> Clocks.uneval vdecl.var_id cr
-
-let uneval_node_generics vdecls =
- List.iter uneval_vdecl_generics vdecls
+ (*Format.eprintf "Clock_calculus.uneval_vdecl_generics %a@."
+ Printers.pp_node_var vdecl;*)
+ if Types.get_clock_base_type vdecl.var_type <> None then
+ match get_carrier_name vdecl.var_clock with
+ | None ->
+ Format.eprintf "internal error: %a@." print_ck vdecl.var_clock;
+ assert false
+ | Some cr ->
+ Clocks.uneval vdecl.var_id cr
+
+let uneval_node_generics vdecls = List.iter uneval_vdecl_generics vdecls
let uneval_top_generics decl =
match decl.top_decl_desc with
| Node nd ->
- (* A node could contain first-order carrier variable in local vars. This is not the case for types. *)
- uneval_node_generics (nd.node_inputs @ nd.node_locals @ nd.node_outputs)
+ (* A node could contain first-order carrier variable in local vars. This is
+ not the case for types. *)
+ uneval_node_generics (nd.node_inputs @ nd.node_locals @ nd.node_outputs)
| ImportedNode nd ->
- uneval_node_generics (nd.nodei_inputs @ nd.nodei_outputs)
- | Const _
- | Include _ | Open _
- | TypeDef _ -> ()
+ uneval_node_generics (nd.nodei_inputs @ nd.nodei_outputs)
+ | Const _ | Include _ | Open _ | TypeDef _ ->
+ ()
-let uneval_prog_generics prog =
- List.iter uneval_top_generics prog
+let uneval_prog_generics prog = List.iter uneval_top_generics prog
let check_env_compat header declared computed =
uneval_prog_generics header;
Env.iter declared (fun k decl_clock_k ->
try
- let computed_c = instantiate (ref []) (ref []) (Env.lookup_value computed k) in
+ let computed_c =
+ instantiate (ref []) (ref []) (Env.lookup_value computed k)
+ in
try_semi_unify decl_clock_k computed_c Location.dummy_loc
- with Not_found -> (* If the lookup failed then either an actual
- required element should have been declared
- and is missing but typing should have catch
- it, or it was a contract and does not
- require this additional check. *)
- ()
- )
+ with Not_found ->
+ (* If the lookup failed then either an actual required element should
+ have been declared and is missing but typing should have catch it, or
+ it was a contract and does not require this additional check. *)
+ ())
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/clock_predef.ml b/src/clock_predef.ml
index a2cd3fedaadcb5333e3cb8f885b3b2e7b1853ce6..790fcba48d1edb3987819cb16f173b0bf5ee5d20 100644
--- a/src/clock_predef.ml
+++ b/src/clock_predef.ml
@@ -6,23 +6,23 @@
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)
(* under the terms of the GNU Lesser General Public License *)
(* version 2.1. *)
-(* *)
+(* *)
(* This file was originally from the Prelude compiler *)
-(* *)
+(* *)
(********************************************************************)
-(** Predefined operator clocks *)
open Clocks
+(** Predefined operator clocks *)
let ck_tuple cl = new_ck (Ctuple cl) true
let ck_bin_univ =
let univ = new_univar () in
- new_ck (Carrow (new_ck (Ctuple [univ;univ]) true, univ)) true
+ new_ck (Carrow (new_ck (Ctuple [ univ; univ ]) true, univ)) true
let ck_ite =
let univ = new_univar () in
- new_ck (Carrow (new_ck (Ctuple [univ;univ;univ]) true, univ)) true
+ new_ck (Carrow (new_ck (Ctuple [ univ; univ; univ ]) true, univ)) true
let ck_nullary_univ =
let univ = new_univar () in
@@ -43,7 +43,7 @@ let ck_clock_to_bool =
new_ck (Carrow (new_ck (Ccarrying (cuniv, univ)) false, univ))
let ck_carrier id ck =
- new_ck (Ccarrying (new_carrier (Carry_const id) true, ck)) true
+ new_ck (Ccarrying (new_carrier (Carry_const id) true, ck)) true
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/clocks.ml b/src/clocks.ml
index 9a4cfe7ac1928916168f17839cd01d42eb602e9b..5290af2b95eb79f160df11eeb62ddf90cbd41c12 100644
--- a/src/clocks.ml
+++ b/src/clocks.ml
@@ -6,13 +6,14 @@
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)
(* under the terms of the GNU Lesser General Public License *)
(* version 2.1. *)
-(* *)
+(* *)
(* This file was originally from the Prelude compiler *)
-(* *)
+(* *)
(********************************************************************)
-(** Clocks definitions and a few utility functions on clocks. *)
open Utils
+(** Clocks definitions and a few utility functions on clocks. *)
+
open Format
(* (\* Clock type sets, for subtyping. *\) *)
@@ -27,17 +28,19 @@ type carrier_desc =
| Carry_var
| Carry_link of carrier_expr
-(* Carriers are scoped, to detect clock extrusion. In other words, we
- check the scope of a clock carrier before generalizing it. *)
-and carrier_expr =
- {mutable carrier_desc: carrier_desc;
- mutable carrier_scoped: bool;
- carrier_id: int}
-
-type clock_expr =
- {mutable cdesc: clock_desc;
- mutable cscoped: bool;
- cid: int}
+(* Carriers are scoped, to detect clock extrusion. In other words, we check the
+ scope of a clock carrier before generalizing it. *)
+and carrier_expr = {
+ mutable carrier_desc : carrier_desc;
+ mutable carrier_scoped : bool;
+ carrier_id : int;
+}
+
+type clock_expr = {
+ mutable cdesc : clock_desc;
+ mutable cscoped : bool;
+ cid : int;
+}
(* pck stands for periodic clock. Easier not to separate pck from other clocks *)
and clock_desc =
@@ -48,9 +51,13 @@ and clock_desc =
(* | Pck_down of clock_expr * int *)
(* | Pck_phase of clock_expr * rat *)
(* | Pck_const of int * rat *)
- | Cvar (* of clock_set *) (* Monomorphic clock variable *)
- | Cunivar (* of clock_set *) (* Polymorphic clock variable *)
- | Clink of clock_expr (* During unification, make links instead of substitutions *)
+ | Cvar (* of clock_set *)
+ (* Monomorphic clock variable *)
+ | Cunivar
+ (* of clock_set *)
+ (* Polymorphic clock variable *)
+ | Clink of clock_expr
+ (* During unification, make links instead of substitutions *)
| Ccarrying of carrier_expr * clock_expr
type error =
@@ -66,47 +73,54 @@ type error =
| Clock_extrusion of clock_expr * clock_expr
exception Unify of clock_expr * clock_expr
+
exception Mismatch of carrier_expr * carrier_expr
+
exception Scope_carrier of carrier_expr
+
exception Scope_clock of clock_expr
+
exception Error of Location.t * error
let rec print_carrier fmt cr =
- (* (if cr.carrier_scoped then fprintf fmt "[%t]" else fprintf fmt "%t") (fun fmt -> *)
+ (* (if cr.carrier_scoped then fprintf fmt "[%t]" else fprintf fmt "%t") (fun
+ fmt -> *)
match cr.carrier_desc with
- | Carry_const id -> fprintf fmt "%s" id
+ | Carry_const id ->
+ fprintf fmt "%s" id
| Carry_name ->
- fprintf fmt "_%s" (name_of_carrier cr.carrier_id)
+ fprintf fmt "_%s" (name_of_carrier cr.carrier_id)
| Carry_var ->
fprintf fmt "'%s" (name_of_carrier cr.carrier_id)
| Carry_link cr' ->
print_carrier fmt cr'
-(* Simple pretty-printing, performs no simplifications. Linear
- complexity. For debug mainly. *)
+(* Simple pretty-printing, performs no simplifications. Linear complexity. For
+ debug mainly. *)
let rec print_ck_long fmt ck =
match ck.cdesc with
- | Carrow (ck1,ck2) ->
- fprintf fmt "%a -> %a" print_ck_long ck1 print_ck_long ck2
+ | Carrow (ck1, ck2) ->
+ fprintf fmt "%a -> %a" print_ck_long ck1 print_ck_long ck2
| Ctuple cklist ->
- fprintf fmt "(%a)"
- (fprintf_list ~sep:" * " print_ck_long) cklist
- | Con (ck,c,l) ->
+ fprintf fmt "(%a)" (fprintf_list ~sep:" * " print_ck_long) cklist
+ | Con (ck, c, l) ->
fprintf fmt "%a on %s(%a)" print_ck_long ck l print_carrier c
- | Cvar -> fprintf fmt "'_%i" ck.cid
- | Cunivar -> fprintf fmt "'%i" ck.cid
+ | Cvar ->
+ fprintf fmt "'_%i" ck.cid
+ | Cunivar ->
+ fprintf fmt "'%i" ck.cid
| Clink ck' ->
fprintf fmt "link %a" print_ck_long ck'
- | Ccarrying (cr,ck') ->
+ | Ccarrying (cr, ck') ->
fprintf fmt "(%a:%a)" print_carrier cr print_ck_long ck'
let new_id = ref (-1)
-let rec bottom =
- { cdesc = Clink bottom; cid = -666; cscoped = false }
+let rec bottom = { cdesc = Clink bottom; cid = -666; cscoped = false }
let new_ck desc scoped =
- incr new_id; {cdesc=desc; cid = !new_id; cscoped = scoped}
+ incr new_id;
+ { cdesc = desc; cid = !new_id; cscoped = scoped }
let new_var scoped = new_ck Cvar scoped
@@ -115,177 +129,209 @@ let new_univar () = new_ck Cunivar false
let new_carrier_id = ref (-1)
let new_carrier desc scoped =
- incr new_carrier_id; {carrier_desc = desc;
- carrier_id = !new_carrier_id;
- carrier_scoped = scoped}
-
-let new_carrier_name () =
- new_carrier Carry_name true
+ incr new_carrier_id;
+ { carrier_desc = desc; carrier_id = !new_carrier_id; carrier_scoped = scoped }
-let rec repr =
- function
- {cdesc=Clink ck'; _} ->
- repr ck'
- | ck -> ck
+let new_carrier_name () = new_carrier Carry_name true
-let rec carrier_repr =
- function {carrier_desc = Carry_link cr'; _} -> carrier_repr cr'
- | cr -> cr
+let rec repr = function { cdesc = Clink ck'; _ } -> repr ck' | ck -> ck
+let rec carrier_repr = function
+ | { carrier_desc = Carry_link cr'; _ } ->
+ carrier_repr cr'
+ | cr ->
+ cr
let get_carrier_name ck =
- match (repr ck).cdesc with
- | Ccarrying (cr, _) -> Some cr
- | _ -> None
+ match (repr ck).cdesc with Ccarrying (cr, _) -> Some cr | _ -> None
let rename_carrier_static rename cr =
match (carrier_repr cr).carrier_desc with
- | Carry_const id -> { cr with carrier_desc = Carry_const (rename id) }
- | _ -> (Format.eprintf "internal error: Clocks.rename_carrier_static %a@." print_carrier cr; assert false)
+ | Carry_const id ->
+ { cr with carrier_desc = Carry_const (rename id) }
+ | _ ->
+ Format.eprintf "internal error: Clocks.rename_carrier_static %a@."
+ print_carrier cr;
+ assert false
let rec rename_static rename ck =
- match (repr ck).cdesc with
- | Ccarrying (cr, ck') -> { ck with cdesc = Ccarrying (rename_carrier_static rename cr, rename_static rename ck') }
- | Con (ck', cr, l) -> { ck with cdesc = Con (rename_static rename ck', rename_carrier_static rename cr, l) }
- | _ -> ck
-
-let uncarrier ck =
- match ck.cdesc with
- | Ccarrying (_, ck') -> ck'
- | _ -> ck
-
-(* Removes all links in a clock. Only used for clocks
- simplification though. *)
+ match (repr ck).cdesc with
+ | Ccarrying (cr, ck') ->
+ {
+ ck with
+ cdesc =
+ Ccarrying (rename_carrier_static rename cr, rename_static rename ck');
+ }
+ | Con (ck', cr, l) ->
+ {
+ ck with
+ cdesc = Con (rename_static rename ck', rename_carrier_static rename cr, l);
+ }
+ | _ ->
+ ck
+
+let uncarrier ck = match ck.cdesc with Ccarrying (_, ck') -> ck' | _ -> ck
+
+(* Removes all links in a clock. Only used for clocks simplification though. *)
let rec simplify ck =
match ck.cdesc with
- | Carrow (ck1,ck2) ->
- new_ck (Carrow (simplify ck1, simplify ck2)) ck.cscoped
+ | Carrow (ck1, ck2) ->
+ new_ck (Carrow (simplify ck1, simplify ck2)) ck.cscoped
| Ctuple cl ->
- new_ck (Ctuple (List.map simplify cl)) ck.cscoped
+ new_ck (Ctuple (List.map simplify cl)) ck.cscoped
| Con (ck', c, l) ->
- new_ck (Con (simplify ck', c, l)) ck.cscoped
- | Cvar | Cunivar -> ck
- | Clink ck' -> simplify ck'
- | Ccarrying (cr,ck') -> new_ck (Ccarrying (cr, simplify ck')) ck.cscoped
+ new_ck (Con (simplify ck', c, l)) ck.cscoped
+ | Cvar | Cunivar ->
+ ck
+ | Clink ck' ->
+ simplify ck'
+ | Ccarrying (cr, ck') ->
+ new_ck (Ccarrying (cr, simplify ck')) ck.cscoped
(** Splits ck into the [lhs,rhs] of an arrow clock. Expects an arrow clock
(ensured by language syntax) *)
let split_arrow ck =
match (repr ck).cdesc with
- | Carrow (cin,cout) -> cin,cout
- | _ -> failwith "Internal error: not an arrow clock"
+ | Carrow (cin, cout) ->
+ cin, cout
+ | _ ->
+ failwith "Internal error: not an arrow clock"
(** Returns the clock corresponding to a clock list. *)
let clock_of_clock_list ckl =
- if (List.length ckl) > 1 then
- new_ck (Ctuple ckl) true
- else
- List.hd ckl
+ if List.length ckl > 1 then new_ck (Ctuple ckl) true else List.hd ckl
let clock_list_of_clock ck =
- match (repr ck).cdesc with
- | Ctuple cl -> cl
- | _ -> [ck]
+ match (repr ck).cdesc with Ctuple cl -> cl | _ -> [ ck ]
let clock_on ck cr l =
- clock_of_clock_list (List.map (fun ck -> new_ck (Con (ck,cr,l)) true) (clock_list_of_clock ck))
+ clock_of_clock_list
+ (List.map
+ (fun ck -> new_ck (Con (ck, cr, l)) true)
+ (clock_list_of_clock ck))
let clock_current ck =
- clock_of_clock_list (List.map (fun ck -> match (repr ck).cdesc with
- | Con(ck',_,_) -> ck'
- | _ -> Format.eprintf "internal error: Clocks.clock_current %a@." print_ck_long (repr ck);
- assert false) (clock_list_of_clock ck))
+ clock_of_clock_list
+ (List.map
+ (fun ck ->
+ match (repr ck).cdesc with
+ | Con (ck', _, _) ->
+ ck'
+ | _ ->
+ Format.eprintf "internal error: Clocks.clock_current %a@."
+ print_ck_long (repr ck);
+ assert false)
+ (clock_list_of_clock ck))
let clock_of_impnode_clock ck =
let ck = repr ck in
match ck.cdesc with
| Carrow _ | Clink _ | Cvar | Cunivar ->
- failwith "internal error clock_of_impnode_clock"
- | Ctuple cklist -> List.hd cklist
- | Con (_,_,_)
- | Ccarrying (_,_) -> ck
-
+ failwith "internal error clock_of_impnode_clock"
+ | Ctuple cklist ->
+ List.hd cklist
+ | Con (_, _, _) | Ccarrying (_, _) ->
+ ck
(** [is_polymorphic ck] returns true if [ck] is polymorphic. *)
let rec is_polymorphic ck =
match ck.cdesc with
- | Cvar -> false
- | Carrow (ck1,ck2) -> (is_polymorphic ck1) || (is_polymorphic ck2)
- | Ctuple ckl -> List.exists (fun c -> is_polymorphic c) ckl
- | Con (ck',_,_) -> is_polymorphic ck'
- | Cunivar -> true
- | Clink ck' -> is_polymorphic ck'
- | Ccarrying (_,ck') -> is_polymorphic ck'
-
-(** [constrained_vars_of_clock ck] returns the clock variables subject
- to sub-typing constraints appearing in clock [ck]. Removes duplicates *)
+ | Cvar ->
+ false
+ | Carrow (ck1, ck2) ->
+ is_polymorphic ck1 || is_polymorphic ck2
+ | Ctuple ckl ->
+ List.exists (fun c -> is_polymorphic c) ckl
+ | Con (ck', _, _) ->
+ is_polymorphic ck'
+ | Cunivar ->
+ true
+ | Clink ck' ->
+ is_polymorphic ck'
+ | Ccarrying (_, ck') ->
+ is_polymorphic ck'
+
(* Used mainly for debug, non-linear complexity. *)
+
+(** [constrained_vars_of_clock ck] returns the clock variables subject to
+ sub-typing constraints appearing in clock [ck]. Removes duplicates *)
let constrained_vars_of_clock ck =
let rec aux vars ck =
match ck.cdesc with
- | Cvar -> vars
- | Carrow (ck1,ck2) ->
- let l = aux vars ck1 in
- aux l ck2
+ | Cvar ->
+ vars
+ | Carrow (ck1, ck2) ->
+ let l = aux vars ck1 in
+ aux l ck2
| Ctuple ckl ->
- List.fold_left
- (fun acc ck' -> aux acc ck')
- vars ckl
- | Con (ck',_,_) -> aux vars ck'
- | Cunivar -> vars
- | Clink ck' -> aux vars ck'
- | Ccarrying (_,ck') -> aux vars ck'
+ List.fold_left (fun acc ck' -> aux acc ck') vars ckl
+ | Con (ck', _, _) ->
+ aux vars ck'
+ | Cunivar ->
+ vars
+ | Clink ck' ->
+ aux vars ck'
+ | Ccarrying (_, ck') ->
+ aux vars ck'
in
aux [] ck
let eq_carrier cr1 cr2 =
match (carrier_repr cr1).carrier_desc, (carrier_repr cr2).carrier_desc with
- | Carry_const id1, Carry_const id2 -> id1 = id2
- | _ -> cr1.carrier_id = cr2.carrier_id
+ | Carry_const id1, Carry_const id2 ->
+ id1 = id2
+ | _ ->
+ cr1.carrier_id = cr2.carrier_id
-let eq_clock ck1 ck2 =
- (repr ck1).cid = (repr ck2).cid
+let eq_clock ck1 ck2 = (repr ck1).cid = (repr ck2).cid
(* Returns the clock root of a clock *)
let rec root ck =
let ck = repr ck in
match ck.cdesc with
- | Ctuple (ck'::_)
- | Con (ck',_,_) | Clink ck' | Ccarrying (_,ck') -> root ck'
- | Cvar | Cunivar -> ck
- | Carrow _ | Ctuple _ -> failwith "Internal error root"
+ | Ctuple (ck' :: _) | Con (ck', _, _) | Clink ck' | Ccarrying (_, ck') ->
+ root ck'
+ | Cvar | Cunivar ->
+ ck
+ | Carrow _ | Ctuple _ ->
+ failwith "Internal error root"
(* Returns the branch of clock [ck] in its clock tree *)
let branch ck =
let rec branch ck acc =
match (repr ck).cdesc with
- | Ccarrying (_, ck) -> branch ck acc
- | Con (ck, cr, l) -> branch ck ((cr, l) :: acc)
- | Ctuple (ck::_) -> branch ck acc
- | Ctuple _
- | Carrow _ -> assert false
- | _ -> acc
- in branch ck [];;
+ | Ccarrying (_, ck) ->
+ branch ck acc
+ | Con (ck, cr, l) ->
+ branch ck ((cr, l) :: acc)
+ | Ctuple (ck :: _) ->
+ branch ck acc
+ | Ctuple _ | Carrow _ ->
+ assert false
+ | _ ->
+ acc
+ in
+ branch ck []
let clock_of_root_branch r br =
- List.fold_left (fun ck (cr,l) -> new_ck (Con (ck, cr, l)) true) r br
+ List.fold_left (fun ck (cr, l) -> new_ck (Con (ck, cr, l)) true) r br
(* Computes the (longest) common prefix of two branches *)
let rec common_prefix br1 br2 =
- match br1, br2 with
- | [] , _
- | _ , [] -> []
- | (cr1,l1)::q1, (cr2,l2)::q2 ->
- if eq_carrier cr1 cr2 && (l1 = l2)
- then (cr1, l1) :: common_prefix q1 q2
- else []
+ match br1, br2 with
+ | [], _ | _, [] ->
+ []
+ | (cr1, l1) :: q1, (cr2, l2) :: q2 ->
+ if eq_carrier cr1 cr2 && l1 = l2 then (cr1, l1) :: common_prefix q1 q2
+ else []
(* Tests whether clock branches [br1] nd [br2] are statically disjoint *)
let rec disjoint_branches br1 br2 =
- match br1, br2 with
- | [] , _
- | _ , [] -> false
- | (cr1,l1)::q1, (cr2,l2)::q2 -> eq_carrier cr1 cr2 && ((l1 <> l2) || disjoint_branches q1 q2);;
+ match br1, br2 with
+ | [], _ | _, [] ->
+ false
+ | (cr1, l1) :: q1, (cr2, l2) :: q2 ->
+ eq_carrier cr1 cr2 && (l1 <> l2 || disjoint_branches q1 q2)
(* Disjunction relation between variables based upon their static clocks. *)
let disjoint ck1 ck2 =
@@ -294,162 +340,132 @@ let disjoint ck1 ck2 =
let print_cvar fmt cvar =
match cvar.cdesc with
| Cvar ->
- (*
- if cvar.cscoped
- then
- fprintf fmt "[_%s]"
- (name_of_type cvar.cid)
- else
- *)
- fprintf fmt "_%s"
- (name_of_type cvar.cid)
+ (* if cvar.cscoped then fprintf fmt "[_%s]" (name_of_type cvar.cid) else *)
+ fprintf fmt "_%s" (name_of_type cvar.cid)
| Cunivar ->
- (*
- if cvar.cscoped
- then
- fprintf fmt "['%s]"
- (name_of_type cvar.cid)
- else
- *)
- fprintf fmt "'%s"
- (name_of_type cvar.cid)
- | _ -> failwith "Internal error print_cvar"
+ (* if cvar.cscoped then fprintf fmt "['%s]" (name_of_type cvar.cid) else *)
+ fprintf fmt "'%s" (name_of_type cvar.cid)
+ | _ ->
+ failwith "Internal error print_cvar"
(* Nice pretty-printing. Simplifies expressions before printing them. Non-linear
complexity. *)
let print_ck fmt ck =
let rec aux fmt ck =
match ck.cdesc with
- | Carrow (ck1,ck2) ->
+ | Carrow (ck1, ck2) ->
fprintf fmt "%a -> %a" aux ck1 aux ck2
| Ctuple cklist ->
- fprintf fmt "(%a)"
- (fprintf_list ~sep:" * " aux) cklist
- | Con (ck,c,l) ->
+ fprintf fmt "(%a)" (fprintf_list ~sep:" * " aux) cklist
+ | Con (ck, c, l) ->
fprintf fmt "%a on %s(%a)" aux ck l print_carrier c
| Cvar ->
-(*
- if ck.cscoped
- then
- fprintf fmt "[_%s]" (name_of_type ck.cid)
- else
-*)
- fprintf fmt "_%s" (name_of_type ck.cid)
+ (* if ck.cscoped then fprintf fmt "[_%s]" (name_of_type ck.cid) else *)
+ fprintf fmt "_%s" (name_of_type ck.cid)
| Cunivar ->
-(*
- if ck.cscoped
- then
- fprintf fmt "['%s]" (name_of_type ck.cid)
- else
-*)
- fprintf fmt "'%s" (name_of_type ck.cid)
+ (* if ck.cscoped then fprintf fmt "['%s]" (name_of_type ck.cid) else *)
+ fprintf fmt "'%s" (name_of_type ck.cid)
| Clink ck' ->
- aux fmt ck'
- | Ccarrying (cr,ck') ->
+ aux fmt ck'
+ | Ccarrying (cr, ck') ->
fprintf fmt "(%a:%a)" print_carrier cr aux ck'
in
let cvars = constrained_vars_of_clock ck in
aux fmt ck;
if cvars <> [] then
- fprintf fmt " (where %a)"
- (fprintf_list ~sep:", " print_cvar) cvars
+ fprintf fmt " (where %a)" (fprintf_list ~sep:", " print_cvar) cvars
(* prints only the Con components of a clock, useful for printing nodes *)
let rec print_ck_suffix fmt ck =
match ck.cdesc with
- | Carrow _
- | Ctuple _
- | Cvar
- | Cunivar -> ()
- | Con (ck,c,l) ->
- if !Options.kind2_print then
- print_ck_suffix fmt ck
- else
- fprintf fmt "%a when %s(%a)" print_ck_suffix ck l print_carrier c
+ | Carrow _ | Ctuple _ | Cvar | Cunivar ->
+ ()
+ | Con (ck, c, l) ->
+ if !Options.kind2_print then print_ck_suffix fmt ck
+ else fprintf fmt "%a when %s(%a)" print_ck_suffix ck l print_carrier c
| Clink ck' ->
print_ck_suffix fmt ck'
| Ccarrying (_, ck') ->
fprintf fmt "%a" print_ck_suffix ck'
-
let pp_error fmt = function
- | Clock_clash (ck1,ck2) ->
- reset_names ();
- fprintf fmt "Expected clock %a, got clock %a@."
- print_ck ck1
- print_ck ck2
+ | Clock_clash (ck1, ck2) ->
+ reset_names ();
+ fprintf fmt "Expected clock %a, got clock %a@." print_ck ck1 print_ck ck2
| Carrier_mismatch (cr1, cr2) ->
- fprintf fmt "Name clash. Expected clock %a, got clock %a@."
- print_carrier cr1
- print_carrier cr2
+ fprintf fmt "Name clash. Expected clock %a, got clock %a@." print_carrier
+ cr1 print_carrier cr2
| Cannot_be_polymorphic ck ->
- reset_names ();
- fprintf fmt "The main node cannot have a polymorphic clock: %a@."
- print_ck ck
+ reset_names ();
+ fprintf fmt "The main node cannot have a polymorphic clock: %a@." print_ck
+ ck
| Invalid_imported_clock ck ->
- reset_names ();
- fprintf fmt "Not a valid imported node clock: %a@."
- print_ck ck
+ reset_names ();
+ fprintf fmt "Not a valid imported node clock: %a@." print_ck ck
| Invalid_const ck ->
- reset_names ();
- fprintf fmt "Clock %a is not a valid periodic clock@."
- print_ck ck;
+ reset_names ();
+ fprintf fmt "Clock %a is not a valid periodic clock@." print_ck ck
| Factor_zero ->
fprintf fmt "Cannot apply clock transformation with factor 0@."
- | Carrier_extrusion (ck,cr) ->
- fprintf fmt "This node has clock@.%a@.It is invalid as the carrier %a escapes its scope@."
- print_ck ck
- print_carrier cr
- | Clock_extrusion (ck_node,ck) ->
- fprintf fmt "This node has clock@.%a@.It is invalid as the clock %a escapes its scope@."
- print_ck ck_node
- print_ck ck
+ | Carrier_extrusion (ck, cr) ->
+ fprintf fmt
+ "This node has clock@.%a@.It is invalid as the carrier %a escapes its \
+ scope@."
+ print_ck ck print_carrier cr
+ | Clock_extrusion (ck_node, ck) ->
+ fprintf fmt
+ "This node has clock@.%a@.It is invalid as the clock %a escapes its \
+ scope@."
+ print_ck ck_node print_ck ck
let const_of_carrier cr =
match (carrier_repr cr).carrier_desc with
- | Carry_const id -> id
- | Carry_name
- | Carry_var
- | Carry_link _ -> (Format.eprintf "internal error: const_of_carrier %a@." print_carrier cr; assert false) (* TODO check this Xavier *)
-
+ | Carry_const id ->
+ id
+ | Carry_name | Carry_var | Carry_link _ ->
+ Format.eprintf "internal error: const_of_carrier %a@." print_carrier cr;
+ assert false
+(* TODO check this Xavier *)
+
let uneval const cr =
(*Format.printf "Clocks.uneval %s %a@." const print_carrier cr;*)
let cr = carrier_repr cr in
match cr.carrier_desc with
- | Carry_var -> cr.carrier_desc <- Carry_const const
- | Carry_name -> cr.carrier_desc <- Carry_const const
- | _ -> assert false
-
+ | Carry_var ->
+ cr.carrier_desc <- Carry_const const
+ | Carry_name ->
+ cr.carrier_desc <- Carry_const const
+ | _ ->
+ assert false
(* Used in rename functions in Corelang. We have to propagate the renaming to
ids of variables clocking the signals *)
(* Carrier are not renamed. They corresponds to enumerated type constants *)
-(*
-let rec rename_carrier f c =
- { c with carrier_desc = rename_carrier_desc fvar c.carrier_desc }
-and rename_carrier_desc f
-let re = rename_carrier f
- match cd with
- | Carry_const id -> Carry_const (f id)
- | Carry_link ce -> Carry_link (re ce)
- | _ -> cd
-*)
+(* let rec rename_carrier f c = { c with carrier_desc = rename_carrier_desc fvar
+ c.carrier_desc } and rename_carrier_desc f let re = rename_carrier f match cd
+ with | Carry_const id -> Carry_const (f id) | Carry_link ce -> Carry_link (re
+ ce) | _ -> cd *)
-
let rec rename_clock_expr fvar c =
{ c with cdesc = rename_clock_desc fvar c.cdesc }
+
and rename_clock_desc fvar cd =
let re = rename_clock_expr fvar in
match cd with
- | Carrow (c1, c2) -> Carrow (re c1, re c2)
- | Ctuple cl -> Ctuple (List.map re cl)
- | Con (c1, car, id) -> Con (re c1, car, fvar id)
- | Cvar
- | Cunivar -> cd
- | Clink c -> Clink (re c)
- | Ccarrying (car, c) -> Ccarrying (car, re c)
-
+ | Carrow (c1, c2) ->
+ Carrow (re c1, re c2)
+ | Ctuple cl ->
+ Ctuple (List.map re cl)
+ | Con (c1, car, id) ->
+ Con (re c1, car, fvar id)
+ | Cvar | Cunivar ->
+ cd
+ | Clink c ->
+ Clink (re c)
+ | Ccarrying (car, c) ->
+ Ccarrying (car, re c)
+
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/compiler_common.ml b/src/compiler_common.ml
index e96fae4a6255748279e56e3003d1114fd1ab2407..8a0e6521e1ca608b091dc33caa9d8b8fad61d24f 100644
--- a/src/compiler_common.ml
+++ b/src/compiler_common.ml
@@ -10,153 +10,132 @@
(********************************************************************)
open Utils
-open Format
+open Format
open Lustre_types
open Corelang
let check_main () =
- if !Options.main_node = "" then
- begin
- eprintf "Code generation error: %a@." Error.pp_error_msg Error.No_main_specified;
- raise (Error.Error (Location.dummy_loc, Error.No_main_specified))
- end
+ if !Options.main_node = "" then (
+ eprintf "Code generation error: %a@." Error.pp_error_msg
+ Error.No_main_specified;
+ raise (Error.Error (Location.dummy_loc, Error.No_main_specified)))
let create_dest_dir () =
- begin
- if not (Sys.file_exists !Options.dest_dir) then
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. creating destination directory@ ");
- Unix.mkdir !Options.dest_dir (Unix.stat ".").Unix.st_perm
- end;
- if (Unix.stat !Options.dest_dir).Unix.st_kind <> Unix.S_DIR then
- begin
- eprintf "Failure: destination %s is not a directory.@.@." !Options.dest_dir;
- exit 1
- end
- end
+ if not (Sys.file_exists !Options.dest_dir) then (
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt ".. creating destination directory@ ");
+ Unix.mkdir !Options.dest_dir (Unix.stat ".").Unix.st_perm);
+ if (Unix.stat !Options.dest_dir).Unix.st_kind <> Unix.S_DIR then (
+ eprintf "Failure: destination %s is not a directory.@.@." !Options.dest_dir;
+ exit 1)
-(* Loading Lus/Lusi file and filling type tables with parsed
- functions/nodes *)
+(* Loading Lus/Lusi file and filling type tables with parsed functions/nodes *)
let parse filename extension =
(* Location.set_input filename; *)
(* let f_in = open_in filename in *)
(* let lexbuf = Lexing.from_channel f_in in *)
(* Location.init lexbuf filename; *)
(* Parsing *)
- let prog =
+ let prog =
try
- Parse.(parse_filename (module Lexer_lustre) filename
- (match extension with
- | ".lusi" ->
- Log.report ~level:1
- (fun fmt -> fprintf fmt ".. parsing header file %s@ " filename);
- Header
- | ".lus" ->
- Log.report ~level:1
- (fun fmt -> fprintf fmt ".. parsing source file %s@ " filename);
- Program
- | _ -> assert false))
+ Parse.(
+ parse_filename
+ (module Lexer_lustre)
+ filename
+ (match extension with
+ | ".lusi" ->
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt ".. parsing header file %s@ " filename);
+ Header
+ | ".lus" ->
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt ".. parsing source file %s@ " filename);
+ Program
+ | _ ->
+ assert false))
with
(* | (Parse.Error err) as exc ->
* Parse.report_error err;
* raise exc *)
- | Error.Error (loc, err) as exc -> (
- eprintf "Parsing error: %a%a@."
- Error.pp_error_msg err
- Location.pp_loc loc;
+ | Error.Error (loc, err) as exc ->
+ eprintf "Parsing error: %a%a@." Error.pp_error_msg err Location.pp_loc loc;
raise exc
- )
in
(* close_in f_in; *)
prog
-
let expand_automata decls =
Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. expanding automata@ ");
- try
- Automata.expand_decls decls
- with (Error.Error (loc, err)) as exc ->
- eprintf "Automata error: %a%a@."
- Error.pp_error_msg err
- Location.pp_loc loc;
+ try Automata.expand_decls decls
+ with Error.Error (loc, err) as exc ->
+ eprintf "Automata error: %a%a@." Error.pp_error_msg err Location.pp_loc loc;
raise exc
let check_stateless_decls decls =
- Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. checking stateless/stateful status@ ");
- try
- Stateless.check_prog decls
- with (Stateless.Error (loc, err)) as exc ->
- eprintf "Stateless status error: %a%a@."
- Stateless.pp_error err
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@ .. checking stateless/stateful status@ ");
+ try Stateless.check_prog decls
+ with Stateless.Error (loc, err) as exc ->
+ eprintf "Stateless status error: %a%a@." Stateless.pp_error err
Location.pp_loc loc;
raise exc
let force_stateful_decls decls =
Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. forcing stateful status@ ");
- try
- Stateless.force_prog decls
- with (Stateless.Error (loc, err)) as exc ->
- eprintf "Stateless status error: %a%a@."
- Stateless.pp_error err
+ try Stateless.force_prog decls
+ with Stateless.Error (loc, err) as exc ->
+ eprintf "Stateless status error: %a%a@." Stateless.pp_error err
Location.pp_loc loc;
raise exc
-let type_decls env decls =
+let type_decls env decls =
Log.report ~level:1 (fun fmt -> fprintf fmt "@ @[<v 2>.. typing@ ");
- let new_env =
- try
- Typing.type_prog env decls
- with Types.Error (loc,err) as exc ->
- eprintf "Typing error: %a%a@."
- Types.pp_error err
- Location.pp_loc loc;
+ let new_env =
+ try Typing.type_prog env decls
+ with Types.Error (loc, err) as exc ->
+ eprintf "Typing error: %a%a@." Types.pp_error err Location.pp_loc loc;
raise exc
in
Log.report ~level:1 (fun fmt -> fprintf fmt "@]");
if !Options.print_types || !Options.verbose_level > 2 then
- Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2> %a@]@ " Corelang.pp_prog_type decls);
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@[<v 2> %a@]@ " Corelang.pp_prog_type decls);
new_env
-
-let clock_decls env decls =
+
+let clock_decls env decls =
Log.report ~level:1 (fun fmt -> fprintf fmt "@ @[<v 2>.. clock calculus@ ");
let new_env =
- try
- Clock_calculus.clock_prog env decls
- with (Clocks.Error (loc,err)) as exc ->
- eprintf "Clock calculus error: %a%a@." Clocks.pp_error err Location.pp_loc loc;
+ try Clock_calculus.clock_prog env decls
+ with Clocks.Error (loc, err) as exc ->
+ eprintf "Clock calculus error: %a%a@." Clocks.pp_error err Location.pp_loc
+ loc;
raise exc
in
Log.report ~level:1 (fun fmt -> fprintf fmt "@]");
- if !Options.print_clocks || !Options.verbose_level > 2 then
- Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2> %a@]@ " Corelang.pp_prog_clock decls);
+ if !Options.print_clocks || !Options.verbose_level > 2 then
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@[<v 2> %a@]@ " Corelang.pp_prog_clock decls);
new_env
(* Typing/Clocking with an empty env *)
let check_top_decls header =
- let new_tenv = type_decls Basic_library.type_env header in (* Typing *)
- let new_cenv = clock_decls Basic_library.clock_env header in (* Clock calculus *)
+ let new_tenv = type_decls Basic_library.type_env header in
+ (* Typing *)
+ let new_cenv = clock_decls Basic_library.clock_env header in
+ (* Clock calculus *)
header, new_tenv, new_cenv
+(* List.fold_right (fun top_decl (ty_env, ck_env) -> match
+ top_decl.top_decl_desc with | Node nd -> (Env.add_value ty_env nd.node_id
+ nd.node_type, Env.add_value ck_env nd.node_id nd.node_clock) | ImportedNode
+ ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type, Env.add_value
+ ck_env ind.nodei_id ind.nodei_clock) | Const c -> get_envs_from_const c
+ (ty_env, ck_env) | TypeDef _ -> List.fold_left (fun envs top ->
+ consts_of_enum_type top_decl | Open _ -> (ty_env, ck_env)) header
+ (Env.initial, Env.initial) *)
-(*
- List.fold_right
- (fun top_decl (ty_env, ck_env) ->
- match top_decl.top_decl_desc with
- | Node nd -> (Env.add_value ty_env nd.node_id nd.node_type,
- Env.add_value ck_env nd.node_id nd.node_clock)
- | ImportedNode ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type,
- Env.add_value ck_env ind.nodei_id ind.nodei_clock)
- | Const c -> get_envs_from_const c (ty_env, ck_env)
- | TypeDef _ -> List.fold_left (fun envs top -> consts_of_enum_type top_decl
- | Open _ -> (ty_env, ck_env))
- header
- (Env.initial, Env.initial)
- *)
-
-
-
-
-let check_compatibility (_, computed_types_env, computed_clocks_env) (header, declared_types_env, declared_clocks_env) =
+let check_compatibility (_, computed_types_env, computed_clocks_env)
+ (header, declared_types_env, declared_clocks_env) =
try
(* checking defined types are compatible with declared types*)
Typing.check_typedef_compat header;
@@ -165,66 +144,81 @@ let check_compatibility (_, computed_types_env, computed_clocks_env) (header, de
Typing.check_env_compat header declared_types_env computed_types_env;
(* checking clocks compatibility with computed clocks*)
- Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
+ Clock_calculus.check_env_compat header declared_clocks_env
+ computed_clocks_env;
(* checking stateless status compatibility *)
Stateless.check_compat header
with
- | (Types.Error (loc,err)) as exc ->
- eprintf "Type mismatch between computed type and declared type in lustre interface file: %a%a@."
- Types.pp_error err
- Location.pp_loc loc;
+ | Types.Error (loc, err) as exc ->
+ eprintf
+ "Type mismatch between computed type and declared type in lustre \
+ interface file: %a%a@."
+ Types.pp_error err Location.pp_loc loc;
raise exc
| Clocks.Error (loc, err) as exc ->
- eprintf "Clock mismatch between computed clock and declared clock in lustre interface file: %a%a@."
- Clocks.pp_error err
- Location.pp_loc loc;
+ eprintf
+ "Clock mismatch between computed clock and declared clock in lustre \
+ interface file: %a%a@."
+ Clocks.pp_error err Location.pp_loc loc;
raise exc
| Stateless.Error (loc, err) as exc ->
- eprintf "Stateless status mismatch between defined status and declared status in lustre interface file: %a%a@."
- Stateless.pp_error err
- Location.pp_loc loc;
+ eprintf
+ "Stateless status mismatch between defined status and declared status in \
+ lustre interface file: %a%a@."
+ Stateless.pp_error err Location.pp_loc loc;
raise exc
(* Process each node/imported node and introduce the associated contract node *)
let resolve_contracts prog =
- (* Bind a fresh node with a new name according to existing nodes and freshly binded contract node. Clean the contract to remove the stmts *)
+ (* Bind a fresh node with a new name according to existing nodes and freshly
+ binded contract node. Clean the contract to remove the stmts *)
let process_contract new_contracts c =
(* Format.eprintf "Process contract@."; *)
(* Resolve first the imports *)
let stmts, locals, c =
- List.fold_left (
- fun (stmts, locals, c) import ->
- (* Search for contract in prog.
- The node have to be processed already. Otherwise raise an error.
- Each stmts in injected with a fresh name
- Inputs are renamed and associated to the expression in1
- Same thing for outputs.
+ List.fold_left
+ (fun (stmts, locals, c) import ->
+ (* Search for contract in prog. The node have to be processed already.
+ Otherwise raise an error. Each stmts in injected with a fresh name
+ Inputs are renamed and associated to the expression in1 Same thing
+ for outputs.
- Last the contracts elements are replaced with the renamed vars and merged with c contract.
- *)
+ Last the contracts elements are replaced with the renamed vars and
+ merged with c contract. *)
let name = import.import_nodeid in
(* Format.eprintf "Process contract import %s@." name; *)
let loc = import.import_loc in
try
- let imp_nd = get_node name new_contracts in (* Get the contract node in process contracts *)
+ let imp_nd = get_node name new_contracts in
+ (* Get the contract node in process contracts *)
(* checking that it's actually a (processed) contract *)
let _ =
- if not (is_node_contract imp_nd) then
- assert false (* should be a contract *)
+ if not (is_node_contract imp_nd) then assert false
+ (* should be a contract *)
else
let imp_c = get_node_contract imp_nd in
- if not (imp_c.imports = [] && imp_c.locals = [] && imp_c.consts = [] && imp_c.stmts = []) then
- ( Format.eprintf "Invalid processed contract: %i %i %i %i@.@?" (List.length imp_c.imports) (List.length imp_c.locals) (List.length imp_c.consts) (List.length imp_c.stmts);
- assert false (* should be processed *)
- )
+ if
+ not
+ (imp_c.imports = [] && imp_c.locals = []
+ && imp_c.consts = [] && imp_c.stmts = [])
+ then (
+ Format.eprintf "Invalid processed contract: %i %i %i %i@.@?"
+ (List.length imp_c.imports)
+ (List.length imp_c.locals) (List.length imp_c.consts)
+ (List.length imp_c.stmts);
+ assert false (* should be processed *))
in
let name_prefix x = "__" ^ name ^ "__" ^ x in
- let imp_nd = rename_node (fun x -> x (* not changing node names *)) name_prefix imp_nd in
+ let imp_nd =
+ rename_node
+ (fun x -> x (* not changing node names *))
+ name_prefix imp_nd
+ in
let imp_in = imp_nd.node_inputs in
let imp_out = imp_nd.node_outputs in
let imp_locals = imp_nd.node_locals in
- let locals = imp_in@imp_out@imp_locals@locals in
+ let locals = imp_in @ imp_out @ imp_locals @ locals in
let imp_c = get_node_contract imp_nd in
(* Assigning in and out *)
let mk_def vars_l e =
@@ -233,164 +227,176 @@ let resolve_contracts prog =
in
let in_assigns = mk_def imp_in import.inputs in
let out_assigns = mk_def imp_out import.outputs in
- let stmts = in_assigns :: out_assigns :: imp_nd.node_stmts @ stmts in
+ let stmts =
+ in_assigns :: out_assigns :: imp_nd.node_stmts @ stmts
+ in
let c = merge_contracts c imp_c in
- stmts, locals, c
- with Not_found -> Format.eprintf "Where is contract %s@.@?" name; raise (Error.Error (loc, (Error.Unbound_symbol ("contract " ^ name))))
-
-
- ) ([], c.consts@c.locals, c) c.imports
+ stmts, locals, c
+ with Not_found ->
+ Format.eprintf "Where is contract %s@.@?" name;
+ raise (Error.Error (loc, Error.Unbound_symbol ("contract " ^ name))))
+ ([], c.consts @ c.locals, c)
+ c.imports
in
- let stmts = stmts @ c.stmts in
+ let stmts = stmts @ c.stmts in
(* Other contract elements will be normalized later *)
- let c = { c with (* we erase locals and stmts sinced they are now in the parent node *)
- locals = [];
- consts = [];
- stmts = [];
- imports = []
- }
+ let c =
+ {
+ c with
+ (* we erase locals and stmts sinced they are now in the parent node *)
+ locals = [];
+ consts = [];
+ stmts = [];
+ imports = [];
+ }
in
-
+
(* Format.eprintf "Processed stmts: %a@." Printers.pp_node_stmts stmts;
* Format.eprintf "Processed locals: %a@." Printers.pp_vars locals; *)
stmts, locals, c
-
in
+
let process_contract_new_node accu_contracts prog top =
let id, spec, inputs, outputs =
match top.top_decl_desc with
- | Node nd -> nd.node_id, nd.node_spec, nd.node_inputs, nd.node_outputs
- | ImportedNode ind -> ind.nodei_id, ind.nodei_spec, ind.nodei_inputs, ind.nodei_outputs
- | _ -> assert false
+ | Node nd ->
+ nd.node_id, nd.node_spec, nd.node_inputs, nd.node_outputs
+ | ImportedNode ind ->
+ ind.nodei_id, ind.nodei_spec, ind.nodei_inputs, ind.nodei_outputs
+ | _ ->
+ assert false
in
- (* Format.eprintf "Process contract new node for node %s@." id; *)
+ (* Format.eprintf "Process contract new node for node %s@." id; *)
let stmts, locals, c =
match spec with
- | None | Some (NodeSpec _) -> assert false
+ | None | Some (NodeSpec _) ->
+ assert false
| Some (Contract c) ->
- (* Format.eprintf "Processing contract of node %s@." id; *)
- process_contract accu_contracts c
+ (* Format.eprintf "Processing contract of node %s@." id; *)
+ process_contract accu_contracts c
in
(* Create a fresh name *)
- let used v = List.exists (fun top ->
- match top.top_decl_desc with
- | Node _
- | ImportedNode _ ->
- (node_name top) = v
- | _ -> false
- ) (accu_contracts@prog)
+ let used v =
+ List.exists
+ (fun top ->
+ match top.top_decl_desc with
+ | Node _ | ImportedNode _ ->
+ node_name top = v
+ | _ ->
+ false)
+ (accu_contracts @ prog)
in
let new_nd_id = mk_new_name used (id ^ "_coco") in
let new_nd =
- mktop_decl
- c.spec_loc
- top.top_decl_owner
- top.top_decl_itf
- (Node {
+ mktop_decl c.spec_loc top.top_decl_owner top.top_decl_itf
+ (Node
+ {
node_id = new_nd_id;
- node_type = Types.new_var ();
- node_clock = Clocks.new_var true;
- node_inputs = inputs;
- node_outputs = outputs;
- node_locals = locals;
- node_gencalls = [];
- node_checks = [];
- node_asserts = [];
- node_stmts = stmts;
- node_dec_stateless = false;
- node_stateless = None;
- node_spec = Some (Contract c);
- node_annot = [];
- node_iscontract = true;
- }) in
+ node_type = Types.new_var ();
+ node_clock = Clocks.new_var true;
+ node_inputs = inputs;
+ node_outputs = outputs;
+ node_locals = locals;
+ node_gencalls = [];
+ node_checks = [];
+ node_asserts = [];
+ node_stmts = stmts;
+ node_dec_stateless = false;
+ node_stateless = None;
+ node_spec = Some (Contract c);
+ node_annot = [];
+ node_iscontract = true;
+ })
+ in
new_nd
in
(* Processing nodes in order. Should have been sorted by now
Each top level contract is processed: stmts pushed in node
- Each regular imported node or node associated with a contract is
- replaced with a simplidfied contract and its contract is bound to
- a fresh node.
-
- *)
+ Each regular imported node or node associated with a contract is replaced
+ with a simplidfied contract and its contract is bound to a fresh node. *)
let new_contracts, prog =
List.fold_left
- (
- fun (accu_contracts, accu_nodes) top ->
+ (fun (accu_contracts, accu_nodes) top ->
match top.top_decl_desc with
-
| Node nd when nd.node_iscontract -> (
match nd.node_spec with
- | None | Some (NodeSpec _) -> assert false
+ | None | Some (NodeSpec _) ->
+ assert false
| Some (Contract c) ->
- (* Format.eprintf "Processing top contract %s@." nd.node_id; *)
- let stmts, locals, c = process_contract accu_contracts c in
- let nd =
- { nd with
- node_locals = nd.node_locals @ locals;
- node_stmts = nd.node_stmts @ stmts;
- node_spec = Some (Contract c);
- }
- in
- { top with top_decl_desc = Node nd }::accu_contracts,
- accu_nodes
-
- )
+ (* Format.eprintf "Processing top contract %s@." nd.node_id; *)
+ let stmts, locals, c = process_contract accu_contracts c in
+ let nd =
+ {
+ nd with
+ node_locals = nd.node_locals @ locals;
+ node_stmts = nd.node_stmts @ stmts;
+ node_spec = Some (Contract c);
+ }
+ in
+ { top with top_decl_desc = Node nd } :: accu_contracts, accu_nodes)
| Node nd -> (
match nd.node_spec with
- | None -> accu_contracts, top::accu_nodes (* A boring node: no contract *)
- | Some (NodeSpec _) -> (* shall not happen, its too early *)
- assert false
- | Some (Contract _) -> (* A contract: processing it *)
- (* we bind a fresh node *)
- let new_nd = process_contract_new_node accu_contracts prog top in
- (* Format.eprintf "Creating new contract node %s@." (node_name new_nd); *)
- let nd = { nd with node_spec = (Some (NodeSpec (node_name new_nd))) } in
- new_nd::accu_contracts,
- { top with top_decl_desc = Node nd }::accu_nodes
-
- )
-
- | ImportedNode ind -> ( (* Similar treatment for imported nodes *)
+ | None ->
+ accu_contracts, top :: accu_nodes (* A boring node: no contract *)
+ | Some (NodeSpec _) ->
+ (* shall not happen, its too early *)
+ assert false
+ | Some (Contract _) ->
+ (* A contract: processing it *)
+ (* we bind a fresh node *)
+ let new_nd = process_contract_new_node accu_contracts prog top in
+ (* Format.eprintf "Creating new contract node %s@." (node_name
+ new_nd); *)
+ let nd =
+ { nd with node_spec = Some (NodeSpec (node_name new_nd)) }
+ in
+ ( new_nd :: accu_contracts,
+ { top with top_decl_desc = Node nd } :: accu_nodes ))
+ | ImportedNode ind -> (
+ (* Similar treatment for imported nodes *)
match ind.nodei_spec with
- None -> accu_contracts, top::accu_nodes (* A boring node: no contract *)
- | Some (NodeSpec _) -> (* shall not happen, its too early *)
- assert false
- | Some (Contract _) -> (* A contract: processing it *)
- (* we bind a fresh node *)
- let new_nd = process_contract_new_node accu_contracts prog top in
- let ind = { ind with nodei_spec = (Some (NodeSpec (node_name new_nd))) } in
- new_nd::accu_contracts,
- { top with top_decl_desc = ImportedNode ind }::accu_nodes
- )
- | _ -> accu_contracts, top::accu_nodes
- ) ([],[]) prog
+ | None ->
+ accu_contracts, top :: accu_nodes (* A boring node: no contract *)
+ | Some (NodeSpec _) ->
+ (* shall not happen, its too early *)
+ assert false
+ | Some (Contract _) ->
+ (* A contract: processing it *)
+ (* we bind a fresh node *)
+ let new_nd = process_contract_new_node accu_contracts prog top in
+ let ind =
+ { ind with nodei_spec = Some (NodeSpec (node_name new_nd)) }
+ in
+ ( new_nd :: accu_contracts,
+ { top with top_decl_desc = ImportedNode ind } :: accu_nodes ))
+ | _ ->
+ accu_contracts, top :: accu_nodes)
+ ([], []) prog
in
- (List.rev new_contracts) @ (List.rev prog)
-
+ List.rev new_contracts @ List.rev prog
-
let track_exception () =
- if !Options.track_exceptions
- then (Printexc.print_backtrace stdout; flush stdout)
+ if !Options.track_exceptions then (
+ Printexc.print_backtrace stdout;
+ flush stdout)
else ()
-
let update_vdecl_parents_prog prog =
- let update_vdecl_parents parent v =
- v.var_parent_nodeid <- Some parent
- in
- List.iter (
- fun top -> match top.top_decl_desc with
- | Node nd ->
- List.iter
- (update_vdecl_parents nd.node_id)
- (nd.node_inputs @ nd.node_outputs @ nd.node_locals )
- | ImportedNode ind ->
- List.iter
- (update_vdecl_parents ind.nodei_id)
- (ind.nodei_inputs @ ind.nodei_outputs )
- | _ -> ()
- ) prog
+ let update_vdecl_parents parent v = v.var_parent_nodeid <- Some parent in
+ List.iter
+ (fun top ->
+ match top.top_decl_desc with
+ | Node nd ->
+ List.iter
+ (update_vdecl_parents nd.node_id)
+ (nd.node_inputs @ nd.node_outputs @ nd.node_locals)
+ | ImportedNode ind ->
+ List.iter
+ (update_vdecl_parents ind.nodei_id)
+ (ind.nodei_inputs @ ind.nodei_outputs)
+ | _ ->
+ ())
+ prog
diff --git a/src/compiler_stages.ml b/src/compiler_stages.ml
index 841e1fc300adc76673f6f6188398386f93d7a030..7ce0503b8c7d730691378b7e7c247a76a4295000 100644
--- a/src/compiler_stages.ml
+++ b/src/compiler_stages.ml
@@ -6,55 +6,50 @@ module Mpfr = Lustrec_mpfr
exception StopPhase1 of program_t
let dynamic_checks () =
- match !Options.output, !Options.spec with
- | "C", "C" -> true
- | _ -> false
-
+ match !Options.output, !Options.spec with "C", "C" -> true | _ -> false
let generate_c_header = ref false
(* check whether a source file has a compiled header, if not, generate the
compiled header *)
-let compile_source_to_header prog computed_types_env computed_clocks_env dirname basename extension =
+let compile_source_to_header prog computed_types_env computed_clocks_env dirname
+ basename extension =
let destname = !Options.dest_dir ^ "/" ^ basename in
let lusic_ext = ".lusic" in
let header_name = destname ^ lusic_ext in
let from_lusi = extension = ".lusi" in
- begin
- if (* Generating the lusic file *)
- (* because input is a lusi *)
- from_lusi
- (* or because it is a lus but no lusic exists *)
- || (extension = ".lus" && not (Sys.file_exists header_name))
- (* or the lusic exists but is not generated from a lusi, hence it
- has te be regenerated *)
- || (let lusic = Lusic.read_lusic destname lusic_ext in
- not lusic.Lusic.from_lusi)
- then
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. generating compiled header file %s@,"
- header_name);
- Lusic.write_lusic
- from_lusi (* is it a lusi file ? *)
- (if from_lusi then prog else Lusic.extract_header dirname basename prog)
- destname
- lusic_ext;
- generate_c_header := !Options.output = "C";
- end
- else (* Lusic exists and is usable. Checking compatibility *)
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. loading compiled header file %s@,"
- header_name);
- let lusic = Lusic.read_lusic destname lusic_ext in
- Lusic.check_obsolete lusic destname;
- let header = lusic.Lusic.contents in
- let (declared_types_env, declared_clocks_env) = Modules.get_envs_from_top_decls header in
- check_compatibility
- (prog, computed_types_env, computed_clocks_env)
- (header, declared_types_env, declared_clocks_env)
- end
- end
-
+ if
+ (* Generating the lusic file *)
+ (* because input is a lusi *)
+ from_lusi
+ (* or because it is a lus but no lusic exists *)
+ || (extension = ".lus" && not (Sys.file_exists header_name))
+ (* or the lusic exists but is not generated from a lusi, hence it has te be
+ regenerated *)
+ ||
+ let lusic = Lusic.read_lusic destname lusic_ext in
+ not lusic.Lusic.from_lusi
+ then (
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@ .. generating compiled header file %s@," header_name);
+ Lusic.write_lusic from_lusi
+ (* is it a lusi file ? *)
+ (if from_lusi then prog else Lusic.extract_header dirname basename prog)
+ destname lusic_ext;
+ generate_c_header := !Options.output = "C")
+ else (
+ (* Lusic exists and is usable. Checking compatibility *)
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@ .. loading compiled header file %s@," header_name);
+ let lusic = Lusic.read_lusic destname lusic_ext in
+ Lusic.check_obsolete lusic destname;
+ let header = lusic.Lusic.contents in
+ let declared_types_env, declared_clocks_env =
+ Modules.get_envs_from_top_decls header
+ in
+ check_compatibility
+ (prog, computed_types_env, computed_clocks_env)
+ (header, declared_types_env, declared_clocks_env))
(* From prog to prog *)
let stage1 params prog dirname basename extension =
@@ -64,17 +59,18 @@ let stage1 params prog dirname basename extension =
(* Removing automata *)
let prog = expand_automata prog in
Log.report ~level:4 (fun fmt ->
- fprintf fmt "@[<v 2>.. after automata expansion:@ %a@]@ "
- Printers.pp_prog prog
- (* Utils.Format.pp_print_nothing () *)
- );
+ fprintf fmt "@[<v 2>.. after automata expansion:@ %a@]@ " Printers.pp_prog
+ prog
+ (* Utils.Format.pp_print_nothing () *));
(* Importing source *)
- let prog, dependencies, (typ_env, clk_env) = Modules.load ~is_header:(extension = ".lusi") prog in
+ let prog, dependencies, (typ_env, clk_env) =
+ Modules.load ~is_header:(extension = ".lusi") prog
+ in
(* Registering types and clocks for future checks *)
Global.type_env := Env.overwrite !Global.type_env typ_env;
Global.clock_env := Env.overwrite !Global.clock_env clk_env;
-
+
(* (\* Extracting dependencies (and updating Global.(type_env/clock_env) *\)
* let dependencies = import_dependencies prog in *)
@@ -84,37 +80,35 @@ let stage1 params prog dirname basename extension =
let prog = resolve_contracts prog in
let prog = SortProg.sort prog in
Log.report ~level:3 (fun fmt ->
- Format.fprintf fmt "@ @[<v 2>.. contracts resolved:@ %a@ @]@ " Printers.pp_prog prog);
+ Format.fprintf fmt "@ @[<v 2>.. contracts resolved:@ %a@ @]@ "
+ Printers.pp_prog prog);
(* Consolidating main node *)
let _ =
match !Options.main_node with
- | "" -> ()
+ | "" ->
+ ()
| main_node -> (
Global.main_node := main_node;
- try
- ignore (Corelang.node_from_name main_node)
- with Not_found -> (
- Format.eprintf "Code generation error: %a@." Error.pp_error_msg Error.Main_not_found;
- raise (Error.Error (Location.dummy_loc, Error.Main_not_found))
- ))
+ try ignore (Corelang.node_from_name main_node)
+ with Not_found ->
+ Format.eprintf "Code generation error: %a@." Error.pp_error_msg
+ Error.Main_not_found;
+ raise (Error.Error (Location.dummy_loc, Error.Main_not_found)))
in
-
+
(* Perform inlining before any analysis *)
let _, prog =
if !Options.global_inline && !Global.main_node <> "" then
- (if !Options.witnesses then prog else []),
- Inliner.global_inline prog
+ (if !Options.witnesses then prog else []), Inliner.global_inline prog
else (* if !Option.has_local_inline *)
- [],
- Inliner.local_inline prog (* type_env clock_env *)
+ [], Inliner.local_inline prog
+ (* type_env clock_env *)
in
(* Checking stateless/stateful status *)
- if Plugins.check_force_stateful () then
- force_stateful_decls prog
- else
- check_stateless_decls prog;
+ if Plugins.check_force_stateful () then force_stateful_decls prog
+ else check_stateless_decls prog;
(* Typing *)
Global.type_env := type_decls !Global.type_env prog;
@@ -125,83 +119,54 @@ let stage1 params prog dirname basename extension =
(* Registering and checking machine types *)
if Machine_types.is_active then Machine_types.load prog;
-
(* Generating a .lusi header file only *)
if !Options.lusi || !Options.print_nodes then
(* We stop here the processing and produce the current prog. It will be
exported as a lusi *)
raise (StopPhase1 prog);
- (* Optimization of prog:
- - Unfold consts
- - eliminate trivial expressions
- *)
-
+ (* Optimization of prog: - Unfold consts - eliminate trivial expressions *)
let prog =
- if !Options.const_unfold || !Options.optimization >= 5 then
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. eliminating constants and aliases@,");
- Optimize_prog.prog_unfold_consts prog
- end
- else
- prog
+ if !Options.const_unfold || !Options.optimization >= 5 then (
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt ".. eliminating constants and aliases@,");
+ Optimize_prog.prog_unfold_consts prog)
+ else prog
in
-
+
(* Delay calculus *)
- (* TO BE DONE LATER (Xavier)
- if(!Options.delay_calculus)
- then
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. initialisation analysis@?");
- try
- Delay_calculus.delay_prog Basic_library.delay_env prog
- with (Delay.Error (loc,err)) as exc ->
- Location.print loc;
- eprintf "%a" Delay.pp_error err;
- Utils.track_exception ();
- raise exc
- end;
- *)
+ (* TO BE DONE LATER (Xavier) if(!Options.delay_calculus) then begin Log.report
+ ~level:1 (fun fmt -> fprintf fmt ".. initialisation analysis@?"); try
+ Delay_calculus.delay_prog Basic_library.delay_env prog with (Delay.Error
+ (loc,err)) as exc -> Location.print loc; eprintf "%a" Delay.pp_error err;
+ Utils.track_exception (); raise exc end; *)
(* Creating destination directory if needed *)
create_dest_dir ();
-
+
Typing.uneval_prog_generics prog;
Clock_calculus.uneval_prog_generics prog;
-
- (* Disabling witness option. Could but reactivated later
- if !Options.global_inline && !Options.main_node <> "" && !Options.witnesses then
- begin
- let orig = Corelang.copy_prog orig in
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating witness file@,");
- check_stateless_decls orig;
- let _ = Typing.type_prog type_env orig in
- let _ = Clock_calculus.clock_prog clock_env orig in
- Typing.uneval_prog_generics orig;
- Clock_calculus.uneval_prog_generics orig;
- Inliner.witness
- basename
- !Options.main_node
- orig prog type_env clock_env
- end;
- *)
-
- (* Computes and stores generic calls for each node,
- only useful for ANSI C90 compliant generic node compilation *)
+ (* Disabling witness option. Could but reactivated later if
+ !Options.global_inline && !Options.main_node <> "" && !Options.witnesses
+ then begin let orig = Corelang.copy_prog orig in Log.report ~level:1 (fun
+ fmt -> fprintf fmt ".. generating witness file@,"); check_stateless_decls
+ orig; let _ = Typing.type_prog type_env orig in let _ =
+ Clock_calculus.clock_prog clock_env orig in Typing.uneval_prog_generics
+ orig; Clock_calculus.uneval_prog_generics orig; Inliner.witness basename
+ !Options.main_node orig prog type_env clock_env end; *)
+
+ (* Computes and stores generic calls for each node, only useful for ANSI C90
+ compliant generic node compilation *)
if !Options.ansi then Causality.NodeDep.compute_generic_calls prog;
+
(*Hashtbl.iter (fun id td -> match td.Corelang.top_decl_desc with
Corelang.Node nd -> Format.eprintf "%s calls %a" id
Causality.NodeDep.pp_generic_calls nd | _ -> ()) Corelang.node_table;*)
- (* If some backend involving dynamic checks are active, then node annotations become runtime checks *)
- let prog =
- if dynamic_checks () then
- Spec.enforce_spec_prog prog
- else
- prog
- in
-
+ (* If some backend involving dynamic checks are active, then node annotations
+ become runtime checks *)
+ let prog = if dynamic_checks () then Spec.enforce_spec_prog prog else prog in
(* (\* Registering and checking machine types *\) *)
(* Machine_types.load prog; *)
@@ -209,55 +174,51 @@ let stage1 params prog dirname basename extension =
(* Normalization phase *)
Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. normalization@ ");
let prog = Normalization.normalize_prog params prog in
- Log.report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@ "
- Printers.pp_prog_short prog);
- Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@ "
- Printers.pp_prog prog);
-
+ Log.report ~level:2 (fun fmt ->
+ fprintf fmt "@[<v 2>@ %a@]@ " Printers.pp_prog_short prog);
+ Log.report ~level:3 (fun fmt ->
+ fprintf fmt "@[<v 2>@ %a@]@ " Printers.pp_prog prog);
+
(* Compatibility with Lusi *)
- (* If compiling a lusi, generate the lusic. If this is a lus file, Check the existence of a lusi (Lustre Interface file) *)
+ (* If compiling a lusi, generate the lusic. If this is a lus file, Check the
+ existence of a lusi (Lustre Interface file) *)
if !Options.compile_header then
- compile_source_to_header
- prog !Global.type_env !Global.clock_env dirname basename extension;
-
+ compile_source_to_header prog !Global.type_env !Global.clock_env dirname
+ basename extension;
let prog =
- if !Options.mpfr
- then
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. targetting MPFR library@,");
- Mpfr.inject_prog prog
- end
- else
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. keeping floating-point numbers@,");
- prog
- end in
- Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Printers.pp_prog prog);
+ if !Options.mpfr then (
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@ .. targetting MPFR library@,");
+ Mpfr.inject_prog prog)
+ else (
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@ .. keeping floating-point numbers@,");
+ prog)
+ in
+ Log.report ~level:3 (fun fmt ->
+ fprintf fmt "@[<v 2>@ %a@]@," Printers.pp_prog prog);
(* Checking array accesses *)
- if !Options.check then
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. checking array accesses@,");
- Access.check_prog prog;
- end;
-
+ if !Options.check then (
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@ .. checking array accesses@,");
+ Access.check_prog prog);
let prog = SortProg.sort_nodes_locals prog in
prog, dependencies
-
- (* from source to machine code, with optimization *)
+(* from source to machine code, with optimization *)
let stage2 params prog =
(* Computation of node equation scheduling. It also breaks dependency cycles
and warns about unused input or memory variables *)
Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. scheduling@ ");
let prog, node_schs =
- try
- Scheduling.schedule_prog prog
- with Causality.Error _ -> (* Error is not kept. It is recomputed in a more
- systemtic way in AlgebraicLoop module *)
+ try Scheduling.schedule_prog prog
+ with Causality.Error _ ->
+ (* Error is not kept. It is recomputed in a more systemtic way in
+ AlgebraicLoop module *)
AlgebraicLoop.analyze prog
in
Scheduling.(
@@ -268,101 +229,89 @@ let stage2 params prog =
Log.report ~level:3 (fun fmt -> fprintf fmt "@ %a" Printers.pp_prog prog);
Log.report ~level:1 (fun fmt -> fprintf fmt "@]@ "));
- (* TODO Salsa optimize prog:
- - emits warning for programs with pre inside expressions
- - make sure each node arguments and memory is bounded by a local annotation
- - introduce fresh local variables for each real pure subexpression
- *)
+ (* TODO Salsa optimize prog: - emits warning for programs with pre inside
+ expressions - make sure each node arguments and memory is bounded by a
+ local annotation - introduce fresh local variables for each real pure
+ subexpression *)
(* DFS with modular code generation *)
- Log.report ~level:1 (fun fmt -> fprintf fmt "@ @[<v 2>.. machines generation@ ");
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@ @[<v 2>.. machines generation@ ");
let machine_code = Machine_code.translate_prog prog node_schs in
Log.report ~level:1 (fun fmt -> fprintf fmt "@]");
- Log.report ~level:3 (fun fmt -> fprintf fmt "@ @[<v 2>.. generated machines (unoptimized):@ %a@]@ "
- Machine_code_common.pp_machines machine_code);
+ Log.report ~level:3 (fun fmt ->
+ fprintf fmt "@ @[<v 2>.. generated machines (unoptimized):@ %a@]@ "
+ Machine_code_common.pp_machines machine_code);
(* Optimize machine code *)
Optimize_machine.optimize params prog node_schs machine_code
-
(* printing code *)
let stage3 prog machine_code dependencies basename extension =
- let basename = Filename.basename basename in
+ let basename = Filename.basename basename in
match !Options.output, extension with
- "C", ".lus" ->
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,");
- C_backend.translate_to_c !generate_c_header
- (* alloc_header_file source_lib_file source_main_file makefile_file *)
- basename prog machine_code dependencies
- end
-(*
- | "acsl", ".lus" ->
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. ACSL annotations generation@,");
- ACSL_backend.translate_to_acsl
- (* alloc_header_file source_lib_file source_main_file makefile_file *)
- basename prog machine_code dependencies
- end
-*)
- | "C", _ ->
- begin
- C_backend.print_c_header basename;
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. no C code generation for lusi@,");
- end
+ | "C", ".lus" ->
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,");
+ C_backend.translate_to_c !generate_c_header
+ (* alloc_header_file source_lib_file source_main_file makefile_file *)
+ basename prog machine_code dependencies
+ (* | "acsl", ".lus" -> begin Log.report ~level:1 (fun fmt -> fprintf fmt "..
+ ACSL annotations generation@,"); ACSL_backend.translate_to_acsl (*
+ alloc_header_file source_lib_file source_main_file makefile_file *)
+ basename prog machine_code dependencies end *)
+ | "C", _ ->
+ C_backend.print_c_header basename;
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt ".. no C code generation for lusi@,")
| "java", _ ->
- begin
- (Format.eprintf "internal error: sorry, but not yet supported !"; assert false)
- (*let source_file = basename ^ ".java" in
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. opening file %s@,@?" source_file);
- let source_out = open_out source_file in
- let source_fmt = formatter_of_out_channel source_out in
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. java code generation@,@?");
- Java_backend.translate_to_java source_fmt basename normalized_prog machine_code;*)
- end
+ Format.eprintf "internal error: sorry, but not yet supported !";
+ assert false
+ (*let source_file = basename ^ ".java" in Log.report ~level:1 (fun fmt ->
+ fprintf fmt ".. opening file %s@,@?" source_file); let source_out = open_out
+ source_file in let source_fmt = formatter_of_out_channel source_out in
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. java code generation@,@?");
+ Java_backend.translate_to_java source_fmt basename normalized_prog
+ machine_code;*)
| "Ada", _ ->
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. Ada code generation@.");
- Ada_backend.translate_to_ada
- basename (Machine_code_common.arrow_machine::machine_code)
- end
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. Ada code generation@.");
+ Ada_backend.translate_to_ada basename
+ (Machine_code_common.arrow_machine :: machine_code)
| "horn", _ ->
- begin
- let destname = !Options.dest_dir ^ "/" ^ basename in
- let source_file = destname ^ ".smt2" in (* Could be changed *)
- let source_out = open_out source_file in
- let fmt = formatter_of_out_channel source_out in
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. hornification@,");
- Horn_backend.translate fmt prog (Machine_code_common.arrow_machine::machine_code);
- (* Tracability file if option is activated *)
- if !Options.traces then (
- let traces_file = destname ^ ".traces.xml" in (* Could be changed *)
- let traces_out = open_out traces_file in
- let fmt = formatter_of_out_channel traces_out in
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. tracing info@,");
- Horn_backend_traces.traces_file fmt machine_code;
- )
- end
+ let destname = !Options.dest_dir ^ "/" ^ basename in
+ let source_file = destname ^ ".smt2" in
+ (* Could be changed *)
+ let source_out = open_out source_file in
+ let fmt = formatter_of_out_channel source_out in
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. hornification@,");
+ Horn_backend.translate fmt prog
+ (Machine_code_common.arrow_machine :: machine_code);
+ (* Tracability file if option is activated *)
+ if !Options.traces then (
+ let traces_file = destname ^ ".traces.xml" in
+ (* Could be changed *)
+ let traces_out = open_out traces_file in
+ let fmt = formatter_of_out_channel traces_out in
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. tracing info@,");
+ Horn_backend_traces.traces_file fmt machine_code)
| "lustre", _ ->
- begin
- let destname = !Options.dest_dir ^ "/" ^ basename in
- let source_file = destname ^ ".lustrec" ^ extension in (* Could be changed *)
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. exporting processed file as %s@," source_file);
- let source_out = open_out source_file in
- let fmt = formatter_of_out_channel source_out in
- Printers.pp_prog fmt prog;
- Format.fprintf fmt "@.@?";
- (* Lustre_backend.translate fmt basename normalized_prog machine_code *)
- ()
- end
+ let destname = !Options.dest_dir ^ "/" ^ basename in
+ let source_file = destname ^ ".lustrec" ^ extension in
+ (* Could be changed *)
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt ".. exporting processed file as %s@," source_file);
+ let source_out = open_out source_file in
+ let fmt = formatter_of_out_channel source_out in
+ Printers.pp_prog fmt prog;
+ Format.fprintf fmt "@.@?";
+ (* Lustre_backend.translate fmt basename normalized_prog machine_code *)
+ ()
| "emf", _ ->
- begin
- let destname = !Options.dest_dir ^ "/" ^ basename in
- let source_file = destname ^ ".json" in (* Could be changed *)
- let source_out = open_out source_file in
- let fmt = formatter_of_out_channel source_out in
- EMF_backend.translate fmt basename prog machine_code;
- ()
- end
-
- | _ -> assert false
+ let destname = !Options.dest_dir ^ "/" ^ basename in
+ let source_file = destname ^ ".json" in
+ (* Could be changed *)
+ let source_out = open_out source_file in
+ let fmt = formatter_of_out_channel source_out in
+ EMF_backend.translate fmt basename prog machine_code;
+ ()
+ | _ ->
+ assert false
diff --git a/src/corelang.ml b/src/corelang.ml
index a819930d0ba4dc16db952fb2a8fb1c46a74ef823..fabbe47f4bfec7982d21814c466f46983a6c6a9e 100644
--- a/src/corelang.ml
+++ b/src/corelang.ml
@@ -14,47 +14,53 @@ open Lustre_types
open Machine_code_types
(*open Dimension*)
-
-module VDeclModule =
-struct (* Node module *)
+module VDeclModule = struct
+ (* Node module *)
type t = var_decl
+
let compare v1 v2 = compare v1.var_id v2.var_id
end
-module VMap = Map.Make(VDeclModule)
+module VMap = Map.Make (VDeclModule)
-module VSet: sig
+module VSet : sig
include Set.S
- val pp: Format.formatter -> t -> unit
- val get: ident -> t -> elt
-end with type elt = var_decl =
- struct
- include Set.Make(VDeclModule)
- let pp fmt s =
- Format.fprintf fmt "{@[%a}@]" (Utils.fprintf_list ~sep:",@ " Printers.pp_var) (elements s)
- (* Strangley the find_first function of Set.Make is incorrect (at
- the current time of writting this comment. Had to switch to
- lists *)
- let get id s = List.find (fun v -> v.var_id = id) (elements s)
- end
-let dummy_type_dec = {ty_dec_desc=Tydec_any; ty_dec_loc=Location.dummy_loc}
-let dummy_clock_dec = {ck_dec_desc=Ckdec_any; ck_dec_loc=Location.dummy_loc}
+ val pp : Format.formatter -> t -> unit
+
+ val get : ident -> t -> elt
+end
+with type elt = var_decl = struct
+ include Set.Make (VDeclModule)
+
+ let pp fmt s =
+ Format.fprintf fmt "{@[%a}@]"
+ (Utils.fprintf_list ~sep:",@ " Printers.pp_var)
+ (elements s)
+ (* Strangley the find_first function of Set.Make is incorrect (at the current
+ time of writting this comment. Had to switch to lists *)
+ let get id s = List.find (fun v -> v.var_id = id) (elements s)
+end
+let dummy_type_dec =
+ { ty_dec_desc = Tydec_any; ty_dec_loc = Location.dummy_loc }
+
+let dummy_clock_dec =
+ { ck_dec_desc = Ckdec_any; ck_dec_loc = Location.dummy_loc }
(************************************************************)
(* *)
-let mktyp loc d =
- { ty_dec_desc = d; ty_dec_loc = loc }
+let mktyp loc d = { ty_dec_desc = d; ty_dec_loc = loc }
-let mkclock loc d =
- { ck_dec_desc = d; ck_dec_loc = loc }
+let mkclock loc d = { ck_dec_desc = d; ck_dec_loc = loc }
-let mkvar_decl loc ?(orig=false) (id, ty_dec, ck_dec, is_const, value, parentid) =
+let mkvar_decl loc ?(orig = false)
+ (id, ty_dec, ck_dec, is_const, value, parentid) =
assert (value = None || is_const);
- { var_id = id;
+ {
+ var_id = id;
var_orig = orig;
var_dec_type = ty_dec;
var_dec_clock = ck_dec;
@@ -63,7 +69,8 @@ let mkvar_decl loc ?(orig=false) (id, ty_dec, ck_dec, is_const, value, parentid)
var_parent_nodeid = parentid;
var_type = Types.new_var ();
var_clock = Clocks.new_var true;
- var_loc = loc }
+ var_loc = loc;
+ }
let dummy_var_decl name typ =
{
@@ -74,22 +81,25 @@ let dummy_var_decl name typ =
var_dec_const = false;
var_dec_value = None;
var_parent_nodeid = None;
- var_type = typ;
+ var_type = typ;
var_clock = Clocks.new_ck Clocks.Cvar true;
- var_loc = Location.dummy_loc
+ var_loc = Location.dummy_loc;
}
let mkexpr loc d =
- { expr_tag = Utils.new_tag ();
+ {
+ expr_tag = Utils.new_tag ();
expr_desc = d;
expr_type = Types.new_var ();
expr_clock = Clocks.new_var true;
expr_delay = Delay.new_var ();
expr_annot = None;
- expr_loc = loc }
+ expr_loc = loc;
+ }
-let var_decl_of_const ?(parentid=None) c =
- { var_id = c.const_id;
+let var_decl_of_const ?(parentid = None) c =
+ {
+ var_id = c.const_id;
var_orig = true;
var_dec_type = { ty_dec_loc = c.const_loc; ty_dec_desc = Tydec_any };
var_dec_clock = { ck_dec_loc = c.const_loc; ck_dec_desc = Ckdec_any };
@@ -98,281 +108,313 @@ let var_decl_of_const ?(parentid=None) c =
var_parent_nodeid = parentid;
var_type = c.const_type;
var_clock = Clocks.new_var false;
- var_loc = c.const_loc }
+ var_loc = c.const_loc;
+ }
let mk_new_name used id =
let rec new_name name cpt =
- if used name
- then new_name (sprintf "_%s_%i" id cpt) (cpt+1)
- else name
- in new_name id 1
-
-let mkeq loc (lhs, rhs) =
- { eq_lhs = lhs;
- eq_rhs = rhs;
- eq_loc = loc }
-
-let mkassert loc expr =
- { assert_loc = loc;
- assert_expr = expr
- }
+ if used name then new_name (sprintf "_%s_%i" id cpt) (cpt + 1) else name
+ in
+ new_name id 1
+
+let mkeq loc (lhs, rhs) = { eq_lhs = lhs; eq_rhs = rhs; eq_loc = loc }
+
+let mkassert loc expr = { assert_loc = loc; assert_expr = expr }
let mktop_decl loc own itf d =
- { top_decl_desc = d; top_decl_loc = loc; top_decl_owner = own; top_decl_itf = itf }
+ {
+ top_decl_desc = d;
+ top_decl_loc = loc;
+ top_decl_owner = own;
+ top_decl_itf = itf;
+ }
let mkpredef_call loc funname args =
mkexpr loc (Expr_appl (funname, mkexpr loc (Expr_tuple args), None))
-let is_clock_dec_type cty =
- match cty with
- | Tydec_clock _ -> true
- | _ -> false
+let is_clock_dec_type cty = match cty with Tydec_clock _ -> true | _ -> false
let const_of_top top_decl =
- match top_decl.top_decl_desc with
- | Const c -> c
- | _ -> assert false
+ match top_decl.top_decl_desc with Const c -> c | _ -> assert false
let node_of_top top_decl =
- match top_decl.top_decl_desc with
- | Node nd -> nd
- | _ -> raise Not_found
+ match top_decl.top_decl_desc with Node nd -> nd | _ -> raise Not_found
let imported_node_of_top top_decl =
match top_decl.top_decl_desc with
- | ImportedNode ind -> ind
- | _ -> assert false
+ | ImportedNode ind ->
+ ind
+ | _ ->
+ assert false
let typedef_of_top top_decl =
- match top_decl.top_decl_desc with
- | TypeDef tdef -> tdef
- | _ -> assert false
+ match top_decl.top_decl_desc with TypeDef tdef -> tdef | _ -> assert false
let dependency_of_top top_decl =
match top_decl.top_decl_desc with
- | Open (local, dep) -> (local, dep)
- | _ -> assert false
+ | Open (local, dep) ->
+ local, dep
+ | _ ->
+ assert false
let consts_of_enum_type top_decl =
match top_decl.top_decl_desc with
- | TypeDef tdef ->
- (match tdef.tydef_desc with
+ | TypeDef tdef -> (
+ match tdef.tydef_desc with
| Tydec_enum tags ->
- List.map
- (fun tag ->
- let cdecl = {
- const_id = tag;
- const_loc = top_decl.top_decl_loc;
- const_value = Const_tag tag;
- const_type = Type_predef.type_const tdef.tydef_id
- } in
- { top_decl with top_decl_desc = Const cdecl })
- tags
- | _ -> [])
- | _ -> assert false
+ List.map
+ (fun tag ->
+ let cdecl =
+ {
+ const_id = tag;
+ const_loc = top_decl.top_decl_loc;
+ const_value = Const_tag tag;
+ const_type = Type_predef.type_const tdef.tydef_id;
+ }
+ in
+ { top_decl with top_decl_desc = Const cdecl })
+ tags
+ | _ ->
+ [])
+ | _ ->
+ assert false
(************************************************************)
(* Eexpr functions *)
(************************************************************)
-
let empty_contract =
{
- consts = []; locals = []; stmts = []; assume = []; guarantees = []; modes = []; imports = []; spec_loc = Location.dummy_loc;
+ consts = [];
+ locals = [];
+ stmts = [];
+ assume = [];
+ guarantees = [];
+ modes = [];
+ imports = [];
+ spec_loc = Location.dummy_loc;
}
-(* For const declaration we do as for regular lustre node.
-But for local flows we registered the variable and the lustre flow definition *)
+(* For const declaration we do as for regular lustre node. But for local flows
+ we registered the variable and the lustre flow definition *)
let mk_contract_var id is_const type_opt expr loc =
let typ = match type_opt with None -> mktyp loc Tydec_any | Some t -> t in
if is_const then
- let v = mkvar_decl loc (id, typ, mkclock loc Ckdec_any, is_const, Some expr, None) in
- { empty_contract with consts = [v]; spec_loc = loc; }
+ let v =
+ mkvar_decl loc (id, typ, mkclock loc Ckdec_any, is_const, Some expr, None)
+ in
+ { empty_contract with consts = [ v ]; spec_loc = loc }
else
- let v = mkvar_decl loc (id, typ, mkclock loc Ckdec_any, is_const, None, None) in
- let eq = mkeq loc ([id], expr) in
- { empty_contract with locals = [v]; stmts = [Eq eq]; spec_loc = loc; }
+ let v =
+ mkvar_decl loc (id, typ, mkclock loc Ckdec_any, is_const, None, None)
+ in
+ let eq = mkeq loc ([ id ], expr) in
+ { empty_contract with locals = [ v ]; stmts = [ Eq eq ]; spec_loc = loc }
-let eexpr_add_name eexpr eexpr_name =
- { eexpr with eexpr_name }
+let eexpr_add_name eexpr eexpr_name = { eexpr with eexpr_name }
let mk_contract_guarantees name eexpr =
- { empty_contract with guarantees = [eexpr_add_name eexpr name]; spec_loc = eexpr.eexpr_loc }
+ {
+ empty_contract with
+ guarantees = [ eexpr_add_name eexpr name ];
+ spec_loc = eexpr.eexpr_loc;
+ }
let mk_contract_assume name eexpr =
- { empty_contract with assume = [eexpr_add_name eexpr name]; spec_loc = eexpr.eexpr_loc }
+ {
+ empty_contract with
+ assume = [ eexpr_add_name eexpr name ];
+ spec_loc = eexpr.eexpr_loc;
+ }
let mk_contract_mode id rl el loc =
- { empty_contract with modes = [{ mode_id = id; require = rl; ensure = el; mode_loc = loc; }]; spec_loc = loc }
+ {
+ empty_contract with
+ modes = [ { mode_id = id; require = rl; ensure = el; mode_loc = loc } ];
+ spec_loc = loc;
+ }
let mk_contract_import id ins outs loc =
- { empty_contract with imports = [{import_nodeid = id; inputs = ins; outputs = outs; import_loc = loc; }]; spec_loc = loc }
+ {
+ empty_contract with
+ imports =
+ [ { import_nodeid = id; inputs = ins; outputs = outs; import_loc = loc } ];
+ spec_loc = loc;
+ }
-
-let merge_contracts ann1 ann2 = (* keeping the first item loc *)
- { consts = ann1.consts @ ann2.consts;
+let merge_contracts ann1 ann2 =
+ (* keeping the first item loc *)
+ {
+ consts = ann1.consts @ ann2.consts;
locals = ann1.locals @ ann2.locals;
stmts = ann1.stmts @ ann2.stmts;
assume = ann1.assume @ ann2.assume;
guarantees = ann1.guarantees @ ann2.guarantees;
modes = ann1.modes @ ann2.modes;
imports = ann1.imports @ ann2.imports;
- spec_loc = ann1.spec_loc
+ spec_loc = ann1.spec_loc;
}
let mkeexpr loc expr =
- { eexpr_tag = Utils.new_tag ();
+ {
+ eexpr_tag = Utils.new_tag ();
eexpr_qfexpr = expr;
eexpr_quantifiers = [];
eexpr_name = None;
eexpr_type = Types.new_var ();
eexpr_clock = Clocks.new_var true;
- eexpr_loc = loc }
+ eexpr_loc = loc;
+ }
-let extend_eexpr q e = { e with eexpr_quantifiers = q@e.eexpr_quantifiers }
+let extend_eexpr q e = { e with eexpr_quantifiers = q @ e.eexpr_quantifiers }
-(*
-let mkepredef_call loc funname args =
- mkeexpr loc (EExpr_appl (funname, mkeexpr loc (EExpr_tuple args), None))
+(* let mkepredef_call loc funname args = mkeexpr loc (EExpr_appl (funname,
+ mkeexpr loc (EExpr_tuple args), None))
-let mkepredef_unary_call loc funname arg =
- mkeexpr loc (EExpr_appl (funname, arg, None))
-*)
+ let mkepredef_unary_call loc funname arg = mkeexpr loc (EExpr_appl (funname,
+ arg, None)) *)
let merge_expr_annot ann1 ann2 =
match ann1, ann2 with
- | None, None -> assert false
- | Some _, None -> ann1
- | None, Some _ -> ann2
- | Some ann1, Some ann2 -> Some {
- annots = ann1.annots @ ann2.annots;
- annot_loc = ann1.annot_loc
- }
+ | None, None ->
+ assert false
+ | Some _, None ->
+ ann1
+ | None, Some _ ->
+ ann2
+ | Some ann1, Some ann2 ->
+ Some { annots = ann1.annots @ ann2.annots; annot_loc = ann1.annot_loc }
let update_expr_annot node_id e annot =
- List.iter (fun (key, _) ->
- Annotations.add_expr_ann node_id e.expr_tag key
- ) annot.annots;
+ List.iter
+ (fun (key, _) -> Annotations.add_expr_ann node_id e.expr_tag key)
+ annot.annots;
e.expr_annot <- merge_expr_annot e.expr_annot (Some annot);
e
-
-let mkinstr ?lustre_eq ?(instr_spec=[]) instr_desc = {
- instr_desc;
- (* lustre_expr = lustre_expr; *)
- instr_spec;
- lustre_eq;
-}
+let mkinstr ?lustre_eq ?(instr_spec = []) instr_desc =
+ { instr_desc; (* lustre_expr = lustre_expr; *)
+ instr_spec; lustre_eq }
let get_instr_desc i = i.instr_desc
+
let update_instr_desc i id = { i with instr_desc = id }
(***********************************************************)
(* Fast access to nodes, by name *)
let (node_table : (ident, top_decl) Hashtbl.t) = Hashtbl.create 30
+
let consts_table = Hashtbl.create 30
let print_node_table fmt () =
- begin
- Format.fprintf fmt "{ /* node table */@.";
- Hashtbl.iter (fun id nd ->
- Format.fprintf fmt "%s |-> %a"
- id
- Printers.pp_short_decl nd
- ) node_table;
- Format.fprintf fmt "}@."
- end
+ Format.fprintf fmt "{ /* node table */@.";
+ Hashtbl.iter
+ (fun id nd -> Format.fprintf fmt "%s |-> %a" id Printers.pp_short_decl nd)
+ node_table;
+ Format.fprintf fmt "}@."
let print_consts_table fmt () =
- begin
- Format.fprintf fmt "{ /* consts table */@.";
- Hashtbl.iter (fun id const ->
- Format.fprintf fmt "%s |-> %a"
- id
- Printers.pp_const_decl (const_of_top const)
- ) consts_table;
- Format.fprintf fmt "}@."
- end
+ Format.fprintf fmt "{ /* consts table */@.";
+ Hashtbl.iter
+ (fun id const ->
+ Format.fprintf fmt "%s |-> %a" id Printers.pp_const_decl
+ (const_of_top const))
+ consts_table;
+ Format.fprintf fmt "}@."
let node_name td =
- match td.top_decl_desc with
- | Node nd -> nd.node_id
- | ImportedNode nd -> nd.nodei_id
- | _ -> assert false
+ match td.top_decl_desc with
+ | Node nd ->
+ nd.node_id
+ | ImportedNode nd ->
+ nd.nodei_id
+ | _ ->
+ assert false
let is_generic_node td =
- match td.top_decl_desc with
- | Node nd -> List.exists (fun v -> v.var_dec_const) nd.node_inputs
- | ImportedNode nd -> List.exists (fun v -> v.var_dec_const) nd.nodei_inputs
- | _ -> assert false
+ match td.top_decl_desc with
+ | Node nd ->
+ List.exists (fun v -> v.var_dec_const) nd.node_inputs
+ | ImportedNode nd ->
+ List.exists (fun v -> v.var_dec_const) nd.nodei_inputs
+ | _ ->
+ assert false
let node_inputs td =
- match td.top_decl_desc with
- | Node nd -> nd.node_inputs
- | ImportedNode nd -> nd.nodei_inputs
- | _ -> assert false
+ match td.top_decl_desc with
+ | Node nd ->
+ nd.node_inputs
+ | ImportedNode nd ->
+ nd.nodei_inputs
+ | _ ->
+ assert false
+
+let node_from_name id = Hashtbl.find node_table id
-let node_from_name id =
- Hashtbl.find node_table id
-
-let update_node id top =
- Hashtbl.replace node_table id top
+let update_node id top = Hashtbl.replace node_table id top
let is_imported_node td =
- match td.top_decl_desc with
- | Node _ -> false
- | ImportedNode _ -> true
- | _ -> assert false
+ match td.top_decl_desc with
+ | Node _ ->
+ false
+ | ImportedNode _ ->
+ true
+ | _ ->
+ assert false
let is_node_contract nd =
- match nd.node_spec with
- | Some (Contract _) -> true
- | _ -> false
-
+ match nd.node_spec with Some (Contract _) -> true | _ -> false
+
let get_node_contract nd =
- match nd.node_spec with
- | Some (Contract c) -> c
- | _ -> assert false
-
+ match nd.node_spec with Some (Contract c) -> c | _ -> assert false
+
let is_contract td =
- match td.top_decl_desc with
- | Node nd -> is_node_contract nd
- | _ -> false
+ match td.top_decl_desc with Node nd -> is_node_contract nd | _ -> false
(* alias and type definition table *)
let mktop = mktop_decl Location.dummy_loc !Options.dest_dir false
-let top_int_type = mktop (TypeDef {tydef_id = "int"; tydef_desc = Tydec_int})
-let top_bool_type = mktop (TypeDef {tydef_id = "bool"; tydef_desc = Tydec_bool})
-(* let top_float_type = mktop (TypeDef {tydef_id = "float"; tydef_desc = Tydec_float}) *)
-let top_real_type = mktop (TypeDef {tydef_id = "real"; tydef_desc = Tydec_real})
+let top_int_type = mktop (TypeDef { tydef_id = "int"; tydef_desc = Tydec_int })
+
+let top_bool_type =
+ mktop (TypeDef { tydef_id = "bool"; tydef_desc = Tydec_bool })
+
+(* let top_float_type = mktop (TypeDef {tydef_id = "float"; tydef_desc =
+ Tydec_float}) *)
+let top_real_type =
+ mktop (TypeDef { tydef_id = "real"; tydef_desc = Tydec_real })
let type_table =
- Utils.create_hashtable 20 [
- Tydec_int , top_int_type;
- Tydec_bool , top_bool_type;
- (* Tydec_float, top_float_type; *)
- Tydec_real , top_real_type
- ]
+ Utils.create_hashtable 20
+ [
+ Tydec_int, top_int_type;
+ Tydec_bool, top_bool_type;
+ (* Tydec_float, top_float_type; *)
+ Tydec_real, top_real_type;
+ ]
let print_type_table fmt () =
- begin
- Format.fprintf fmt "{ /* type table */@.";
- Hashtbl.iter (fun tydec tdef ->
- Format.fprintf fmt "%a |-> %a"
- Printers.pp_var_type_dec_desc tydec
- Printers.pp_typedef (typedef_of_top tdef)
- ) type_table;
- Format.fprintf fmt "}@."
- end
+ Format.fprintf fmt "{ /* type table */@.";
+ Hashtbl.iter
+ (fun tydec tdef ->
+ Format.fprintf fmt "%a |-> %a" Printers.pp_var_type_dec_desc tydec
+ Printers.pp_typedef (typedef_of_top tdef))
+ type_table;
+ Format.fprintf fmt "}@."
let rec is_user_type typ =
match typ with
- | Tydec_int | Tydec_bool | Tydec_real
- (* | Tydec_float *) | Tydec_any | Tydec_const _ -> false
- | Tydec_clock typ' -> is_user_type typ'
- | _ -> true
+ | Tydec_int
+ | Tydec_bool
+ | Tydec_real (* | Tydec_float *)
+ | Tydec_any
+ | Tydec_const _ ->
+ false
+ | Tydec_clock typ' ->
+ is_user_type typ'
+ | _ ->
+ true
let get_repr_type typ =
let typ_def = (typedef_of_top (Hashtbl.find type_table typ)).tydef_desc in
@@ -380,628 +422,754 @@ let get_repr_type typ =
let rec coretype_equal ty1 ty2 =
let res =
- match ty1, ty2 with
- | Tydec_any , _
- | _ , Tydec_any -> assert false
- | Tydec_const _ , Tydec_const _ -> get_repr_type ty1 = get_repr_type ty2
- | Tydec_const _ , _ -> let ty1' = (typedef_of_top (Hashtbl.find type_table ty1)).tydef_desc
- in (not (is_user_type ty1')) && coretype_equal ty1' ty2
- | _ , Tydec_const _ -> coretype_equal ty2 ty1
- | Tydec_int , Tydec_int
- | Tydec_real , Tydec_real
- (* | Tydec_float , Tydec_float *)
- | Tydec_bool , Tydec_bool -> true
- | Tydec_clock ty1 , Tydec_clock ty2 -> coretype_equal ty1 ty2
- | Tydec_array (d1,ty1), Tydec_array (d2, ty2) -> Dimension.is_eq_dimension d1 d2 && coretype_equal ty1 ty2
- | Tydec_enum tl1 , Tydec_enum tl2 -> List.sort compare tl1 = List.sort compare tl2
- | Tydec_struct fl1 , Tydec_struct fl2 ->
- List.length fl1 = List.length fl2
- && List.for_all2 (fun (f1, t1) (f2, t2) -> f1 = f2 && coretype_equal t1 t2)
- (List.sort (fun (f1,_) (f2,_) -> compare f1 f2) fl1)
- (List.sort (fun (f1,_) (f2,_) -> compare f1 f2) fl2)
- | _ -> false
- in ((*Format.eprintf "coretype_equal %a %a = %B@." Printers.pp_var_type_dec_desc ty1 Printers.pp_var_type_dec_desc ty2 res;*) res)
+ match ty1, ty2 with
+ | Tydec_any, _ | _, Tydec_any ->
+ assert false
+ | Tydec_const _, Tydec_const _ ->
+ get_repr_type ty1 = get_repr_type ty2
+ | Tydec_const _, _ ->
+ let ty1' = (typedef_of_top (Hashtbl.find type_table ty1)).tydef_desc in
+ (not (is_user_type ty1')) && coretype_equal ty1' ty2
+ | _, Tydec_const _ ->
+ coretype_equal ty2 ty1
+ | Tydec_int, Tydec_int
+ | Tydec_real, Tydec_real
+ (* | Tydec_float , Tydec_float *)
+ | Tydec_bool, Tydec_bool ->
+ true
+ | Tydec_clock ty1, Tydec_clock ty2 ->
+ coretype_equal ty1 ty2
+ | Tydec_array (d1, ty1), Tydec_array (d2, ty2) ->
+ Dimension.is_eq_dimension d1 d2 && coretype_equal ty1 ty2
+ | Tydec_enum tl1, Tydec_enum tl2 ->
+ List.sort compare tl1 = List.sort compare tl2
+ | Tydec_struct fl1, Tydec_struct fl2 ->
+ List.length fl1 = List.length fl2
+ && List.for_all2
+ (fun (f1, t1) (f2, t2) -> f1 = f2 && coretype_equal t1 t2)
+ (List.sort (fun (f1, _) (f2, _) -> compare f1 f2) fl1)
+ (List.sort (fun (f1, _) (f2, _) -> compare f1 f2) fl2)
+ | _ ->
+ false
+ in
+ (*Format.eprintf "coretype_equal %a %a = %B@." Printers.pp_var_type_dec_desc
+ ty1 Printers.pp_var_type_dec_desc ty2 res;*)
+ res
let tag_default = "default"
let const_is_bool c =
- match c with
- | Const_tag t -> t = tag_true || t = tag_false
- | _ -> false
+ match c with Const_tag t -> t = tag_true || t = tag_false | _ -> false
(* Computes the negation of a boolean constant *)
let const_negation c =
assert (const_is_bool c);
match c with
- | Const_tag t when t = tag_true -> Const_tag tag_false
- | _ -> Const_tag tag_true
+ | Const_tag t when t = tag_true ->
+ Const_tag tag_false
+ | _ ->
+ Const_tag tag_true
let const_or c1 c2 =
assert (const_is_bool c1 && const_is_bool c2);
match c1, c2 with
- | Const_tag t1, _ when t1 = tag_true -> c1
- | _ , Const_tag t2 when t2 = tag_true -> c2
- | _ -> Const_tag tag_false
+ | Const_tag t1, _ when t1 = tag_true ->
+ c1
+ | _, Const_tag t2 when t2 = tag_true ->
+ c2
+ | _ ->
+ Const_tag tag_false
let const_and c1 c2 =
assert (const_is_bool c1 && const_is_bool c2);
match c1, c2 with
- | Const_tag t1, _ when t1 = tag_false -> c1
- | _ , Const_tag t2 when t2 = tag_false -> c2
- | _ -> Const_tag tag_true
+ | Const_tag t1, _ when t1 = tag_false ->
+ c1
+ | _, Const_tag t2 when t2 = tag_false ->
+ c2
+ | _ ->
+ Const_tag tag_true
let const_xor c1 c2 =
assert (const_is_bool c1 && const_is_bool c2);
- match c1, c2 with
- | Const_tag t1, Const_tag t2 when t1 <> t2 -> Const_tag tag_true
- | _ -> Const_tag tag_false
+ match c1, c2 with
+ | Const_tag t1, Const_tag t2 when t1 <> t2 ->
+ Const_tag tag_true
+ | _ ->
+ Const_tag tag_false
let const_impl c1 c2 =
assert (const_is_bool c1 && const_is_bool c2);
match c1, c2 with
- | Const_tag t1, _ when t1 = tag_false -> Const_tag tag_true
- | _ , Const_tag t2 when t2 = tag_true -> Const_tag tag_true
- | _ -> Const_tag tag_false
+ | Const_tag t1, _ when t1 = tag_false ->
+ Const_tag tag_true
+ | _, Const_tag t2 when t2 = tag_true ->
+ Const_tag tag_true
+ | _ ->
+ Const_tag tag_false
(* To guarantee uniqueness of tags in enum types *)
let tag_table =
- Utils.create_hashtable 20 [
- tag_true, top_bool_type;
- tag_false, top_bool_type
- ]
+ Utils.create_hashtable 20
+ [ tag_true, top_bool_type; tag_false, top_bool_type ]
(* To guarantee uniqueness of fields in struct types *)
-let field_table =
- Utils.create_hashtable 20 [
- ]
+let field_table = Utils.create_hashtable 20 []
let get_enum_type_tags cty =
-(*Format.eprintf "get_enum_type_tags %a@." Printers.pp_var_type_dec_desc cty;*)
- match cty with
- | Tydec_bool -> [tag_true; tag_false]
- | Tydec_const _ -> (match (typedef_of_top (Hashtbl.find type_table cty)).tydef_desc with
- | Tydec_enum tl -> tl
- | _ -> assert false)
- | _ -> assert false
+ (*Format.eprintf "get_enum_type_tags %a@." Printers.pp_var_type_dec_desc cty;*)
+ match cty with
+ | Tydec_bool ->
+ [ tag_true; tag_false ]
+ | Tydec_const _ -> (
+ match (typedef_of_top (Hashtbl.find type_table cty)).tydef_desc with
+ | Tydec_enum tl ->
+ tl
+ | _ ->
+ assert false)
+ | _ ->
+ assert false
let get_struct_type_fields cty =
- match cty with
- | Tydec_const _ -> (match (typedef_of_top (Hashtbl.find type_table cty)).tydef_desc with
- | Tydec_struct fl -> fl
- | _ -> assert false)
- | _ -> assert false
+ match cty with
+ | Tydec_const _ -> (
+ match (typedef_of_top (Hashtbl.find type_table cty)).tydef_desc with
+ | Tydec_struct fl ->
+ fl
+ | _ ->
+ assert false)
+ | _ ->
+ assert false
-let const_of_bool b =
- Const_tag (if b then tag_true else tag_false)
+let const_of_bool b = Const_tag (if b then tag_true else tag_false)
(* let get_const c = snd (Hashtbl.find consts_table c) *)
let ident_of_expr expr =
- match expr.expr_desc with
- | Expr_ident id -> id
- | _ -> assert false
+ match expr.expr_desc with Expr_ident id -> id | _ -> assert false
(* Generate a new ident expression from a declared variable *)
let expr_of_vdecl v =
- { expr_tag = Utils.new_tag ();
+ {
+ expr_tag = Utils.new_tag ();
expr_desc = Expr_ident v.var_id;
expr_type = v.var_type;
expr_clock = v.var_clock;
expr_delay = Delay.new_var ();
expr_annot = None;
- expr_loc = v.var_loc }
+ expr_loc = v.var_loc;
+ }
(* Caution, returns an untyped and unclocked expression *)
let expr_of_ident id loc =
- {expr_tag = Utils.new_tag ();
- expr_desc = Expr_ident id;
- expr_type = Types.new_var ();
- expr_clock = Clocks.new_var true;
- expr_delay = Delay.new_var ();
- expr_loc = loc;
- expr_annot = None}
+ {
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_ident id;
+ expr_type = Types.new_var ();
+ expr_clock = Clocks.new_var true;
+ expr_delay = Delay.new_var ();
+ expr_loc = loc;
+ expr_annot = None;
+ }
let is_tuple_expr expr =
- match expr.expr_desc with
- | Expr_tuple _ -> true
- | _ -> false
+ match expr.expr_desc with Expr_tuple _ -> true | _ -> false
let expr_list_of_expr expr =
- match expr.expr_desc with
- | Expr_tuple elist -> elist
- | _ -> [expr]
+ match expr.expr_desc with Expr_tuple elist -> elist | _ -> [ expr ]
let expr_of_expr_list loc elist =
- match elist with
- | [t] -> { t with expr_loc = loc }
- | t::_ ->
+ match elist with
+ | [ t ] ->
+ { t with expr_loc = loc }
+ | t :: _ ->
let tlist = List.map (fun e -> e.expr_type) elist in
let clist = List.map (fun e -> e.expr_clock) elist in
- { t with expr_desc = Expr_tuple elist;
- expr_type = Type_predef.type_tuple tlist;
- expr_clock = Clock_predef.ck_tuple clist;
- expr_tag = Utils.new_tag ();
- expr_loc = loc }
- | _ -> assert false
+ {
+ t with
+ expr_desc = Expr_tuple elist;
+ expr_type = Type_predef.type_tuple tlist;
+ expr_clock = Clock_predef.ck_tuple clist;
+ expr_tag = Utils.new_tag ();
+ expr_loc = loc;
+ }
+ | _ ->
+ assert false
let call_of_expr expr =
- match expr.expr_desc with
- | Expr_appl (f, args, r) -> (f, expr_list_of_expr args, r)
- | _ -> assert false
+ match expr.expr_desc with
+ | Expr_appl (f, args, r) ->
+ f, expr_list_of_expr args, r
+ | _ ->
+ assert false
-
-(* Conversion from dimension expr to standard expr, for the purpose of printing, typing, etc... *)
+(* Conversion from dimension expr to standard expr, for the purpose of printing,
+ typing, etc... *)
let rec expr_of_dimension dim =
let open Dimension in
let expr =
- match dim.dim_desc with
- | Dbool b ->
- mkexpr dim.dim_loc (Expr_const (const_of_bool b))
- | Dint i ->
- mkexpr dim.dim_loc (Expr_const (Const_int i))
- | Dident id ->
- mkexpr dim.dim_loc (Expr_ident id)
- | Dite (c, t, e) ->
- mkexpr dim.dim_loc (Expr_ite (expr_of_dimension c, expr_of_dimension t, expr_of_dimension e))
- | Dappl (id, args) ->
- mkexpr dim.dim_loc (Expr_appl (id, expr_of_expr_list dim.dim_loc (List.map expr_of_dimension args), None))
- | Dlink dim' -> expr_of_dimension dim'
- | Dvar
- | Dunivar -> (Format.eprintf "internal error: Corelang.expr_of_dimension %a@." Dimension.pp_dimension dim;
- assert false)
+ match dim.dim_desc with
+ | Dbool b ->
+ mkexpr dim.dim_loc (Expr_const (const_of_bool b))
+ | Dint i ->
+ mkexpr dim.dim_loc (Expr_const (Const_int i))
+ | Dident id ->
+ mkexpr dim.dim_loc (Expr_ident id)
+ | Dite (c, t, e) ->
+ mkexpr dim.dim_loc
+ (Expr_ite (expr_of_dimension c, expr_of_dimension t, expr_of_dimension e))
+ | Dappl (id, args) ->
+ mkexpr dim.dim_loc
+ (Expr_appl
+ ( id,
+ expr_of_expr_list dim.dim_loc (List.map expr_of_dimension args),
+ None ))
+ | Dlink dim' ->
+ expr_of_dimension dim'
+ | Dvar | Dunivar ->
+ Format.eprintf "internal error: Corelang.expr_of_dimension %a@."
+ Dimension.pp_dimension dim;
+ assert false
in
- { expr
- with
- expr_type = Types.new_ty Types.type_int;
- }
-
+ { expr with expr_type = Types.new_ty Types.type_int }
+
let dimension_of_const loc const =
let open Dimension in
- match const with
- | Const_int i -> mkdim_int loc i
- | Const_tag t when t = tag_true || t = tag_false -> mkdim_bool loc (t = tag_true)
- | _ -> raise InvalidDimension
-
-(* Conversion from standard expr to dimension expr, for the purpose of injecting static call arguments
- into dimension expressions *)
+ match const with
+ | Const_int i ->
+ mkdim_int loc i
+ | Const_tag t when t = tag_true || t = tag_false ->
+ mkdim_bool loc (t = tag_true)
+ | _ ->
+ raise InvalidDimension
+
+(* Conversion from standard expr to dimension expr, for the purpose of injecting
+ static call arguments into dimension expressions *)
let rec dimension_of_expr expr =
let open Dimension in
match expr.expr_desc with
- | Expr_const c -> dimension_of_const expr.expr_loc c
- | Expr_ident id -> mkdim_ident expr.expr_loc id
+ | Expr_const c ->
+ dimension_of_const expr.expr_loc c
+ | Expr_ident id ->
+ mkdim_ident expr.expr_loc id
| Expr_appl (f, args, None) when Basic_library.is_expr_internal_fun expr ->
- let k = Types.get_static_value (Env.lookup_value Basic_library.type_env f) in
- if k = None then raise InvalidDimension;
- mkdim_appl expr.expr_loc f (List.map dimension_of_expr (expr_list_of_expr args))
- | Expr_ite (i, t, e) ->
- mkdim_ite expr.expr_loc (dimension_of_expr i) (dimension_of_expr t) (dimension_of_expr e)
- | _ -> raise InvalidDimension (* not a simple dimension expression *)
-
-
-let sort_handlers hl =
- List.sort (fun (t, _) (t', _) -> compare t t') hl
+ let k =
+ Types.get_static_value (Env.lookup_value Basic_library.type_env f)
+ in
+ if k = None then raise InvalidDimension;
+ mkdim_appl expr.expr_loc f
+ (List.map dimension_of_expr (expr_list_of_expr args))
+ | Expr_ite (i, t, e) ->
+ mkdim_ite expr.expr_loc (dimension_of_expr i) (dimension_of_expr t)
+ (dimension_of_expr e)
+ | _ ->
+ raise InvalidDimension
+(* not a simple dimension expression *)
+
+let sort_handlers hl = List.sort (fun (t, _) (t', _) -> compare t t') hl
-
let rec is_eq_const c1 c2 =
match c1, c2 with
- | Const_real r1, Const_real _
- -> Real.eq r1 r1
- | Const_struct lcl1, Const_struct lcl2
- -> List.length lcl1 = List.length lcl2
- && List.for_all2 (fun (l1, c1) (l2, c2) -> l1 = l2 && is_eq_const c1 c2) lcl1 lcl2
- | _ -> c1 = c2
-
-let rec is_eq_expr e1 e2 = match e1.expr_desc, e2.expr_desc with
- | Expr_const c1, Expr_const c2 -> is_eq_const c1 c2
- | Expr_ident i1, Expr_ident i2 -> i1 = i2
- | Expr_array el1, Expr_array el2
- | Expr_tuple el1, Expr_tuple el2 ->
- List.length el1 = List.length el2 && List.for_all2 is_eq_expr el1 el2
- | Expr_arrow (e1, e2), Expr_arrow (e1', e2') -> is_eq_expr e1 e1' && is_eq_expr e2 e2'
- | Expr_fby (e1,e2), Expr_fby (e1',e2') -> is_eq_expr e1 e1' && is_eq_expr e2 e2'
- | Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) -> is_eq_expr i1 i2 && is_eq_expr t1 t2 && is_eq_expr e1 e2
- (* | Expr_concat (e1,e2), Expr_concat (e1',e2') -> is_eq_expr e1 e1' && is_eq_expr e2 e2' *)
+ | Const_real r1, Const_real _ ->
+ Real.eq r1 r1
+ | Const_struct lcl1, Const_struct lcl2 ->
+ List.length lcl1 = List.length lcl2
+ && List.for_all2
+ (fun (l1, c1) (l2, c2) -> l1 = l2 && is_eq_const c1 c2)
+ lcl1 lcl2
+ | _ ->
+ c1 = c2
+
+let rec is_eq_expr e1 e2 =
+ match e1.expr_desc, e2.expr_desc with
+ | Expr_const c1, Expr_const c2 ->
+ is_eq_const c1 c2
+ | Expr_ident i1, Expr_ident i2 ->
+ i1 = i2
+ | Expr_array el1, Expr_array el2 | Expr_tuple el1, Expr_tuple el2 ->
+ List.length el1 = List.length el2 && List.for_all2 is_eq_expr el1 el2
+ | Expr_arrow (e1, e2), Expr_arrow (e1', e2') ->
+ is_eq_expr e1 e1' && is_eq_expr e2 e2'
+ | Expr_fby (e1, e2), Expr_fby (e1', e2') ->
+ is_eq_expr e1 e1' && is_eq_expr e2 e2'
+ | Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) ->
+ is_eq_expr i1 i2 && is_eq_expr t1 t2 && is_eq_expr e1 e2
+ (* | Expr_concat (e1,e2), Expr_concat (e1',e2') -> is_eq_expr e1 e1' &&
+ is_eq_expr e2 e2' *)
(* | Expr_tail e, Expr_tail e' -> is_eq_expr e e' *)
- | Expr_pre e, Expr_pre e' -> is_eq_expr e e'
- | Expr_when (e, i, l), Expr_when (e', i', l') -> l=l' && i=i' && is_eq_expr e e'
- | Expr_merge(i, hl), Expr_merge(i', hl') -> i=i' && List.for_all2 (fun (t, h) (t', h') -> t=t' && is_eq_expr h h') (sort_handlers hl) (sort_handlers hl')
- | Expr_appl (i, e, r), Expr_appl (i', e', r') -> i=i' && r=r' && is_eq_expr e e'
+ | Expr_pre e, Expr_pre e' ->
+ is_eq_expr e e'
+ | Expr_when (e, i, l), Expr_when (e', i', l') ->
+ l = l' && i = i' && is_eq_expr e e'
+ | Expr_merge (i, hl), Expr_merge (i', hl') ->
+ i = i'
+ && List.for_all2
+ (fun (t, h) (t', h') -> t = t' && is_eq_expr h h')
+ (sort_handlers hl) (sort_handlers hl')
+ | Expr_appl (i, e, r), Expr_appl (i', e', r') ->
+ i = i' && r = r' && is_eq_expr e e'
| Expr_power (e1, i1), Expr_power (e2, i2)
- | Expr_access (e1, i1), Expr_access (e2, i2) -> is_eq_expr e1 e2 && is_eq_expr (expr_of_dimension i1) (expr_of_dimension i2)
- | _ -> false
+ | Expr_access (e1, i1), Expr_access (e2, i2) ->
+ is_eq_expr e1 e2 && is_eq_expr (expr_of_dimension i1) (expr_of_dimension i2)
+ | _ ->
+ false
-let get_node_vars nd =
- nd.node_inputs @ nd.node_locals @ nd.node_outputs
+let get_node_vars nd = nd.node_inputs @ nd.node_locals @ nd.node_outputs
let mk_new_node_name nd id =
let used_vars = get_node_vars nd in
let used v = List.exists (fun vdecl -> vdecl.var_id = v) used_vars in
mk_new_name used id
-let get_var id var_list =
- List.find (fun v -> v.var_id = id) var_list
+let get_var id var_list = List.find (fun v -> v.var_id = id) var_list
let get_node_var id node =
- try
- get_var id (get_node_vars node)
- with Not_found -> begin
- (* Format.eprintf "Unable to find variable %s in node %s@.@?" id node.node_id; *)
+ try get_var id (get_node_vars node)
+ with Not_found ->
+ (* Format.eprintf "Unable to find variable %s in node %s@.@?" id
+ node.node_id; *)
raise Not_found
- end
-
let get_node_eqs =
let get_eqs stmts =
List.fold_right
(fun stmt (res_eq, res_aut) ->
- match stmt with
- | Eq eq -> eq :: res_eq, res_aut
- | Aut aut -> res_eq, aut::res_aut)
- stmts
- ([], []) in
+ match stmt with
+ | Eq eq ->
+ eq :: res_eq, res_aut
+ | Aut aut ->
+ res_eq, aut :: res_aut)
+ stmts ([], [])
+ in
let table_eqs = Hashtbl.create 23 in
- (fun nd ->
+ fun nd ->
try
- let (old, res) = Hashtbl.find table_eqs nd.node_id
- in if old == nd.node_stmts then res else raise Not_found
- with Not_found ->
+ let old, res = Hashtbl.find table_eqs nd.node_id in
+ if old == nd.node_stmts then res else raise Not_found
+ with Not_found ->
let res = get_eqs nd.node_stmts in
- begin
- Hashtbl.replace table_eqs nd.node_id (nd.node_stmts, res);
- res
- end)
+ Hashtbl.replace table_eqs nd.node_id (nd.node_stmts, res);
+ res
let get_node_eq id node =
let eqs, _ = get_node_eqs node in
- try
- List.find (fun eq -> List.mem id eq.eq_lhs) eqs
- with
- Not_found -> (* Shall be defined in automata auts *) raise Not_found
-
-let get_nodes prog =
- List.fold_left (
- fun nodes decl ->
+ try List.find (fun eq -> List.mem id eq.eq_lhs) eqs
+ with Not_found -> (* Shall be defined in automata auts *)
+ raise Not_found
+
+let get_nodes prog =
+ List.fold_left
+ (fun nodes decl ->
match decl.top_decl_desc with
- | Node _ -> decl::nodes
- | Const _ | ImportedNode _ | Include _ | Open _ | TypeDef _ -> nodes
- ) [] prog
+ | Node _ ->
+ decl :: nodes
+ | Const _ | ImportedNode _ | Include _ | Open _ | TypeDef _ ->
+ nodes)
+ [] prog
|> List.rev
-let get_imported_nodes prog =
- List.fold_left (
- fun nodes decl ->
+let get_imported_nodes prog =
+ List.fold_left
+ (fun nodes decl ->
match decl.top_decl_desc with
- | ImportedNode _ -> decl::nodes
- | Const _ | Node _ | Include _ | Open _ | TypeDef _-> nodes
- ) [] prog
-
-let get_consts prog =
- List.fold_right (
- fun decl consts ->
+ | ImportedNode _ ->
+ decl :: nodes
+ | Const _ | Node _ | Include _ | Open _ | TypeDef _ ->
+ nodes)
+ [] prog
+
+let get_consts prog =
+ List.fold_right
+ (fun decl consts ->
match decl.top_decl_desc with
- | Const _ -> decl::consts
- | Node _ | ImportedNode _ | Include _ | Open _ | TypeDef _ -> consts
- ) prog []
-
-let get_typedefs prog =
- List.fold_right (
- fun decl types ->
+ | Const _ ->
+ decl :: consts
+ | Node _ | ImportedNode _ | Include _ | Open _ | TypeDef _ ->
+ consts)
+ prog []
+
+let get_typedefs prog =
+ List.fold_right
+ (fun decl types ->
match decl.top_decl_desc with
- | TypeDef _ -> decl::types
- | Node _ | ImportedNode _ | Include _ | Open _ | Const _ -> types
- ) prog []
+ | TypeDef _ ->
+ decl :: types
+ | Node _ | ImportedNode _ | Include _ | Open _ | Const _ ->
+ types)
+ prog []
let get_dependencies prog =
- List.fold_right (
- fun decl deps ->
+ List.fold_right
+ (fun decl deps ->
match decl.top_decl_desc with
- | Open _ -> decl::deps
- | Node _ | ImportedNode _ | TypeDef _ | Include _ | Const _ -> deps
- ) prog []
+ | Open _ ->
+ decl :: deps
+ | Node _ | ImportedNode _ | TypeDef _ | Include _ | Const _ ->
+ deps)
+ prog []
let get_node_interface nd =
- {nodei_id = nd.node_id;
- nodei_type = nd.node_type;
- nodei_clock = nd.node_clock;
- nodei_inputs = nd.node_inputs;
- nodei_outputs = nd.node_outputs;
- nodei_stateless = nd.node_dec_stateless;
- nodei_spec = nd.node_spec;
- (* nodei_annot = nd.node_annot; *)
- nodei_prototype = None;
- nodei_in_lib = [];
- }
+ {
+ nodei_id = nd.node_id;
+ nodei_type = nd.node_type;
+ nodei_clock = nd.node_clock;
+ nodei_inputs = nd.node_inputs;
+ nodei_outputs = nd.node_outputs;
+ nodei_stateless = nd.node_dec_stateless;
+ nodei_spec = nd.node_spec;
+ (* nodei_annot = nd.node_annot; *)
+ nodei_prototype = None;
+ nodei_in_lib = [];
+ }
(************************************************************************)
-(* Renaming / Copying *)
+(* Renaming / Copying *)
let copy_var_decl vdecl =
- mkvar_decl
- vdecl.var_loc
- ~orig:vdecl.var_orig
- (
- vdecl.var_id,
+ mkvar_decl vdecl.var_loc ~orig:vdecl.var_orig
+ ( vdecl.var_id,
vdecl.var_dec_type,
vdecl.var_dec_clock,
vdecl.var_dec_const,
vdecl.var_dec_value,
- vdecl.var_parent_nodeid
- )
+ vdecl.var_parent_nodeid )
-let copy_const cdecl =
- { cdecl with const_type = Types.new_var () }
+let copy_const cdecl = { cdecl with const_type = Types.new_var () }
let copy_node nd =
- { nd with
- node_type = Types.new_var ();
- node_clock = Clocks.new_var true;
- node_inputs = List.map copy_var_decl nd.node_inputs;
- node_outputs = List.map copy_var_decl nd.node_outputs;
- node_locals = List.map copy_var_decl nd.node_locals;
+ {
+ nd with
+ node_type = Types.new_var ();
+ node_clock = Clocks.new_var true;
+ node_inputs = List.map copy_var_decl nd.node_inputs;
+ node_outputs = List.map copy_var_decl nd.node_outputs;
+ node_locals = List.map copy_var_decl nd.node_locals;
node_gencalls = [];
- node_checks = [];
+ node_checks = [];
node_stateless = None;
}
let copy_top top =
match top.top_decl_desc with
- | Node nd -> { top with top_decl_desc = Node (copy_node nd) }
- | Const c -> { top with top_decl_desc = Const (copy_const c) }
- | _ -> top
+ | Node nd ->
+ { top with top_decl_desc = Node (copy_node nd) }
+ | Const c ->
+ { top with top_decl_desc = Const (copy_const c) }
+ | _ ->
+ top
-let copy_prog top_list =
- List.map copy_top top_list
+let copy_prog top_list = List.map copy_top top_list
-
let rec rename_static rename cty =
- match cty with
- | Tydec_array (d, cty') -> Tydec_array (Dimension.expr_replace_expr rename d, rename_static rename cty')
- | Tydec_clock cty -> Tydec_clock (rename_static rename cty)
- | Tydec_struct fl -> Tydec_struct (List.map (fun (f, cty) -> f, rename_static rename cty) fl)
- | _ -> cty
+ match cty with
+ | Tydec_array (d, cty') ->
+ Tydec_array (Dimension.expr_replace_expr rename d, rename_static rename cty')
+ | Tydec_clock cty ->
+ Tydec_clock (rename_static rename cty)
+ | Tydec_struct fl ->
+ Tydec_struct (List.map (fun (f, cty) -> f, rename_static rename cty) fl)
+ | _ ->
+ cty
let rename_carrier rename cck =
- match cck with
- | Ckdec_bool cl -> Ckdec_bool (List.map (fun (c, l) -> rename c, l) cl)
- | _ -> cck
+ match cck with
+ | Ckdec_bool cl ->
+ Ckdec_bool (List.map (fun (c, l) -> rename c, l) cl)
+ | _ ->
+ cck
- (*Format.eprintf "Types.rename_static %a = %a@." print_ty ty print_ty res; res*)
+(*Format.eprintf "Types.rename_static %a = %a@." print_ty ty print_ty res; res*)
(* applies the renaming function [fvar] to all variables of expression [expr] *)
- (* let rec expr_replace_var fvar expr = *)
- (* { expr with expr_desc = expr_desc_replace_var fvar expr.expr_desc } *)
-
- (* and expr_desc_replace_var fvar expr_desc = *)
- (* match expr_desc with *)
- (* | Expr_const _ -> expr_desc *)
- (* | Expr_ident i -> Expr_ident (fvar i) *)
- (* | Expr_array el -> Expr_array (List.map (expr_replace_var fvar) el) *)
- (* | Expr_access (e1, d) -> Expr_access (expr_replace_var fvar e1, d) *)
- (* | Expr_power (e1, d) -> Expr_power (expr_replace_var fvar e1, d) *)
- (* | Expr_tuple el -> Expr_tuple (List.map (expr_replace_var fvar) el) *)
- (* | Expr_ite (c, t, e) -> Expr_ite (expr_replace_var fvar c, expr_replace_var fvar t, expr_replace_var fvar e) *)
- (* | Expr_arrow (e1, e2)-> Expr_arrow (expr_replace_var fvar e1, expr_replace_var fvar e2) *)
- (* | Expr_fby (e1, e2) -> Expr_fby (expr_replace_var fvar e1, expr_replace_var fvar e2) *)
- (* | Expr_pre e' -> Expr_pre (expr_replace_var fvar e') *)
- (* | Expr_when (e', i, l)-> Expr_when (expr_replace_var fvar e', fvar i, l) *)
- (* | Expr_merge (i, hl) -> Expr_merge (fvar i, List.map (fun (t, h) -> (t, expr_replace_var fvar h)) hl) *)
- (* | Expr_appl (i, e', i') -> Expr_appl (i, expr_replace_var fvar e', Utils.option_map (expr_replace_var fvar) i') *)
-
-
-
- let rec rename_expr f_node f_var expr =
- { expr with expr_desc = rename_expr_desc f_node f_var expr.expr_desc }
- and rename_expr_desc f_node f_var expr_desc =
- let re = rename_expr f_node f_var in
- match expr_desc with
- | Expr_const _ -> expr_desc
- | Expr_ident i -> Expr_ident (f_var i)
- | Expr_array el -> Expr_array (List.map re el)
- | Expr_access (e1, d) -> Expr_access (re e1, d)
- | Expr_power (e1, d) -> Expr_power (re e1, d)
- | Expr_tuple el -> Expr_tuple (List.map re el)
- | Expr_ite (c, t, e) -> Expr_ite (re c, re t, re e)
- | Expr_arrow (e1, e2)-> Expr_arrow (re e1, re e2)
- | Expr_fby (e1, e2) -> Expr_fby (re e1, re e2)
- | Expr_pre e' -> Expr_pre (re e')
- | Expr_when (e', i, l)-> Expr_when (re e', f_var i, l)
- | Expr_merge (i, hl) ->
- Expr_merge (f_var i, List.map (fun (t, h) -> (t, re h)) hl)
- | Expr_appl (i, e', i') ->
- Expr_appl (f_node i, re e', Utils.option_map re i')
-
- let rename_var f_var v = {
- (copy_var_decl v) with
- var_id = f_var v.var_id;
- var_type = v.var_type;
- var_clock = v.var_clock;
- }
-
- let rename_vars f_var = List.map (rename_var f_var)
-
- let rec rename_eq f_node f_var eq = { eq with
- eq_lhs = List.map f_var eq.eq_lhs;
- eq_rhs = rename_expr f_node f_var eq.eq_rhs
- }
- and rename_handler f_node f_var h = {h with
- hand_state = f_var h.hand_state;
- hand_unless = List.map (
- fun (l,e,b,id) -> l, rename_expr f_node f_var e, b, f_var id
- ) h.hand_unless;
- hand_until = List.map (
- fun (l,e,b,id) -> l, rename_expr f_node f_var e, b, f_var id
- ) h.hand_until;
- hand_locals = rename_vars f_var h.hand_locals;
- hand_stmts = rename_stmts f_node f_var h.hand_stmts;
- hand_annots = rename_annots f_node f_var h.hand_annots;
-
- }
- and rename_aut f_node f_var aut = { aut with
- aut_id = f_var aut.aut_id;
- aut_handlers = List.map (rename_handler f_node f_var) aut.aut_handlers;
- }
- and rename_stmts f_node f_var stmts = List.map (fun stmt -> match stmt with
- | Eq eq -> Eq (rename_eq f_node f_var eq)
- | Aut at -> Aut (rename_aut f_node f_var at))
- stmts
- and rename_annotl f_node f_var annots =
- List.map
- (fun (key, value) -> key, rename_eexpr f_node f_var value)
- annots
- and rename_annot f_node f_var annot =
- { annot with annots = rename_annotl f_node f_var annot.annots }
- and rename_annots f_node f_var annots =
- List.map (rename_annot f_node f_var) annots
+(* let rec expr_replace_var fvar expr = *)
+(* { expr with expr_desc = expr_desc_replace_var fvar expr.expr_desc } *)
+
+(* and expr_desc_replace_var fvar expr_desc = *)
+(* match expr_desc with *)
+(* | Expr_const _ -> expr_desc *)
+(* | Expr_ident i -> Expr_ident (fvar i) *)
+(* | Expr_array el -> Expr_array (List.map (expr_replace_var fvar) el) *)
+(* | Expr_access (e1, d) -> Expr_access (expr_replace_var fvar e1, d) *)
+(* | Expr_power (e1, d) -> Expr_power (expr_replace_var fvar e1, d) *)
+(* | Expr_tuple el -> Expr_tuple (List.map (expr_replace_var fvar) el) *)
+(* | Expr_ite (c, t, e) -> Expr_ite (expr_replace_var fvar c, expr_replace_var
+ fvar t, expr_replace_var fvar e) *)
+(* | Expr_arrow (e1, e2)-> Expr_arrow (expr_replace_var fvar e1,
+ expr_replace_var fvar e2) *)
+(* | Expr_fby (e1, e2) -> Expr_fby (expr_replace_var fvar e1, expr_replace_var
+ fvar e2) *)
+(* | Expr_pre e' -> Expr_pre (expr_replace_var fvar e') *)
+(* | Expr_when (e', i, l)-> Expr_when (expr_replace_var fvar e', fvar i, l) *)
+(* | Expr_merge (i, hl) -> Expr_merge (fvar i, List.map (fun (t, h) -> (t,
+ expr_replace_var fvar h)) hl) *)
+(* | Expr_appl (i, e', i') -> Expr_appl (i, expr_replace_var fvar e',
+ Utils.option_map (expr_replace_var fvar) i') *)
+
+let rec rename_expr f_node f_var expr =
+ { expr with expr_desc = rename_expr_desc f_node f_var expr.expr_desc }
+
+and rename_expr_desc f_node f_var expr_desc =
+ let re = rename_expr f_node f_var in
+ match expr_desc with
+ | Expr_const _ ->
+ expr_desc
+ | Expr_ident i ->
+ Expr_ident (f_var i)
+ | Expr_array el ->
+ Expr_array (List.map re el)
+ | Expr_access (e1, d) ->
+ Expr_access (re e1, d)
+ | Expr_power (e1, d) ->
+ Expr_power (re e1, d)
+ | Expr_tuple el ->
+ Expr_tuple (List.map re el)
+ | Expr_ite (c, t, e) ->
+ Expr_ite (re c, re t, re e)
+ | Expr_arrow (e1, e2) ->
+ Expr_arrow (re e1, re e2)
+ | Expr_fby (e1, e2) ->
+ Expr_fby (re e1, re e2)
+ | Expr_pre e' ->
+ Expr_pre (re e')
+ | Expr_when (e', i, l) ->
+ Expr_when (re e', f_var i, l)
+ | Expr_merge (i, hl) ->
+ Expr_merge (f_var i, List.map (fun (t, h) -> t, re h) hl)
+ | Expr_appl (i, e', i') ->
+ Expr_appl (f_node i, re e', Utils.option_map re i')
+
+let rename_var f_var v =
+ {
+ (copy_var_decl v) with
+ var_id = f_var v.var_id;
+ var_type = v.var_type;
+ var_clock = v.var_clock;
+ }
+
+let rename_vars f_var = List.map (rename_var f_var)
+
+let rec rename_eq f_node f_var eq =
+ {
+ eq with
+ eq_lhs = List.map f_var eq.eq_lhs;
+ eq_rhs = rename_expr f_node f_var eq.eq_rhs;
+ }
+
+and rename_handler f_node f_var h =
+ {
+ h with
+ hand_state = f_var h.hand_state;
+ hand_unless =
+ List.map
+ (fun (l, e, b, id) -> l, rename_expr f_node f_var e, b, f_var id)
+ h.hand_unless;
+ hand_until =
+ List.map
+ (fun (l, e, b, id) -> l, rename_expr f_node f_var e, b, f_var id)
+ h.hand_until;
+ hand_locals = rename_vars f_var h.hand_locals;
+ hand_stmts = rename_stmts f_node f_var h.hand_stmts;
+ hand_annots = rename_annots f_node f_var h.hand_annots;
+ }
+
+and rename_aut f_node f_var aut =
+ {
+ aut with
+ aut_id = f_var aut.aut_id;
+ aut_handlers = List.map (rename_handler f_node f_var) aut.aut_handlers;
+ }
+
+and rename_stmts f_node f_var stmts =
+ List.map
+ (fun stmt ->
+ match stmt with
+ | Eq eq ->
+ Eq (rename_eq f_node f_var eq)
+ | Aut at ->
+ Aut (rename_aut f_node f_var at))
+ stmts
+
+and rename_annotl f_node f_var annots =
+ List.map (fun (key, value) -> key, rename_eexpr f_node f_var value) annots
+
+and rename_annot f_node f_var annot =
+ { annot with annots = rename_annotl f_node f_var annot.annots }
+
+and rename_annots f_node f_var annots =
+ List.map (rename_annot f_node f_var) annots
+
and rename_eexpr f_node f_var ee =
- { ee with
- eexpr_tag = Utils.new_tag ();
- eexpr_qfexpr = rename_expr f_node f_var ee.eexpr_qfexpr;
- eexpr_quantifiers = List.map (fun (typ,vdecls) -> typ, rename_vars f_var vdecls) ee.eexpr_quantifiers;
- }
+ {
+ ee with
+ eexpr_tag = Utils.new_tag ();
+ eexpr_qfexpr = rename_expr f_node f_var ee.eexpr_qfexpr;
+ eexpr_quantifiers =
+ List.map
+ (fun (typ, vdecls) -> typ, rename_vars f_var vdecls)
+ ee.eexpr_quantifiers;
+ }
+
and rename_mode f_node f_var m =
let rename_ee = rename_eexpr f_node f_var in
{
m with
require = List.map rename_ee m.require;
- ensure = List.map rename_ee m.ensure
+ ensure = List.map rename_ee m.ensure;
+ }
+
+let rename_import f_node f_var imp =
+ let rename_expr = rename_expr f_node f_var in
+ {
+ imp with
+ import_nodeid = f_node imp.import_nodeid;
+ inputs = rename_expr imp.inputs;
+ outputs = rename_expr imp.outputs;
}
-
- let rename_import f_node f_var imp =
- let rename_expr = rename_expr f_node f_var in
- {
- imp with
- import_nodeid = f_node imp.import_nodeid;
- inputs = rename_expr imp.inputs;
- outputs = rename_expr imp.outputs;
- }
-
- let rename_node f_node f_var nd =
- let f_var x = (* checking that this is actually a local variable *)
- if List.exists (fun v -> v.var_id = x) (get_node_vars nd) then
- f_var x
- else
- x
- in
- let rename_var = rename_var f_var in
- let rename_vars = List.map rename_var in
- let rename_expr = rename_expr f_node f_var in
- let rename_eexpr = rename_eexpr f_node f_var in
- let rename_stmts = rename_stmts f_node f_var in
- let inputs = rename_vars nd.node_inputs in
- let outputs = rename_vars nd.node_outputs in
- let locals = rename_vars nd.node_locals in
- let gen_calls = List.map rename_expr nd.node_gencalls in
- let node_checks = List.map (Dimension.rename f_node f_var) nd.node_checks in
- let node_asserts = List.map
- (fun a ->
- {a with assert_expr =
- let expr = a.assert_expr in
- rename_expr expr})
- nd.node_asserts
- in
- let node_stmts = rename_stmts nd.node_stmts
-
-
- in
- let spec =
- Utils.option_map
- (fun s -> match s with
- NodeSpec id -> NodeSpec (f_node id)
- | Contract c -> Contract {
- c with
- consts = rename_vars c.consts;
- locals = rename_vars c.locals;
- stmts = rename_stmts c.stmts;
- assume = List.map rename_eexpr c.assume;
- guarantees = List.map rename_eexpr c.guarantees;
- modes = List.map (rename_mode f_node f_var) c.modes;
- imports = List.map (rename_import f_node f_var) c.imports;
- }
- )
- nd.node_spec
- in
- let annot = rename_annots f_node f_var nd.node_annot in
- {
- node_id = f_node nd.node_id;
- node_type = nd.node_type;
- node_clock = nd.node_clock;
- node_inputs = inputs;
- node_outputs = outputs;
- node_locals = locals;
- node_gencalls = gen_calls;
- node_checks = node_checks;
- node_asserts = node_asserts;
- node_stmts = node_stmts;
- node_dec_stateless = nd.node_dec_stateless;
- node_stateless = nd.node_stateless;
- node_spec = spec;
- node_annot = annot;
- node_iscontract = nd.node_iscontract;
- }
-
-
-let rename_const f_const c =
- { c with const_id = f_const c.const_id }
+
+let rename_node f_node f_var nd =
+ let f_var x =
+ (* checking that this is actually a local variable *)
+ if List.exists (fun v -> v.var_id = x) (get_node_vars nd) then f_var x
+ else x
+ in
+ let rename_var = rename_var f_var in
+ let rename_vars = List.map rename_var in
+ let rename_expr = rename_expr f_node f_var in
+ let rename_eexpr = rename_eexpr f_node f_var in
+ let rename_stmts = rename_stmts f_node f_var in
+ let inputs = rename_vars nd.node_inputs in
+ let outputs = rename_vars nd.node_outputs in
+ let locals = rename_vars nd.node_locals in
+ let gen_calls = List.map rename_expr nd.node_gencalls in
+ let node_checks = List.map (Dimension.rename f_node f_var) nd.node_checks in
+ let node_asserts =
+ List.map
+ (fun a ->
+ {
+ a with
+ assert_expr =
+ (let expr = a.assert_expr in
+ rename_expr expr);
+ })
+ nd.node_asserts
+ in
+ let node_stmts = rename_stmts nd.node_stmts in
+
+ let spec =
+ Utils.option_map
+ (fun s ->
+ match s with
+ | NodeSpec id ->
+ NodeSpec (f_node id)
+ | Contract c ->
+ Contract
+ {
+ c with
+ consts = rename_vars c.consts;
+ locals = rename_vars c.locals;
+ stmts = rename_stmts c.stmts;
+ assume = List.map rename_eexpr c.assume;
+ guarantees = List.map rename_eexpr c.guarantees;
+ modes = List.map (rename_mode f_node f_var) c.modes;
+ imports = List.map (rename_import f_node f_var) c.imports;
+ })
+ nd.node_spec
+ in
+ let annot = rename_annots f_node f_var nd.node_annot in
+ {
+ node_id = f_node nd.node_id;
+ node_type = nd.node_type;
+ node_clock = nd.node_clock;
+ node_inputs = inputs;
+ node_outputs = outputs;
+ node_locals = locals;
+ node_gencalls = gen_calls;
+ node_checks;
+ node_asserts;
+ node_stmts;
+ node_dec_stateless = nd.node_dec_stateless;
+ node_stateless = nd.node_stateless;
+ node_spec = spec;
+ node_annot = annot;
+ node_iscontract = nd.node_iscontract;
+ }
+
+let rename_const f_const c = { c with const_id = f_const c.const_id }
let rename_typedef f_var t =
match t.tydef_desc with
- | Tydec_enum tags -> { t with tydef_desc = Tydec_enum (List.map f_var tags) }
- | _ -> t
+ | Tydec_enum tags ->
+ { t with tydef_desc = Tydec_enum (List.map f_var tags) }
+ | _ ->
+ t
let rename_prog f_node f_var f_const prog =
- List.rev (
- List.fold_left (fun accu top ->
- (match top.top_decl_desc with
- | Node nd ->
- { top with top_decl_desc = Node (rename_node f_node f_var nd) }
- | Const c ->
- { top with top_decl_desc = Const (rename_const f_const c) }
- | TypeDef tdef ->
- { top with top_decl_desc = TypeDef (rename_typedef f_var tdef) }
- | ImportedNode _
- | Include _ | Open _ -> top)
- ::accu
-) [] prog
- )
-
-(* Applies the renaming function [fvar] to every rhs
- only when the corresponding lhs satisfies predicate [pvar] *)
- let eq_replace_rhs_var pvar fvar eq =
- let pvar l = List.exists pvar l in
- let rec replace lhs rhs =
- { rhs with expr_desc =
- match lhs with
- | [] -> assert false
- | [_] -> if pvar lhs then rename_expr_desc (fun x -> x) fvar rhs.expr_desc else rhs.expr_desc
- | _ ->
- (match rhs.expr_desc with
- | Expr_tuple tl ->
- Expr_tuple (List.map2 (fun v e -> replace [v] e) lhs tl)
- | Expr_appl (f, arg, None) when Basic_library.is_expr_internal_fun rhs ->
- let args = expr_list_of_expr arg in
- Expr_appl (f, expr_of_expr_list arg.expr_loc (List.map (replace lhs) args), None)
- | Expr_array _
- | Expr_access _
- | Expr_power _
- | Expr_const _
- | Expr_ident _
- | Expr_appl _ ->
- if pvar lhs
- then rename_expr_desc (fun x -> x) fvar rhs.expr_desc
- else rhs.expr_desc
- | Expr_ite (c, t, e) -> Expr_ite (replace lhs c, replace lhs t, replace lhs e)
- | Expr_arrow (e1, e2) -> Expr_arrow (replace lhs e1, replace lhs e2)
- | Expr_fby (e1, e2) -> Expr_fby (replace lhs e1, replace lhs e2)
- | Expr_pre e' -> Expr_pre (replace lhs e')
- | Expr_when (e', i, l) -> let i' = if pvar lhs then fvar i else i
- in Expr_when (replace lhs e', i', l)
- | Expr_merge (i, hl) -> let i' = if pvar lhs then fvar i else i
- in Expr_merge (i', List.map (fun (t, h) -> (t, replace lhs h)) hl)
- )
- }
- in { eq with eq_rhs = replace eq.eq_lhs eq.eq_rhs }
-
-
+ List.rev
+ (List.fold_left
+ (fun accu top ->
+ (match top.top_decl_desc with
+ | Node nd ->
+ { top with top_decl_desc = Node (rename_node f_node f_var nd) }
+ | Const c ->
+ { top with top_decl_desc = Const (rename_const f_const c) }
+ | TypeDef tdef ->
+ { top with top_decl_desc = TypeDef (rename_typedef f_var tdef) }
+ | ImportedNode _ | Include _ | Open _ ->
+ top)
+ :: accu)
+ [] prog)
+
+(* Applies the renaming function [fvar] to every rhs only when the corresponding
+ lhs satisfies predicate [pvar] *)
+let eq_replace_rhs_var pvar fvar eq =
+ let pvar l = List.exists pvar l in
+ let rec replace lhs rhs =
+ {
+ rhs with
+ expr_desc =
+ (match lhs with
+ | [] ->
+ assert false
+ | [ _ ] ->
+ if pvar lhs then rename_expr_desc (fun x -> x) fvar rhs.expr_desc
+ else rhs.expr_desc
+ | _ -> (
+ match rhs.expr_desc with
+ | Expr_tuple tl ->
+ Expr_tuple (List.map2 (fun v e -> replace [ v ] e) lhs tl)
+ | Expr_appl (f, arg, None) when Basic_library.is_expr_internal_fun rhs
+ ->
+ let args = expr_list_of_expr arg in
+ Expr_appl
+ ( f,
+ expr_of_expr_list arg.expr_loc (List.map (replace lhs) args),
+ None )
+ | Expr_array _
+ | Expr_access _
+ | Expr_power _
+ | Expr_const _
+ | Expr_ident _
+ | Expr_appl _ ->
+ if pvar lhs then rename_expr_desc (fun x -> x) fvar rhs.expr_desc
+ else rhs.expr_desc
+ | Expr_ite (c, t, e) ->
+ Expr_ite (replace lhs c, replace lhs t, replace lhs e)
+ | Expr_arrow (e1, e2) ->
+ Expr_arrow (replace lhs e1, replace lhs e2)
+ | Expr_fby (e1, e2) ->
+ Expr_fby (replace lhs e1, replace lhs e2)
+ | Expr_pre e' ->
+ Expr_pre (replace lhs e')
+ | Expr_when (e', i, l) ->
+ let i' = if pvar lhs then fvar i else i in
+ Expr_when (replace lhs e', i', l)
+ | Expr_merge (i, hl) ->
+ let i' = if pvar lhs then fvar i else i in
+ Expr_merge (i', List.map (fun (t, h) -> t, replace lhs h) hl)));
+ }
+ in
+ { eq with eq_rhs = replace eq.eq_lhs eq.eq_rhs }
+
(**********************************************************************)
(* Pretty printers *)
@@ -1015,12 +1183,12 @@ let pp_decl_type fmt tdecl =
fprintf fmt "%s: " ind.nodei_id;
Utils.reset_names ();
fprintf fmt "%a" Types.print_ty ind.nodei_type
- | Const _ | Include _ | Open _ | TypeDef _ -> ()
+ | Const _ | Include _ | Open _ | TypeDef _ ->
+ ()
let pp_prog_type fmt tdecl_list =
- Utils.Format.(pp_print_list
- ~pp_open_box:pp_open_vbox0
- pp_decl_type fmt tdecl_list)
+ Utils.Format.(
+ pp_print_list ~pp_open_box:pp_open_vbox0 pp_decl_type fmt tdecl_list)
let pp_decl_clock fmt cdecl =
match cdecl.top_decl_desc with
@@ -1032,161 +1200,190 @@ let pp_decl_clock fmt cdecl =
fprintf fmt "%s: " ind.nodei_id;
Utils.reset_names ();
fprintf fmt "%a@ " Clocks.print_ck ind.nodei_clock
- | Const _ | Include _ | Open _ | TypeDef _ -> ()
-
-let pp_prog_clock fmt prog =
- Utils.fprintf_list ~sep:"" pp_decl_clock fmt prog
+ | Const _ | Include _ | Open _ | TypeDef _ ->
+ ()
+let pp_prog_clock fmt prog = Utils.fprintf_list ~sep:"" pp_decl_clock fmt prog
(* filling node table with internal functions *)
let vdecls_of_typ_ck cpt ty =
let loc = Location.dummy_loc in
List.map
- (fun _ -> incr cpt;
- let name = sprintf "_var_%d" !cpt in
- mkvar_decl loc (name, mktyp loc Tydec_any, mkclock loc Ckdec_any, false, None, None))
+ (fun _ ->
+ incr cpt;
+ let name = sprintf "_var_%d" !cpt in
+ mkvar_decl loc
+ (name, mktyp loc Tydec_any, mkclock loc Ckdec_any, false, None, None))
(Types.type_list_of_type ty)
let mk_internal_node id =
let spec = None in
let ty = Env.lookup_value Basic_library.type_env id in
let ck = Env.lookup_value Basic_library.clock_env id in
- let (tin, tout) = Types.split_arrow ty in
- (*eprintf "internal fun %s: %d -> %d@." id (List.length (Types.type_list_of_type tin)) (List.length (Types.type_list_of_type tout));*)
+ let tin, tout = Types.split_arrow ty in
+ (*eprintf "internal fun %s: %d -> %d@." id (List.length
+ (Types.type_list_of_type tin)) (List.length (Types.type_list_of_type tout));*)
let cpt = ref (-1) in
mktop
(ImportedNode
- {nodei_id = id;
- nodei_type = ty;
- nodei_clock = ck;
- nodei_inputs = vdecls_of_typ_ck cpt tin;
- nodei_outputs = vdecls_of_typ_ck cpt tout;
- nodei_stateless = Types.get_static_value ty <> None;
- nodei_spec = spec;
- (* nodei_annot = []; *)
- nodei_prototype = None;
- nodei_in_lib = [];
+ {
+ nodei_id = id;
+ nodei_type = ty;
+ nodei_clock = ck;
+ nodei_inputs = vdecls_of_typ_ck cpt tin;
+ nodei_outputs = vdecls_of_typ_ck cpt tout;
+ nodei_stateless = Types.get_static_value ty <> None;
+ nodei_spec = spec;
+ (* nodei_annot = []; *)
+ nodei_prototype = None;
+ nodei_in_lib = [];
})
let add_internal_funs () =
List.iter
- (fun id -> let nd = mk_internal_node id in Hashtbl.add node_table id nd)
+ (fun id ->
+ let nd = mk_internal_node id in
+ Hashtbl.add node_table id nd)
Basic_library.internal_funs
-
-
(* Replace any occurence of a var in vars_to_replace by its associated
expression in defs until e does not contain any such variables *)
let rec substitute_expr vars_to_replace defs e =
let se = substitute_expr vars_to_replace defs in
- { e with expr_desc =
- let ed = e.expr_desc in
- match ed with
- | Expr_const _ -> ed
- | Expr_array el -> Expr_array (List.map se el)
- | Expr_access (e1, d) -> Expr_access (se e1, d)
- | Expr_power (e1, d) -> Expr_power (se e1, d)
- | Expr_tuple el -> Expr_tuple (List.map se el)
- | Expr_ite (c, t, e) -> Expr_ite (se c, se t, se e)
- | Expr_arrow (e1, e2)-> Expr_arrow (se e1, se e2)
- | Expr_fby (e1, e2) -> Expr_fby (se e1, se e2)
- | Expr_pre e' -> Expr_pre (se e')
- | Expr_when (e', i, l)-> Expr_when (se e', i, l)
- | Expr_merge (i, hl) -> Expr_merge (i, List.map (fun (t, h) -> (t, se h)) hl)
- | Expr_appl (i, e', i') -> Expr_appl (i, se e', i')
- | Expr_ident i ->
- if List.exists (fun v -> v.var_id = i) vars_to_replace then (
- let eq_i eq = eq.eq_lhs = [i] in
- if List.exists eq_i defs then
- let sub = List.find eq_i defs in
- let sub' = se sub.eq_rhs in
- sub'.expr_desc
- else
- assert false
- )
- else
- ed
+ {
+ e with
+ expr_desc =
+ (let ed = e.expr_desc in
+ match ed with
+ | Expr_const _ ->
+ ed
+ | Expr_array el ->
+ Expr_array (List.map se el)
+ | Expr_access (e1, d) ->
+ Expr_access (se e1, d)
+ | Expr_power (e1, d) ->
+ Expr_power (se e1, d)
+ | Expr_tuple el ->
+ Expr_tuple (List.map se el)
+ | Expr_ite (c, t, e) ->
+ Expr_ite (se c, se t, se e)
+ | Expr_arrow (e1, e2) ->
+ Expr_arrow (se e1, se e2)
+ | Expr_fby (e1, e2) ->
+ Expr_fby (se e1, se e2)
+ | Expr_pre e' ->
+ Expr_pre (se e')
+ | Expr_when (e', i, l) ->
+ Expr_when (se e', i, l)
+ | Expr_merge (i, hl) ->
+ Expr_merge (i, List.map (fun (t, h) -> t, se h) hl)
+ | Expr_appl (i, e', i') ->
+ Expr_appl (i, se e', i')
+ | Expr_ident i ->
+ if List.exists (fun v -> v.var_id = i) vars_to_replace then
+ let eq_i eq = eq.eq_lhs = [ i ] in
+ if List.exists eq_i defs then
+ let sub = List.find eq_i defs in
+ let sub' = se sub.eq_rhs in
+ sub'.expr_desc
+ else assert false
+ else ed);
+ }
+let expr_to_eexpr expr =
+ {
+ eexpr_tag = expr.expr_tag;
+ eexpr_qfexpr = expr;
+ eexpr_quantifiers = [];
+ eexpr_name = None;
+ eexpr_type = expr.expr_type;
+ eexpr_clock = expr.expr_clock;
+ eexpr_loc = expr.expr_loc (*eexpr_normalized = None*);
}
-
- let expr_to_eexpr expr =
- { eexpr_tag = expr.expr_tag;
- eexpr_qfexpr = expr;
- eexpr_quantifiers = [];
- eexpr_name = None;
- eexpr_type = expr.expr_type;
- eexpr_clock = expr.expr_clock;
- eexpr_loc = expr.expr_loc;
- (*eexpr_normalized = None*)
- }
- (* and expr_desc_to_eexpr_desc expr_desc = *)
- (* let conv = expr_to_eexpr in *)
- (* match expr_desc with *)
- (* | Expr_const c -> EExpr_const (match c with *)
- (* | Const_int x -> EConst_int x *)
- (* | Const_real x -> EConst_real x *)
- (* | Const_float x -> EConst_float x *)
- (* | Const_tag x -> EConst_tag x *)
- (* | _ -> assert false *)
-
- (* ) *)
- (* | Expr_ident i -> EExpr_ident i *)
- (* | Expr_tuple el -> EExpr_tuple (List.map conv el) *)
-
- (* | Expr_arrow (e1, e2)-> EExpr_arrow (conv e1, conv e2) *)
- (* | Expr_fby (e1, e2) -> EExpr_fby (conv e1, conv e2) *)
- (* | Expr_pre e' -> EExpr_pre (conv e') *)
- (* | Expr_appl (i, e', i') -> *)
- (* EExpr_appl *)
- (* (i, conv e', match i' with None -> None | Some(id, _) -> Some id) *)
-
- (* | Expr_when _ *)
- (* | Expr_merge _ -> assert false *)
- (* | Expr_array _ *)
- (* | Expr_access _ *)
- (* | Expr_power _ -> assert false *)
- (* | Expr_ite (c, t, e) -> assert false *)
- (* | _ -> assert false *)
-
-
+
+(* and expr_desc_to_eexpr_desc expr_desc = *)
+(* let conv = expr_to_eexpr in *)
+(* match expr_desc with *)
+(* | Expr_const c -> EExpr_const (match c with *)
+(* | Const_int x -> EConst_int x *)
+(* | Const_real x -> EConst_real x *)
+(* | Const_float x -> EConst_float x *)
+(* | Const_tag x -> EConst_tag x *)
+(* | _ -> assert false *)
+
+(* ) *)
+(* | Expr_ident i -> EExpr_ident i *)
+(* | Expr_tuple el -> EExpr_tuple (List.map conv el) *)
+
+(* | Expr_arrow (e1, e2)-> EExpr_arrow (conv e1, conv e2) *)
+(* | Expr_fby (e1, e2) -> EExpr_fby (conv e1, conv e2) *)
+(* | Expr_pre e' -> EExpr_pre (conv e') *)
+(* | Expr_appl (i, e', i') -> *)
+(* EExpr_appl *)
+(* (i, conv e', match i' with None -> None | Some(id, _) -> Some id) *)
+
+(* | Expr_when _ *)
+(* | Expr_merge _ -> assert false *)
+(* | Expr_array _ *)
+(* | Expr_access _ *)
+(* | Expr_power _ -> assert false *)
+(* | Expr_ite (c, t, e) -> assert false *)
+(* | _ -> assert false *)
+
let rec get_expr_calls nodes e =
let get_calls = get_expr_calls nodes in
match e.expr_desc with
- | Expr_const _
- | Expr_ident _ -> Utils.ISet.empty
- | Expr_tuple el
- | Expr_array el -> List.fold_left (fun accu e -> Utils.ISet.union accu (get_calls e)) Utils.ISet.empty el
- | Expr_pre e1
- | Expr_when (e1, _, _)
- | Expr_access (e1, _)
- | Expr_power (e1, _) -> get_calls e1
- | Expr_ite (c, t, e) -> Utils.ISet.union (Utils.ISet.union (get_calls c) (get_calls t)) (get_calls e)
- | Expr_arrow (e1, e2)
- | Expr_fby (e1, e2) -> Utils.ISet.union (get_calls e1) (get_calls e2)
- | Expr_merge (_, hl) -> List.fold_left (fun accu (_, h) -> Utils.ISet.union accu (get_calls h)) Utils.ISet.empty hl
- | Expr_appl (i, e', _) ->
- if Basic_library.is_expr_internal_fun e then
- (get_calls e')
- else
- let calls = Utils.ISet.add i (get_calls e') in
- let test = (fun n -> match n.top_decl_desc with Node nd -> nd.node_id = i | _ -> false) in
- if List.exists test nodes then
- match (List.find test nodes).top_decl_desc with
- | Node nd -> Utils.ISet.union (get_node_calls nodes nd) calls
- | _ -> assert false
- else
- calls
-
-and get_eq_calls nodes eq =
- get_expr_calls nodes eq.eq_rhs
+ | Expr_const _ | Expr_ident _ ->
+ Utils.ISet.empty
+ | Expr_tuple el | Expr_array el ->
+ List.fold_left
+ (fun accu e -> Utils.ISet.union accu (get_calls e))
+ Utils.ISet.empty el
+ | Expr_pre e1 | Expr_when (e1, _, _) | Expr_access (e1, _) | Expr_power (e1, _)
+ ->
+ get_calls e1
+ | Expr_ite (c, t, e) ->
+ Utils.ISet.union
+ (Utils.ISet.union (get_calls c) (get_calls t))
+ (get_calls e)
+ | Expr_arrow (e1, e2) | Expr_fby (e1, e2) ->
+ Utils.ISet.union (get_calls e1) (get_calls e2)
+ | Expr_merge (_, hl) ->
+ List.fold_left
+ (fun accu (_, h) -> Utils.ISet.union accu (get_calls h))
+ Utils.ISet.empty hl
+ | Expr_appl (i, e', _) ->
+ if Basic_library.is_expr_internal_fun e then get_calls e'
+ else
+ let calls = Utils.ISet.add i (get_calls e') in
+ let test n =
+ match n.top_decl_desc with Node nd -> nd.node_id = i | _ -> false
+ in
+ if List.exists test nodes then
+ match (List.find test nodes).top_decl_desc with
+ | Node nd ->
+ Utils.ISet.union (get_node_calls nodes nd) calls
+ | _ ->
+ assert false
+ else calls
+
+and get_eq_calls nodes eq = get_expr_calls nodes eq.eq_rhs
+
and get_aut_handler_calls nodes h =
- List.fold_left (fun accu stmt -> match stmt with
- | Eq eq -> Utils.ISet.union (get_eq_calls nodes eq) accu
- | Aut aut' -> Utils.ISet.union (get_aut_calls nodes aut') accu
- ) Utils.ISet.empty h.hand_stmts
+ List.fold_left
+ (fun accu stmt ->
+ match stmt with
+ | Eq eq ->
+ Utils.ISet.union (get_eq_calls nodes eq) accu
+ | Aut aut' ->
+ Utils.ISet.union (get_aut_calls nodes aut') accu)
+ Utils.ISet.empty h.hand_stmts
+
and get_aut_calls nodes aut =
- List.fold_left (fun accu h -> Utils.ISet.union (get_aut_handler_calls nodes h) accu)
+ List.fold_left
+ (fun accu h -> Utils.ISet.union (get_aut_handler_calls nodes h) accu)
Utils.ISet.empty aut.aut_handlers
+
and get_node_calls nodes node =
let eqs, auts = get_node_eqs node in
let aut_calls =
@@ -1199,27 +1396,37 @@ and get_node_calls nodes node =
aut_calls eqs
let get_expr_vars e =
- let rec get_expr_vars vars e =
- get_expr_desc_vars vars e.expr_desc
+ let rec get_expr_vars vars e = get_expr_desc_vars vars e.expr_desc
and get_expr_desc_vars vars expr_desc =
- (*Format.eprintf "get_expr_desc_vars expr=%a@." Printers.pp_expr (mkexpr Location.dummy_loc expr_desc);*)
- match expr_desc with
- | Expr_const _ -> vars
- | Expr_ident x -> Utils.ISet.add x vars
- | Expr_tuple el
- | Expr_array el -> List.fold_left get_expr_vars vars el
- | Expr_pre e1 -> get_expr_vars vars e1
- | Expr_when (e1, c, _) -> get_expr_vars (Utils.ISet.add c vars) e1
- | Expr_access (e1, d)
- | Expr_power (e1, d) -> List.fold_left get_expr_vars vars [e1; expr_of_dimension d]
- | Expr_ite (c, t, e) -> List.fold_left get_expr_vars vars [c; t; e]
- | Expr_arrow (e1, e2)
- | Expr_fby (e1, e2) -> List.fold_left get_expr_vars vars [e1; e2]
- | Expr_merge (c, hl) -> List.fold_left (fun vars (_, h) -> get_expr_vars vars h) (Utils.ISet.add c vars) hl
- | Expr_appl (_, arg, None) -> get_expr_vars vars arg
- | Expr_appl (_, arg, Some r) -> List.fold_left get_expr_vars vars [arg; r]
+ (*Format.eprintf "get_expr_desc_vars expr=%a@." Printers.pp_expr (mkexpr
+ Location.dummy_loc expr_desc);*)
+ match expr_desc with
+ | Expr_const _ ->
+ vars
+ | Expr_ident x ->
+ Utils.ISet.add x vars
+ | Expr_tuple el | Expr_array el ->
+ List.fold_left get_expr_vars vars el
+ | Expr_pre e1 ->
+ get_expr_vars vars e1
+ | Expr_when (e1, c, _) ->
+ get_expr_vars (Utils.ISet.add c vars) e1
+ | Expr_access (e1, d) | Expr_power (e1, d) ->
+ List.fold_left get_expr_vars vars [ e1; expr_of_dimension d ]
+ | Expr_ite (c, t, e) ->
+ List.fold_left get_expr_vars vars [ c; t; e ]
+ | Expr_arrow (e1, e2) | Expr_fby (e1, e2) ->
+ List.fold_left get_expr_vars vars [ e1; e2 ]
+ | Expr_merge (c, hl) ->
+ List.fold_left
+ (fun vars (_, h) -> get_expr_vars vars h)
+ (Utils.ISet.add c vars) hl
+ | Expr_appl (_, arg, None) ->
+ get_expr_vars vars arg
+ | Expr_appl (_, arg, Some r) ->
+ List.fold_left get_expr_vars vars [ arg; r ]
in
- get_expr_vars Utils.ISet.empty e
+ get_expr_vars Utils.ISet.empty e
(* let rec expr_has_arrows e =
* expr_desc_has_arrows e.expr_desc
@@ -1246,149 +1453,145 @@ let get_expr_vars e =
* let eqs, auts = get_node_eqs node in
* List.exists (fun eq -> eq_has_arrows eq) eqs || List.exists (fun aut -> aut_has_arrows aut) auts *)
-
-
-
-
-let rec expr_contains_expr expr_tag expr =
+let rec expr_contains_expr expr_tag expr =
let search = expr_contains_expr expr_tag in
- expr.expr_tag = expr_tag ||
- (
- match expr.expr_desc with
- | Expr_const _ -> false
- | Expr_array el -> List.exists search el
- | Expr_access (e1, _)
- | Expr_power (e1, _) -> search e1
- | Expr_tuple el -> List.exists search el
- | Expr_ite (c, t, e) -> List.exists search [c;t;e]
- | Expr_arrow (e1, e2)
- | Expr_fby (e1, e2) -> List.exists search [e1; e2]
- | Expr_pre e'
- | Expr_when (e', _, _) -> search e'
- | Expr_merge (_, hl) -> List.exists (fun (_, h) -> search h) hl
- | Expr_appl (_, e', None) -> search e'
- | Expr_appl (_, e', Some e'') -> List.exists search [e'; e'']
- | Expr_ident _ -> false
- )
-
-
+ expr.expr_tag = expr_tag
+ ||
+ match expr.expr_desc with
+ | Expr_const _ ->
+ false
+ | Expr_array el ->
+ List.exists search el
+ | Expr_access (e1, _) | Expr_power (e1, _) ->
+ search e1
+ | Expr_tuple el ->
+ List.exists search el
+ | Expr_ite (c, t, e) ->
+ List.exists search [ c; t; e ]
+ | Expr_arrow (e1, e2) | Expr_fby (e1, e2) ->
+ List.exists search [ e1; e2 ]
+ | Expr_pre e' | Expr_when (e', _, _) ->
+ search e'
+ | Expr_merge (_, hl) ->
+ List.exists (fun (_, h) -> search h) hl
+ | Expr_appl (_, e', None) ->
+ search e'
+ | Expr_appl (_, e', Some e'') ->
+ List.exists search [ e'; e'' ]
+ | Expr_ident _ ->
+ false
(* Generate a new local [node] variable *)
let cpt_fresh = ref 0
-let reset_cpt_fresh () =
- cpt_fresh := 0
-
+let reset_cpt_fresh () = cpt_fresh := 0
+
let mk_fresh_var (parentid, ctx_env) loc ty ck =
let rec aux () =
- incr cpt_fresh;
- let s = Printf.sprintf "__%s_%d" parentid !cpt_fresh in
- if List.exists (fun v -> v.var_id = s) ctx_env then aux () else
- {
- var_id = s;
- var_orig = false;
- var_dec_type = dummy_type_dec;
- var_dec_clock = dummy_clock_dec;
- var_dec_const = false;
- var_dec_value = None;
- var_parent_nodeid = Some parentid;
- var_type = ty;
- var_clock = ck;
- var_loc = loc
- }
- in aux ()
-
+ incr cpt_fresh;
+ let s = Printf.sprintf "__%s_%d" parentid !cpt_fresh in
+ if List.exists (fun v -> v.var_id = s) ctx_env then aux ()
+ else
+ {
+ var_id = s;
+ var_orig = false;
+ var_dec_type = dummy_type_dec;
+ var_dec_clock = dummy_clock_dec;
+ var_dec_const = false;
+ var_dec_value = None;
+ var_parent_nodeid = Some parentid;
+ var_type = ty;
+ var_clock = ck;
+ var_loc = loc;
+ }
+ in
+ aux ()
let find_eq xl eqs =
let rec aux accu eqs =
match eqs with
- | [] ->
- begin
- Format.eprintf "Looking for variables %a in the following equations@.%a@."
- (Utils.fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) xl
- Printers.pp_node_eqs eqs;
- assert false
- end
- | hd::tl ->
- if List.exists (fun x -> List.mem x hd.eq_lhs) xl then hd, accu@tl else aux (hd::accu) tl
- in
- aux [] eqs
+ | [] ->
+ Format.eprintf "Looking for variables %a in the following equations@.%a@."
+ (Utils.fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v))
+ xl Printers.pp_node_eqs eqs;
+ assert false
+ | hd :: tl ->
+ if List.exists (fun x -> List.mem x hd.eq_lhs) xl then hd, accu @ tl
+ else aux (hd :: accu) tl
+ in
+ aux [] eqs
-
let get_node name prog =
- let node_opt = List.fold_left
- (fun res top ->
- match res, top.top_decl_desc with
- | Some _, _ -> res
- | None, Node nd ->
- (* Format.eprintf "Checking node %s = %s: %b@." nd.node_id name (nd.node_id = name); *)
- if nd.node_id = name then Some nd else res
- | _ -> None)
- None prog
+ let node_opt =
+ List.fold_left
+ (fun res top ->
+ match res, top.top_decl_desc with
+ | Some _, _ ->
+ res
+ | None, Node nd ->
+ (* Format.eprintf "Checking node %s = %s: %b@." nd.node_id name
+ (nd.node_id = name); *)
+ if nd.node_id = name then Some nd else res
+ | _ ->
+ None)
+ None prog
in
- try
- Utils.desome node_opt
- with Utils.DeSome -> raise Not_found
+ try Utils.desome node_opt with Utils.DeSome -> raise Not_found
(* Pushing negations in expression. Subtitute operators whenever possible *)
-let rec push_negations ?(neg=false) e =
+let rec push_negations ?(neg = false) e =
let res =
let pn = push_negations in
let map desc =
(* Keeping clock and type info *)
let new_e = mkexpr e.expr_loc desc in
- {
- new_e
- with
- expr_type = e.expr_type;
- expr_clock = e.expr_clock
- }
+ { new_e with expr_type = e.expr_type; expr_clock = e.expr_clock }
in
match e.expr_desc with
- | Expr_ite (g,t,e) ->
- if neg then
- map (Expr_ite(pn g, pn e, pn t))
- else
- map (Expr_ite(pn g, pn t, pn e))
+ | Expr_ite (g, t, e) ->
+ if neg then map (Expr_ite (pn g, pn e, pn t))
+ else map (Expr_ite (pn g, pn t, pn e))
| Expr_tuple t ->
- map (Expr_tuple (List.map (pn ~neg) t))
+ map (Expr_tuple (List.map (pn ~neg) t))
| Expr_arrow (e1, e2) ->
- map (Expr_arrow (pn ~neg e1, pn ~neg e2))
+ map (Expr_arrow (pn ~neg e1, pn ~neg e2))
| Expr_fby (e1, e2) ->
- map (Expr_fby (pn ~neg e1, pn ~neg e2))
+ map (Expr_fby (pn ~neg e1, pn ~neg e2))
| Expr_pre e ->
- map (Expr_pre (pn ~neg e))
+ map (Expr_pre (pn ~neg e))
| Expr_appl (op, e', None) when op = "not" ->
- if neg then
- push_negations ~neg:false e'
- else
- push_negations ~neg:true e'
- | Expr_appl (op, e', None) when List.mem op (Basic_library.bool_funs @ Basic_library.rel_funs) -> (
+ if neg then push_negations ~neg:false e' else push_negations ~neg:true e'
+ | Expr_appl (op, e', None)
+ when List.mem op (Basic_library.bool_funs @ Basic_library.rel_funs) -> (
match op with
- | "&&" -> map (Expr_appl((if neg then "||" else op), pn ~neg e', None))
- | "||" -> map (Expr_appl((if neg then "&&" else op), pn ~neg e', None))
+ | "&&" ->
+ map (Expr_appl ((if neg then "||" else op), pn ~neg e', None))
+ | "||" ->
+ map (Expr_appl ((if neg then "&&" else op), pn ~neg e', None))
(* TODO xor/equi/impl *)
- | "<" -> map (Expr_appl((if neg then ">=" else op), pn e', None))
- | ">" -> map (Expr_appl((if neg then "<=" else op), pn e', None))
- | "<=" -> map (Expr_appl((if neg then ">" else op), pn e', None))
- | ">=" -> map (Expr_appl((if neg then "<" else op), pn e', None))
- | "!=" -> map (Expr_appl((if neg then "=" else op), pn e', None))
- | "=" -> map (Expr_appl((if neg then "!=" else op), pn e', None))
-
- | _ -> assert false
- )
- | Expr_const c -> if neg then map (Expr_const (const_negation c)) else e
- | Expr_ident _ ->
- if neg then
- mkpredef_call e.expr_loc "not" [e]
- else
- e
+ | "<" ->
+ map (Expr_appl ((if neg then ">=" else op), pn e', None))
+ | ">" ->
+ map (Expr_appl ((if neg then "<=" else op), pn e', None))
+ | "<=" ->
+ map (Expr_appl ((if neg then ">" else op), pn e', None))
+ | ">=" ->
+ map (Expr_appl ((if neg then "<" else op), pn e', None))
+ | "!=" ->
+ map (Expr_appl ((if neg then "=" else op), pn e', None))
+ | "=" ->
+ map (Expr_appl ((if neg then "!=" else op), pn e', None))
+ | _ ->
+ assert false)
+ | Expr_const c ->
+ if neg then map (Expr_const (const_negation c)) else e
+ | Expr_ident _ ->
+ if neg then mkpredef_call e.expr_loc "not" [ e ] else e
| Expr_appl _ ->
- if neg then
- mkpredef_call e.expr_loc "not" [e]
- else
- e
- | _ -> assert false (* no array, array access, power or merge/when *)
+ if neg then mkpredef_call e.expr_loc "not" [ e ] else e
+ | _ ->
+ assert false
+ (* no array, array access, power or merge/when *)
in
res
@@ -1396,78 +1599,74 @@ let rec add_pre_expr vars e =
let ap = add_pre_expr vars in
let desc =
match e.expr_desc with
- | Expr_ite (g,t,e) ->
- Expr_ite (ap g, ap t,ap e)
+ | Expr_ite (g, t, e) ->
+ Expr_ite (ap g, ap t, ap e)
| Expr_tuple t ->
- Expr_tuple (List.map ap t)
+ Expr_tuple (List.map ap t)
| Expr_arrow (e1, e2) ->
- Expr_arrow (ap e1, ap e2)
+ Expr_arrow (ap e1, ap e2)
| Expr_fby (e1, e2) ->
- Expr_fby (ap e1, ap e2)
+ Expr_fby (ap e1, ap e2)
| Expr_pre e ->
- Expr_pre (ap e)
+ Expr_pre (ap e)
| Expr_appl (op, e, opt) ->
- Expr_appl (op, ap e, opt)
- | Expr_const _ -> e.expr_desc
+ Expr_appl (op, ap e, opt)
+ | Expr_const _ ->
+ e.expr_desc
| Expr_ident id ->
- if List.mem id vars then
- Expr_pre e
- else
- e.expr_desc
- | _ -> assert false (* no array, array access, power or merge/when yet *)
+ if List.mem id vars then Expr_pre e else e.expr_desc
+ | _ ->
+ assert false
+ (* no array, array access, power or merge/when yet *)
in
let new_e = mkexpr e.expr_loc desc in
- { new_e with
- expr_type = e.expr_type;
- expr_clock = e.expr_clock
- }
-
-
-
-let mk_eq l e1 e2 =
- mkpredef_call l "=" [e1; e2]
+ { new_e with expr_type = e.expr_type; expr_clock = e.expr_clock }
+let mk_eq l e1 e2 = mkpredef_call l "=" [ e1; e2 ]
let rec partial_eval e =
let pa = partial_eval in
let edesc =
match e.expr_desc with
- | Expr_const _ -> e.expr_desc
- | Expr_ident _ -> e.expr_desc
- | Expr_ite (g,t,e) -> (
- let g, t, e = pa g, pa t, pa e in
- match g.expr_desc with
- | Expr_const (Const_tag tag) when (tag = tag_true) -> t.expr_desc
- | Expr_const (Const_tag tag) when (tag = tag_false) -> e.expr_desc
- | _ -> Expr_ite (g, t, e)
- )
+ | Expr_const _ ->
+ e.expr_desc
+ | Expr_ident _ ->
+ e.expr_desc
+ | Expr_ite (g, t, e) -> (
+ let g, t, e = pa g, pa t, pa e in
+ match g.expr_desc with
+ | Expr_const (Const_tag tag) when tag = tag_true ->
+ t.expr_desc
+ | Expr_const (Const_tag tag) when tag = tag_false ->
+ e.expr_desc
+ | _ ->
+ Expr_ite (g, t, e))
| Expr_tuple t ->
- Expr_tuple (List.map pa t)
+ Expr_tuple (List.map pa t)
| Expr_arrow (e1, e2) ->
- Expr_arrow (pa e1, pa e2)
+ Expr_arrow (pa e1, pa e2)
| Expr_fby (e1, e2) ->
- Expr_fby (pa e1, pa e2)
+ Expr_fby (pa e1, pa e2)
| Expr_pre e ->
- Expr_pre (pa e)
+ Expr_pre (pa e)
| Expr_appl (op, args, opt) ->
- let args = pa args in
- if Basic_library.is_expr_internal_fun e then
- Basic_library.partial_eval op args opt
- else
- Expr_appl (op, args, opt)
+ let args = pa args in
+ if Basic_library.is_expr_internal_fun e then
+ Basic_library.partial_eval op args opt
+ else Expr_appl (op, args, opt)
| Expr_array el ->
- Expr_array (List.map pa el)
+ Expr_array (List.map pa el)
| Expr_access (e, d) ->
- Expr_access (pa e, d)
+ Expr_access (pa e, d)
| Expr_power (e, d) ->
- Expr_power (pa e, d)
+ Expr_power (pa e, d)
| Expr_when (e, id, l) ->
- Expr_when (pa e, id, l)
- | Expr_merge (id, gl) ->
- Expr_merge(id, List.map (fun (l, e) -> l, pa e) gl)
+ Expr_when (pa e, id, l)
+ | Expr_merge (id, gl) ->
+ Expr_merge (id, List.map (fun (l, e) -> l, pa e) gl)
in
{ e with expr_desc = edesc }
- (* Local Variables: *)
- (* compile-command:"make -C .." *)
- (* End: *)
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
diff --git a/src/corelang.mli b/src/corelang.mli
index e4d1053fbbc69c26043cea6e2f39a7fde6d013ae..8dea180d0da3481cc858e78dd18967415efa9108 100644
--- a/src/corelang.mli
+++ b/src/corelang.mli
@@ -9,205 +9,312 @@
(* *)
(********************************************************************)
-
open Lustre_types
-module VDeclModule: sig
+module VDeclModule : sig
type t
- val compare: t -> t -> int
-end with type t = Lustre_types.var_decl
-module VSet: sig
+ val compare : t -> t -> int
+end
+with type t = Lustre_types.var_decl
+
+module VSet : sig
include Set.S
- val pp: Format.formatter -> t -> unit
- val get: ident -> t -> elt
-end with type elt = Lustre_types.var_decl
-
-val dummy_type_dec: type_dec
-val dummy_clock_dec: clock_dec
-
-val mktyp: Location.t -> type_dec_desc -> type_dec
-val mkclock: Location.t -> clock_dec_desc -> clock_dec
-val mkvar_decl: Location.t -> ?orig:bool ->
- ident *
- type_dec *
- clock_dec *
- bool (* is const *) *
- expr option (* value *) *
- string option (* parent id *)
- -> var_decl
-
-val dummy_var_decl: ident -> Types.type_expr -> var_decl
-
-val var_decl_of_const: ?parentid:ident option -> const_desc -> var_decl
-val mkexpr: Location.t -> expr_desc -> expr
-val mkeq: Location.t -> ident list * expr -> eq
-val mkassert: Location.t -> expr -> assert_t
-val mktop_decl: Location.t -> ident -> bool -> top_decl_desc -> top_decl
-val mkpredef_call: Location.t -> ident -> expr list -> expr
-val mk_new_name: (ident -> bool) -> ident -> ident
-val mk_new_node_name: node_desc -> ident -> ident
-val mktop: top_decl_desc -> top_decl
+
+ val pp : Format.formatter -> t -> unit
+
+ val get : ident -> t -> elt
+end
+with type elt = Lustre_types.var_decl
+
+val dummy_type_dec : type_dec
+
+val dummy_clock_dec : clock_dec
+
+val mktyp : Location.t -> type_dec_desc -> type_dec
+
+val mkclock : Location.t -> clock_dec_desc -> clock_dec
+
+val mkvar_decl :
+ Location.t ->
+ ?orig:bool ->
+ ident
+ * type_dec
+ * clock_dec
+ * bool (* is const *)
+ * expr option
+ (* value *)
+ * string option
+ (* parent id *) ->
+ var_decl
+
+val dummy_var_decl : ident -> Types.type_expr -> var_decl
+
+val var_decl_of_const : ?parentid:ident option -> const_desc -> var_decl
+
+val mkexpr : Location.t -> expr_desc -> expr
+
+val mkeq : Location.t -> ident list * expr -> eq
+
+val mkassert : Location.t -> expr -> assert_t
+
+val mktop_decl : Location.t -> ident -> bool -> top_decl_desc -> top_decl
+
+val mkpredef_call : Location.t -> ident -> expr list -> expr
+
+val mk_new_name : (ident -> bool) -> ident -> ident
+
+val mk_new_node_name : node_desc -> ident -> ident
+
+val mktop : top_decl_desc -> top_decl
(* constructor for machine types *)
-val mkinstr: (* ?lustre_expr:expr -> *)?lustre_eq: eq -> ?instr_spec: Machine_code_types.value_t Spec_types.formula_t list -> Machine_code_types.instr_t_desc -> Machine_code_types.instr_t
-val get_instr_desc: Machine_code_types.instr_t -> Machine_code_types.instr_t_desc
-val update_instr_desc: Machine_code_types.instr_t -> Machine_code_types.instr_t_desc -> Machine_code_types.instr_t
-
+val mkinstr :
+ ?lustre_eq:(* ?lustre_expr:expr -> *)
+ eq ->
+ ?instr_spec:Machine_code_types.value_t Spec_types.formula_t list ->
+ Machine_code_types.instr_t_desc ->
+ Machine_code_types.instr_t
+
+val get_instr_desc :
+ Machine_code_types.instr_t -> Machine_code_types.instr_t_desc
+
+val update_instr_desc :
+ Machine_code_types.instr_t ->
+ Machine_code_types.instr_t_desc ->
+ Machine_code_types.instr_t
+
(*val node_table : (ident, top_decl) Hashtbl.t*)
-val print_node_table: Format.formatter -> unit -> unit
-val node_name: top_decl -> ident
-val node_inputs: top_decl -> var_decl list
-val node_from_name: ident -> top_decl
-val update_node: ident -> top_decl -> unit
-val is_generic_node: top_decl -> bool
-val is_imported_node: top_decl -> bool
-val is_contract: top_decl -> bool
-val is_node_contract: node_desc -> bool
-val get_node_contract: node_desc -> contract_desc
-
-val consts_table: (ident, top_decl) Hashtbl.t
-val print_consts_table: Format.formatter -> unit -> unit
-val type_table: (type_dec_desc, top_decl) Hashtbl.t
-val print_type_table: Format.formatter -> unit -> unit
-val is_clock_dec_type: type_dec_desc -> bool
-val get_repr_type: type_dec_desc -> type_dec_desc
-val is_user_type: type_dec_desc -> bool
-val coretype_equal: type_dec_desc -> type_dec_desc -> bool
-val tag_default: label
-val tag_table: (label, top_decl) Hashtbl.t
-val field_table: (label, top_decl) Hashtbl.t
-
-val get_enum_type_tags: type_dec_desc -> label list
-
-val get_struct_type_fields: type_dec_desc -> (label * type_dec_desc) list
-
-val consts_of_enum_type: top_decl -> top_decl list
-
-val const_of_bool: bool -> constant
-val const_is_bool: constant -> bool
-val const_negation: constant -> constant
-val const_or: constant -> constant -> constant
-val const_and: constant -> constant -> constant
-val const_xor: constant -> constant -> constant
-val const_impl: constant -> constant -> constant
-
-val get_var: ident -> var_decl list -> var_decl
-val get_node_vars: node_desc -> var_decl list
-val get_node_var: ident -> node_desc -> var_decl
-val get_node_eqs: node_desc -> eq list * automata_desc list
-val get_node_eq: ident -> node_desc -> eq
-val get_node_interface: node_desc -> imported_node_desc
+val print_node_table : Format.formatter -> unit -> unit
+
+val node_name : top_decl -> ident
+
+val node_inputs : top_decl -> var_decl list
+
+val node_from_name : ident -> top_decl
+
+val update_node : ident -> top_decl -> unit
+
+val is_generic_node : top_decl -> bool
+
+val is_imported_node : top_decl -> bool
+
+val is_contract : top_decl -> bool
+
+val is_node_contract : node_desc -> bool
+
+val get_node_contract : node_desc -> contract_desc
+
+val consts_table : (ident, top_decl) Hashtbl.t
+
+val print_consts_table : Format.formatter -> unit -> unit
+
+val type_table : (type_dec_desc, top_decl) Hashtbl.t
+
+val print_type_table : Format.formatter -> unit -> unit
+
+val is_clock_dec_type : type_dec_desc -> bool
+
+val get_repr_type : type_dec_desc -> type_dec_desc
+
+val is_user_type : type_dec_desc -> bool
+
+val coretype_equal : type_dec_desc -> type_dec_desc -> bool
+
+val tag_default : label
+
+val tag_table : (label, top_decl) Hashtbl.t
+
+val field_table : (label, top_decl) Hashtbl.t
+
+val get_enum_type_tags : type_dec_desc -> label list
+
+val get_struct_type_fields : type_dec_desc -> (label * type_dec_desc) list
+
+val consts_of_enum_type : top_decl -> top_decl list
+
+val const_of_bool : bool -> constant
+
+val const_is_bool : constant -> bool
+
+val const_negation : constant -> constant
+
+val const_or : constant -> constant -> constant
+
+val const_and : constant -> constant -> constant
+
+val const_xor : constant -> constant -> constant
+
+val const_impl : constant -> constant -> constant
+
+val get_var : ident -> var_decl list -> var_decl
+
+val get_node_vars : node_desc -> var_decl list
+
+val get_node_var : ident -> node_desc -> var_decl
+
+val get_node_eqs : node_desc -> eq list * automata_desc list
+
+val get_node_eq : ident -> node_desc -> eq
+
+val get_node_interface : node_desc -> imported_node_desc
(* val get_const: ident -> constant *)
val sort_handlers : (label * 'a) list -> (label * 'a) list
-val is_eq_expr: expr -> expr -> bool
+val is_eq_expr : expr -> expr -> bool
-(* val pp_error : Format.formatter -> error -> unit *)
+(* val pp_error : Format.formatter -> error -> unit *)
(* Caution, returns an untyped, unclocked, etc, expression *)
val is_tuple_expr : expr -> bool
+
val ident_of_expr : expr -> ident
+
val expr_of_vdecl : var_decl -> expr
+
val expr_of_ident : ident -> Location.t -> expr
+
val expr_list_of_expr : expr -> expr list
+
val expr_of_expr_list : Location.t -> expr list -> expr
-val call_of_expr: expr -> (ident * expr list * expr option)
-val expr_of_dimension: Dimension.dim_expr -> expr
-val dimension_of_expr: expr -> Dimension.dim_expr
-val dimension_of_const: Location.t -> constant -> Dimension.dim_expr
-val expr_to_eexpr: expr -> eexpr
-(* REMOVED, pushed in utils.ml val new_tag : unit -> tag *)
-val add_internal_funs: unit -> unit
+val call_of_expr : expr -> ident * expr list * expr option
+
+val expr_of_dimension : Dimension.dim_expr -> expr
+
+val dimension_of_expr : expr -> Dimension.dim_expr
+
+val dimension_of_const : Location.t -> constant -> Dimension.dim_expr
+
+val expr_to_eexpr : expr -> eexpr
+(* REMOVED, pushed in utils.ml val new_tag : unit -> tag *)
+
+val add_internal_funs : unit -> unit
val pp_prog_type : Format.formatter -> program_t -> unit
val pp_prog_clock : Format.formatter -> program_t -> unit
-val const_of_top: top_decl -> const_desc
-val node_of_top: top_decl -> node_desc
-val imported_node_of_top: top_decl -> imported_node_desc
-val typedef_of_top: top_decl -> typedef_desc
-val dependency_of_top: top_decl -> (bool * ident)
+val const_of_top : top_decl -> const_desc
+
+val node_of_top : top_decl -> node_desc
+
+val imported_node_of_top : top_decl -> imported_node_desc
+
+val typedef_of_top : top_decl -> typedef_desc
+
+val dependency_of_top : top_decl -> bool * ident
val get_nodes : program_t -> top_decl list
+
val get_imported_nodes : program_t -> top_decl list
+
val get_consts : program_t -> top_decl list
-val get_typedefs: program_t -> top_decl list
+
+val get_typedefs : program_t -> top_decl list
+
val get_dependencies : program_t -> top_decl list
(* val prog_unfold_consts: program_t -> program_t *)
-(** Returns the node named ident in the provided program. Raise Not_found *)
val get_node : ident -> program_t -> node_desc
+(** Returns the node named ident in the provided program. Raise Not_found *)
+
+val rename_static :
+ (ident -> Dimension.dim_expr) -> type_dec_desc -> type_dec_desc
-
-val rename_static: (ident -> Dimension.dim_expr) -> type_dec_desc -> type_dec_desc
-val rename_carrier: (ident -> ident) -> clock_dec_desc -> clock_dec_desc
+val rename_carrier : (ident -> ident) -> clock_dec_desc -> clock_dec_desc
-val get_expr_vars: expr -> Utils.ISet.t
+val get_expr_vars : expr -> Utils.ISet.t
(*val expr_replace_var: (ident -> ident) -> expr -> expr*)
-val eq_replace_rhs_var: (ident -> bool) -> (ident -> ident) -> eq -> eq
+val eq_replace_rhs_var : (ident -> bool) -> (ident -> ident) -> eq -> eq
-(** val rename_expr f_node f_var expr *)
val rename_expr : (ident -> ident) -> (ident -> ident) -> expr -> expr
+(** val rename_expr f_node f_var expr *)
-(** val rename_eq f_node f_var eq *)
val rename_eq : (ident -> ident) -> (ident -> ident) -> eq -> eq
+(** val rename_eq f_node f_var eq *)
+val rename_aut :
+ (ident -> ident) -> (ident -> ident) -> automata_desc -> automata_desc
(** val rename_aut f_node f_var aut *)
-val rename_aut : (ident -> ident) -> (ident -> ident) -> automata_desc -> automata_desc
+val rename_prog :
+ (ident -> ident) ->
+ (ident -> ident) ->
+ (ident -> ident) ->
+ program_t ->
+ program_t
(** rename_prog f_node f_var f_const prog *)
-val rename_prog: (ident -> ident) -> (ident -> ident) -> (ident -> ident) -> program_t -> program_t
-val rename_node: (ident -> ident) -> (ident -> ident) -> node_desc -> node_desc
-val substitute_expr: var_decl list -> eq list -> expr -> expr
+val rename_node : (ident -> ident) -> (ident -> ident) -> node_desc -> node_desc
+
+val substitute_expr : var_decl list -> eq list -> expr -> expr
+
+val copy_var_decl : var_decl -> var_decl
+
+val copy_const : const_desc -> const_desc
-val copy_var_decl: var_decl -> var_decl
-val copy_const: const_desc -> const_desc
-val copy_node: node_desc -> node_desc
-val copy_top: top_decl -> top_decl
-val copy_prog: top_decl list -> top_decl list
+val copy_node : node_desc -> node_desc
+val copy_top : top_decl -> top_decl
+
+val copy_prog : top_decl list -> top_decl list
+
+val mkeexpr : Location.t -> expr -> eexpr
(** Annotation expression related functions *)
-val mkeexpr: Location.t -> expr -> eexpr
-val empty_contract: contract_desc
-val mk_contract_var: ident -> bool -> type_dec option -> expr -> Location.t -> contract_desc
-val mk_contract_guarantees: string option -> eexpr -> contract_desc
-val mk_contract_assume: string option -> eexpr -> contract_desc
-val mk_contract_mode: ident -> eexpr list -> eexpr list -> Location.t -> contract_desc
-val mk_contract_import: ident -> expr -> expr -> Location.t -> contract_desc
-val merge_contracts: contract_desc -> contract_desc -> contract_desc
-val extend_eexpr: (quantifier_type * var_decl list) list -> eexpr -> eexpr
-val update_expr_annot: ident -> expr -> expr_annot -> expr
+
+val empty_contract : contract_desc
+
+val mk_contract_var :
+ ident -> bool -> type_dec option -> expr -> Location.t -> contract_desc
+
+val mk_contract_guarantees : string option -> eexpr -> contract_desc
+
+val mk_contract_assume : string option -> eexpr -> contract_desc
+
+val mk_contract_mode :
+ ident -> eexpr list -> eexpr list -> Location.t -> contract_desc
+
+val mk_contract_import : ident -> expr -> expr -> Location.t -> contract_desc
+
+val merge_contracts : contract_desc -> contract_desc -> contract_desc
+
+val extend_eexpr : (quantifier_type * var_decl list) list -> eexpr -> eexpr
+
+val update_expr_annot : ident -> expr -> expr_annot -> expr
(* val mkpredef_call: Location.t -> ident -> eexpr list -> eexpr*)
-val expr_contains_expr: tag -> expr -> bool
+val expr_contains_expr : tag -> expr -> bool
+
+val reset_cpt_fresh : unit -> unit
-val reset_cpt_fresh: unit -> unit
-
-(* mk_fresh_var parentid to be registered as parent_nodeid, vars is the list of existing vars in that context *)
-val mk_fresh_var: (ident * var_decl list) -> Location.t -> Types.type_expr -> Clocks.clock_expr -> var_decl
+(* mk_fresh_var parentid to be registered as parent_nodeid, vars is the list of
+ existing vars in that context *)
+val mk_fresh_var :
+ ident * var_decl list ->
+ Location.t ->
+ Types.type_expr ->
+ Clocks.clock_expr ->
+ var_decl
-val find_eq: ident list -> eq list -> eq * eq list
+val find_eq : ident list -> eq list -> eq * eq list
-val get_expr_calls: top_decl list -> expr -> Utils.ISet.t
+val get_expr_calls : top_decl list -> expr -> Utils.ISet.t
(* val eq_has_arrows: eq -> bool *)
-val push_negations: ?neg:bool -> expr -> expr
+val push_negations : ?neg:bool -> expr -> expr
-val add_pre_expr: ident list -> expr -> expr
+val add_pre_expr : ident list -> expr -> expr
-val mk_eq: Location.t -> expr -> expr -> expr
+val mk_eq : Location.t -> expr -> expr -> expr
(* Simple transformations: eg computation over constants *)
-val partial_eval: expr -> expr
+val partial_eval : expr -> expr
- (* Local Variables: *)
+(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/delay.ml b/src/delay.ml
index 12c60525524d4504f434c09e58f983c493ba04c2..2e2382563376d00559a18b0c3f0760266f7523c6 100644
--- a/src/delay.ml
+++ b/src/delay.ml
@@ -9,90 +9,91 @@
(* *)
(********************************************************************)
-(** Types definitions and a few utility functions on delay types.
- Delay analysis by type polymorphism instead of constraints *)
open Utils
+(** Types definitions and a few utility functions on delay types. Delay analysis
+ by type polymorphism instead of constraints *)
-type delay_expr =
- {mutable ddesc: delay_desc;
- did: int}
+type delay_expr = { mutable ddesc : delay_desc; did : int }
and delay_desc =
| Dvar (* Monomorphic type variable *)
| Dundef
| Darrow of delay_expr * delay_expr
| Dtuple of delay_expr list
- | Dlink of delay_expr (* During unification, make links instead of substitutions *)
- | Dunivar (* Polymorphic type variable *)
-type error =
- | Delay_clash of delay_expr * delay_expr
+ | Dlink of delay_expr
+ (* During unification, make links instead of substitutions *)
+ | Dunivar
+(* Polymorphic type variable *)
+
+type error = Delay_clash of delay_expr * delay_expr
exception Unify of delay_expr * delay_expr
+
exception Error of Location.t * error
let new_id = ref (-1)
let new_delay desc =
- incr new_id; {ddesc = desc; did = !new_id }
+ incr new_id;
+ { ddesc = desc; did = !new_id }
-let new_var () =
- new_delay Dvar
+let new_var () = new_delay Dvar
-let new_univar () =
- new_delay Dunivar
+let new_univar () = new_delay Dunivar
-let rec repr =
- function
- {ddesc = Dlink i'; _} ->
- repr i'
- | i -> i
+let rec repr = function { ddesc = Dlink i'; _ } -> repr i' | i -> i
(** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type
(ensured by language syntax) *)
let split_arrow de =
match (repr de).ddesc with
- | Darrow (din,dout) -> din,dout
- (* Functions are not first order, I don't think the var case
- needs to be considered here *)
- | _ -> failwith "Internal error: not an arrow type"
+ | Darrow (din, dout) ->
+ din, dout
+ (* Functions are not first order, I don't think the var case needs to be
+ considered here *)
+ | _ ->
+ failwith "Internal error: not an arrow type"
(** Returns the type corresponding to a type list. *)
let delay_of_delay_list de =
- if (List.length de) > 1 then
- new_delay (Dtuple de)
- else
- List.hd de
+ if List.length de > 1 then new_delay (Dtuple de) else List.hd de
(** [is_polymorphic de] returns true if [de] is polymorphic. *)
let rec is_polymorphic de =
match de.ddesc with
- | Dvar -> false
- | Dundef -> false
- | Darrow (de1,de2) -> (is_polymorphic de1) || (is_polymorphic de2)
- | Dtuple dl -> List.exists is_polymorphic dl
- | Dlink d' -> is_polymorphic d'
- | Dunivar -> true
+ | Dvar ->
+ false
+ | Dundef ->
+ false
+ | Darrow (de1, de2) ->
+ is_polymorphic de1 || is_polymorphic de2
+ | Dtuple dl ->
+ List.exists is_polymorphic dl
+ | Dlink d' ->
+ is_polymorphic d'
+ | Dunivar ->
+ true
(* Pretty-print*)
open Format
-
+
let rec print_delay fmt de =
match de.ddesc with
| Dvar ->
fprintf fmt "'_%s" (name_of_type de.did)
| Dundef ->
fprintf fmt "1"
- | Darrow (de1,de2) ->
+ | Darrow (de1, de2) ->
fprintf fmt "%a->%a" print_delay de1 print_delay de2
| Dtuple delist ->
- fprintf fmt "(%a)"
- (Utils.fprintf_list ~sep:"*" print_delay) delist
+ fprintf fmt "(%a)" (Utils.fprintf_list ~sep:"*" print_delay) delist
| Dlink de ->
- print_delay fmt de
+ print_delay fmt de
| Dunivar ->
fprintf fmt "'%s" (name_of_delay de.did)
let pp_error fmt = function
- | Delay_clash (de1,de2) ->
- Utils.reset_names ();
- fprintf fmt "Expected delay %a, got delay %a@." print_delay de1 print_delay de2
+ | Delay_clash (de1, de2) ->
+ Utils.reset_names ();
+ fprintf fmt "Expected delay %a, got delay %a@." print_delay de1 print_delay
+ de2
diff --git a/src/delay_predef.ml b/src/delay_predef.ml
index c03017f39f355f7a3e0070b003049077096a4c5c..a9aa36b280f6df528003dd3c8b22e4a3b81640cd 100644
--- a/src/delay_predef.ml
+++ b/src/delay_predef.ml
@@ -9,13 +9,12 @@
(* *)
(********************************************************************)
-(** Base types and predefined operator types. *)
open Delay
+(** Base types and predefined operator types. *)
let delay_zero () = new_univar ()
-let delay_un =
- new_delay Dundef
+let delay_un = new_delay Dundef
let delay_nullary_poly_op =
let univ = new_univar () in
@@ -27,13 +26,11 @@ let delay_unary_poly_op =
let delay_binary_poly_op =
let univ = new_univar () in
- new_delay (Darrow (new_delay (Dtuple [univ;univ]), univ))
+ new_delay (Darrow (new_delay (Dtuple [ univ; univ ]), univ))
let delay_ternary_poly_op =
let univ = new_univar () in
- new_delay (Darrow (new_delay (Dtuple [univ;univ;univ]), univ))
-
-
+ new_delay (Darrow (new_delay (Dtuple [ univ; univ; univ ]), univ))
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/dune b/src/dune
index ed1caff83393afbebd48aa10dacefe8dbe109729..10452d9122f31f51c5570e924124bfd207052d34 100644
--- a/src/dune
+++ b/src/dune
@@ -1,6 +1,7 @@
(env
(dev
- (flags (:standard -warn-error -A))))
+ (flags
+ (:standard -warn-error -A))))
(include_subdirs unqualified)
@@ -8,51 +9,54 @@
(name lustrec_interface)
(package lustrec)
(modules
- lustre_types
- utils
- lustre_utils
- location
- dimension
- env
- real
- types
- options
- version
- clocks
- delay
- machine_code_types
- spec_types
- spec_common
- lustre_live
- scheduling_type
- log
- printers
- corelang
- basic_library
- type_predef
- clock_predef
- delay_predef
- error
- global
- annotations
- machine_code_common
- arrow
- options_management
- stateless
- c_backend_common
- typing
- ocaml_utils
- backends
- lustrec_mpfr
- normalization
- machine_types
- splitting
- compiler_common
- parse parser_lustre parser_lustre_table parser_lustre_messages
- lexer_lustre lexerLustreSpec
- automata
- clock_calculus
- )
+ lustre_types
+ utils
+ lustre_utils
+ location
+ dimension
+ env
+ real
+ types
+ options
+ version
+ clocks
+ delay
+ machine_code_types
+ spec_types
+ spec_common
+ lustre_live
+ scheduling_type
+ log
+ printers
+ corelang
+ basic_library
+ type_predef
+ clock_predef
+ delay_predef
+ error
+ global
+ annotations
+ machine_code_common
+ arrow
+ options_management
+ stateless
+ c_backend_common
+ typing
+ ocaml_utils
+ backends
+ lustrec_mpfr
+ normalization
+ machine_types
+ splitting
+ compiler_common
+ parse
+ parser_lustre
+ parser_lustre_table
+ parser_lustre_messages
+ lexer_lustre
+ lexerLustreSpec
+ automata
+ clock_calculus)
(wrapped false)
(libraries sites ocamlgraph zarith unix str menhirLib))
@@ -80,31 +84,44 @@
(name lustrec_lib)
(package lustrec)
(modules
- lusic
- c_backend_header c_backend_spec c_backend_makefile
- c_backend_mauve c_backend_src
- ada_backend ada_printer ada_backend_common ada_backend_ads ada_backend_adb
- ada_backend_wrapper
- horn_backend horn_backend_common horn_backend_printers
- Horn_backend_collecting_sem horn_backend_traces
- EMF_backend EMF_common EMF_library_calls
- misc_lustre_function misc_printer
- machine_code
- causality
- scheduling
- liveness
- compiler_stages
- modules
- sortProg
- inliner
- access
- algebraicLoop
- optimize_prog
- optimize_machine
- spec
- c_backend c_backend_main
- plugins
- )
+ lusic
+ c_backend_header
+ c_backend_spec
+ c_backend_makefile
+ c_backend_mauve
+ c_backend_src
+ ada_backend
+ ada_printer
+ ada_backend_common
+ ada_backend_ads
+ ada_backend_adb
+ ada_backend_wrapper
+ horn_backend
+ horn_backend_common
+ horn_backend_printers
+ Horn_backend_collecting_sem
+ horn_backend_traces
+ EMF_backend
+ EMF_common
+ EMF_library_calls
+ misc_lustre_function
+ misc_printer
+ machine_code
+ causality
+ scheduling
+ liveness
+ compiler_stages
+ modules
+ sortProg
+ inliner
+ access
+ algebraicLoop
+ optimize_prog
+ optimize_machine
+ spec
+ c_backend
+ c_backend_main
+ plugins)
(wrapped false)
(libraries sites lustrec_interface plugin_register))
@@ -139,7 +156,8 @@
(public_name lustrei)
(modules main_lustre_importer vhdl_deriving_yojson vhdl_json_lib)
(libraries yojson ppx_deriving_yojson.runtime)
- (preprocess (pps ppx_deriving_yojson)))
+ (preprocess
+ (pps ppx_deriving_yojson)))
(library
(name tools_lib)
@@ -152,20 +170,18 @@
(name sf_sem)
(public_name lustresf)
(modules
- sf_sem
- model_simple
- model_stopwatch
- CPS_ccode_generator
- CPS_transformer
- CPS_interpreter
- CPS_lustre_generator
- CPS
- theta
- memo)
+ sf_sem
+ model_simple
+ model_stopwatch
+ CPS_ccode_generator
+ CPS_transformer
+ CPS_interpreter
+ CPS_lustre_generator
+ CPS
+ theta
+ memo)
(libraries tools_lib))
-
-
; (executable
; (name main_parse_json_file)
; (public_name json-parser)
diff --git a/src/error.ml b/src/error.ml
index b0ee596c63305fb833632dcfa7783eb359a9fb51..657b616ab1cb450b026569375c7dbfb4b0e139ff 100644
--- a/src/error.ml
+++ b/src/error.ml
@@ -1,9 +1,9 @@
open Format
-
type ident = Lustre_types.ident
+
type error_kind =
- Main_not_found
+ | Main_not_found
| Main_wrong_kind
| No_main_specified
| Unbound_symbol of ident
@@ -12,62 +12,61 @@ type error_kind =
| Wrong_number of ident
| AlgebraicLoop
| LoadError of string
+
exception Error of Location.t * error_kind
let return_code kind =
match kind with
- | Main_not_found -> 2
- | Main_wrong_kind -> 3
- | No_main_specified -> 4
- | Unbound_symbol _ -> 5
- | Already_bound_symbol _ -> 6
- | Unknown_library _ -> 7
- | Wrong_number _ -> 8
- | AlgebraicLoop -> 9
- | LoadError _ -> 10
-
+ | Main_not_found ->
+ 2
+ | Main_wrong_kind ->
+ 3
+ | No_main_specified ->
+ 4
+ | Unbound_symbol _ ->
+ 5
+ | Already_bound_symbol _ ->
+ 6
+ | Unknown_library _ ->
+ 7
+ | Wrong_number _ ->
+ 8
+ | AlgebraicLoop ->
+ 9
+ | LoadError _ ->
+ 10
- let pp_error_msg fmt = function
+let pp_error_msg fmt = function
| Main_not_found ->
- fprintf fmt "Could not find the definition of main node %s.@."
- !Global.main_node
+ fprintf fmt "Could not find the definition of main node %s.@."
+ !Global.main_node
| Main_wrong_kind ->
- fprintf fmt
- "Node %s does not correspond to a valid main node definition.@."
- !Global.main_node
+ fprintf fmt "Node %s does not correspond to a valid main node definition.@."
+ !Global.main_node
| No_main_specified ->
fprintf fmt "No main node specified (use -node option)@."
| Unbound_symbol sym ->
- fprintf fmt
- "%s is undefined.@."
- sym
- | Already_bound_symbol sym ->
- fprintf fmt
- "%s is already defined.@."
- sym
+ fprintf fmt "%s is undefined.@." sym
+ | Already_bound_symbol sym ->
+ fprintf fmt "%s is already defined.@." sym
| Unknown_library sym ->
fprintf fmt
- "impossible to load library %s.lusic.@.Please compile the corresponding interface or source file.@."
+ "impossible to load library %s.lusic.@.Please compile the corresponding \
+ interface or source file.@."
sym
| Wrong_number sym ->
fprintf fmt
- "library %s.lusic has a different version number and may crash compiler.@.Please recompile the corresponding interface or source file.@."
+ "library %s.lusic has a different version number and may crash \
+ compiler.@.Please recompile the corresponding interface or source \
+ file.@."
sym
- | AlgebraicLoop -> assert false (* should have been handled yet *)
- | LoadError l ->
- fprintf fmt
- "Load error: %s.@."
- l
-
+ | AlgebraicLoop ->
+ assert false (* should have been handled yet *)
+ | LoadError l ->
+ fprintf fmt "Load error: %s.@." l
+
let pp_warning loc pp_msg =
- Format.eprintf "%a@.Warning: %t@."
- Location.pp_loc loc
- pp_msg
+ Format.eprintf "%a@.Warning: %t@." Location.pp_loc loc pp_msg
let pp_error loc pp_msg =
- Format.eprintf "@.%a@.Error: @[<v 0>%t@]@.@?"
- Location.pp_loc loc
- pp_msg
-
-
-
+ Format.eprintf "@.%a@.Error: @[<v 0>%t@]@.@?" Location.pp_loc loc pp_msg
diff --git a/src/expand.ml b/src/expand.ml
index dd5397f9debf9a11da14eeeef1b29d7bb00336c8..da0248c46c398736f2eb6bb720432bedc087bde4 100644
--- a/src/expand.ml
+++ b/src/expand.ml
@@ -19,91 +19,94 @@ let subst_var var_substs vid =
(* Applies clock substitutions *)
let rec subst_ck ck_substs var_substs ck =
match ck.cdesc with
- | Carrow (ck1,ck2) ->
- {ck with cdesc =
- Carrow (subst_ck ck_substs var_substs ck1,
- subst_ck ck_substs var_substs ck2)}
+ | Carrow (ck1, ck2) ->
+ {
+ ck with
+ cdesc =
+ Carrow
+ (subst_ck ck_substs var_substs ck1, subst_ck ck_substs var_substs ck2);
+ }
| Ctuple cklist ->
- {ck with cdesc =
- Ctuple (List.map (subst_ck ck_substs var_substs) cklist)}
- | Con (ck',c) ->
- {ck with cdesc =
- Con (subst_ck ck_substs var_substs ck',c)}
- | Connot (ck',c) ->
- {ck with cdesc =
- Connot (subst_ck ck_substs var_substs ck',c)}
- | Pck_up (ck',k) ->
- {ck with cdesc =
- Pck_up (subst_ck ck_substs var_substs ck', k)}
- | Pck_down (ck',k) ->
- {ck with cdesc =
- Pck_down (subst_ck ck_substs var_substs ck', k)}
- | Pck_phase (ck',q) ->
- {ck with cdesc =
- Pck_phase (subst_ck ck_substs var_substs ck', q)}
+ { ck with cdesc = Ctuple (List.map (subst_ck ck_substs var_substs) cklist) }
+ | Con (ck', c) ->
+ { ck with cdesc = Con (subst_ck ck_substs var_substs ck', c) }
+ | Connot (ck', c) ->
+ { ck with cdesc = Connot (subst_ck ck_substs var_substs ck', c) }
+ | Pck_up (ck', k) ->
+ { ck with cdesc = Pck_up (subst_ck ck_substs var_substs ck', k) }
+ | Pck_down (ck', k) ->
+ { ck with cdesc = Pck_down (subst_ck ck_substs var_substs ck', k) }
+ | Pck_phase (ck', q) ->
+ { ck with cdesc = Pck_phase (subst_ck ck_substs var_substs ck', q) }
| Pck_const _ ->
- ck
- | Cvar _ | Cunivar _ ->
- begin
- try Hashtbl.find ck_substs ck with Not_found -> ck
- end
+ ck
+ | Cvar _ | Cunivar _ -> (
+ try Hashtbl.find ck_substs ck with Not_found -> ck)
| Clink ck' ->
- subst_ck ck_substs var_substs ck'
- | Ccarrying (_,ck') ->
- subst_ck ck_substs var_substs ck'
+ subst_ck ck_substs var_substs ck'
+ | Ccarrying (_, ck') ->
+ subst_ck ck_substs var_substs ck'
-(* [new_expr_instance ck_substs var_substs e edesc] returns a new
- "instance" of expressions [e] of expression [e], where [edesc] is the
- expanded version of [e]. *)
+(* [new_expr_instance ck_substs var_substs e edesc] returns a new "instance" of
+ expressions [e] of expression [e], where [edesc] is the expanded version of
+ [e]. *)
let new_expr_instance ck_substs var_substs e edesc =
- {expr_tag = Utils.new_tag ();
- expr_desc = edesc;
- expr_type = e.expr_type;
- expr_clock = subst_ck ck_substs var_substs e.expr_clock;
- expr_delay = Delay.new_var ();
- expr_loc = e.expr_loc;
- expr_annot = e.expr_annot}
-
+ {
+ expr_tag = Utils.new_tag ();
+ expr_desc = edesc;
+ expr_type = e.expr_type;
+ expr_clock = subst_ck ck_substs var_substs e.expr_clock;
+ expr_delay = Delay.new_var ();
+ expr_loc = e.expr_loc;
+ expr_annot = e.expr_annot;
+ }
+
let locals_cpt = ref 0
(* Returns a new local variable (for the main node) *)
let new_local vtyp vck vdd vloc =
- let vid = "_"^(string_of_int !locals_cpt) in
- locals_cpt := !locals_cpt+1;
- let ty_dec = {ty_dec_desc = Tydec_any; ty_dec_loc = vloc} in (* dummy *)
- let ck_dec = {ck_dec_desc = Ckdec_any; ck_dec_loc = vloc} in (* dummy *)
- {var_id = vid;
- var_orig = false;
- var_dec_type = ty_dec;
- var_dec_clock = ck_dec;
- var_dec_deadline = vdd;
- var_type = vtyp;
- var_clock = vck;
- var_loc = vloc}
+ let vid = "_" ^ string_of_int !locals_cpt in
+ locals_cpt := !locals_cpt + 1;
+ let ty_dec = { ty_dec_desc = Tydec_any; ty_dec_loc = vloc } in
+ (* dummy *)
+ let ck_dec = { ck_dec_desc = Ckdec_any; ck_dec_loc = vloc } in
+ (* dummy *)
+ {
+ var_id = vid;
+ var_orig = false;
+ var_dec_type = ty_dec;
+ var_dec_clock = ck_dec;
+ var_dec_deadline = vdd;
+ var_type = vtyp;
+ var_clock = vck;
+ var_loc = vloc;
+ }
(* Returns an expression correponding to variable v *)
let expr_of_var v =
- {expr_tag = Utils.new_tag ();
- expr_desc = Expr_ident v.var_id;
- expr_type = v.var_type;
- expr_clock = v.var_clock;
- expr_delay = Delay.new_var ();
- expr_loc = v.var_loc;
- expr_annot = None}
+ {
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_ident v.var_id;
+ expr_type = v.var_type;
+ expr_clock = v.var_clock;
+ expr_delay = Delay.new_var ();
+ expr_loc = v.var_loc;
+ expr_annot = None;
+ }
-(* [build_ck_substs ck for_ck] computes the variable substitutions
- corresponding to the substitution of [ck] for [for_ck] *)
+(* [build_ck_substs ck for_ck] computes the variable substitutions corresponding
+ to the substitution of [ck] for [for_ck] *)
let build_ck_substs ck for_ck =
let substs = Hashtbl.create 10 in
let rec aux ck for_ck =
let ck, for_ck = Clocks.repr ck, Clocks.repr for_ck in
match ck.Clocks.cdesc, for_ck.Clocks.cdesc with
| Clocks.Ctuple cklist1, Clocks.Ctuple cklist2 ->
- List.iter2 aux cklist1 cklist2
+ List.iter2 aux cklist1 cklist2
| _, Clocks.Cunivar _ ->
- Hashtbl.add substs for_ck ck
- | _,_ ->
- ()
+ Hashtbl.add substs for_ck ck
+ | _, _ ->
+ ()
in
aux ck for_ck;
substs
@@ -111,179 +114,185 @@ let build_ck_substs ck for_ck =
(* Expands a list of expressions *)
let rec expand_list ck_substs var_substs elist =
List.fold_right
- (fun e (eqs,locs,elist) ->
- let eqs',locs',e' = expand_expr ck_substs var_substs e in
- eqs'@eqs,locs'@locs,e'::elist)
- elist ([],[],[])
+ (fun e (eqs, locs, elist) ->
+ let eqs', locs', e' = expand_expr ck_substs var_substs e in
+ eqs' @ eqs, locs' @ locs, e' :: elist)
+ elist ([], [], [])
(* Expands the node instance [nd(args)]. *)
and expand_nodeinst parent_ck_substs parent_vsubsts nd args =
(* Expand arguments *)
let args_eqs, args_locs, args' =
- expand_expr parent_ck_substs parent_vsubsts args in
+ expand_expr parent_ck_substs parent_vsubsts args
+ in
(* Compute clock substitutions to apply inside node's body *)
let ck_ins = args'.expr_clock in
- let for_ck_ins,_ = Clocks.split_arrow nd.node_clock in
+ let for_ck_ins, _ = Clocks.split_arrow nd.node_clock in
let ck_substs = build_ck_substs ck_ins for_ck_ins in
- (* Compute variable substitutions to apply inside node's body, due
- to the transformation of node variables into local variables of the
- main node. *)
+ (* Compute variable substitutions to apply inside node's body, due to the
+ transformation of node variables into local variables of the main node. *)
let var_substs = Hashtbl.create 10 in
- (* Add an equation in=arg for each node input + transform node input
- into a local variable of the main node *)
+ (* Add an equation in=arg for each node input + transform node input into a
+ local variable of the main node *)
let eq_ins, loc_ins =
List.split
(List.map2
(fun i e ->
let i' =
- new_local i.var_type i.var_clock i.var_dec_deadline i.var_loc in
+ new_local i.var_type i.var_clock i.var_dec_deadline i.var_loc
+ in
Hashtbl.add var_substs i.var_id i'.var_id;
- {eq_lhs = [i'.var_id];
- eq_rhs = e;
- eq_loc = i.var_loc}, i')
+ { eq_lhs = [ i'.var_id ]; eq_rhs = e; eq_loc = i.var_loc }, i')
nd.node_inputs (expr_list_of_expr args'))
in
- (* Transform node local variables into local variables of the main
- node *)
+ (* Transform node local variables into local variables of the main node *)
let loc_sub =
List.map
(fun v ->
- let v' = new_local v.var_type v.var_clock v.var_dec_deadline v.var_loc in
+ let v' =
+ new_local v.var_type v.var_clock v.var_dec_deadline v.var_loc
+ in
Hashtbl.add var_substs v.var_id v'.var_id;
v')
nd.node_locals
- in
+ in
(* Same for outputs *)
let loc_outs =
List.map
(fun o ->
- let o' = new_local o.var_type o.var_clock o.var_dec_deadline o.var_loc in
+ let o' =
+ new_local o.var_type o.var_clock o.var_dec_deadline o.var_loc
+ in
Hashtbl.add var_substs o.var_id o'.var_id;
o')
nd.node_outputs
- in
+ in
(* A tuple made of the node outputs will replace the node call in the parent
node *)
let eout = Expr_tuple (List.map expr_of_var loc_outs) in
let new_eqs, new_locals = expand_eqs ck_substs var_substs nd.node_eqs in
- args_eqs@eq_ins@new_eqs,
- args_locs@loc_ins@loc_outs@loc_sub@new_locals,
- eout
+ ( args_eqs @ eq_ins @ new_eqs,
+ args_locs @ loc_ins @ loc_outs @ loc_sub @ new_locals,
+ eout )
(* Expands an expression *)
and expand_expr ck_substs var_substs expr =
match expr.expr_desc with
| Expr_const cst ->
- [],[],new_expr_instance ck_substs var_substs expr expr.expr_desc
+ [], [], new_expr_instance ck_substs var_substs expr expr.expr_desc
| Expr_ident id ->
- let id' = subst_var var_substs id in
- let edesc = Expr_ident id' in
- [],[],new_expr_instance ck_substs var_substs expr edesc
+ let id' = subst_var var_substs id in
+ let edesc = Expr_ident id' in
+ [], [], new_expr_instance ck_substs var_substs expr edesc
| Expr_tuple elist ->
- let new_eqs,new_locals,exp_elist =
- expand_list ck_substs var_substs elist in
- new_eqs, new_locals,
- new_expr_instance ck_substs var_substs expr (Expr_tuple exp_elist)
- | Expr_fby (cst,e) ->
- let new_eqs,new_locals, e' = expand_expr ck_substs var_substs e in
- let edesc = Expr_fby (cst, e') in
- new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
- | Expr_concat (cst,e) ->
- let new_eqs,new_locals, e' = expand_expr ck_substs var_substs e in
- let edesc = Expr_concat (cst, e') in
- new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
+ let new_eqs, new_locals, exp_elist =
+ expand_list ck_substs var_substs elist
+ in
+ ( new_eqs,
+ new_locals,
+ new_expr_instance ck_substs var_substs expr (Expr_tuple exp_elist) )
+ | Expr_fby (cst, e) ->
+ let new_eqs, new_locals, e' = expand_expr ck_substs var_substs e in
+ let edesc = Expr_fby (cst, e') in
+ new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
+ | Expr_concat (cst, e) ->
+ let new_eqs, new_locals, e' = expand_expr ck_substs var_substs e in
+ let edesc = Expr_concat (cst, e') in
+ new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
| Expr_tail e ->
- let new_eqs,new_locals, e' = expand_expr ck_substs var_substs e in
- let edesc = Expr_tail e' in
- new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
- | Expr_when (e,c) ->
- let new_eqs,new_locals, e' = expand_expr ck_substs var_substs e in
- let edesc = Expr_when (e',c) in
- new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
- | Expr_whennot (e,c) ->
- let new_eqs,new_locals, e' = expand_expr ck_substs var_substs e in
- let edesc = Expr_whennot (e',c) in
- new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
- | Expr_merge (c,e1,e2) ->
- let new_eqs1,new_locals1, e1' = expand_expr ck_substs var_substs e1 in
- let new_eqs2,new_locals2, e2' = expand_expr ck_substs var_substs e2 in
- let edesc = Expr_merge (c,e1',e2') in
- new_eqs1@new_eqs2,
- new_locals1@new_locals2,
- new_expr_instance ck_substs var_substs expr edesc
- | Expr_appl (id, e, r) ->
- let decl = Hashtbl.find node_table id in
- begin
- match decl.top_decl_desc with
- | ImportedNode _ ->
- let new_eqs,new_locals, e' = expand_expr ck_substs var_substs e in
- let edesc = Expr_appl (id, e', r) in
- new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
- | Node nd ->
- let new_eqs, new_locals, outs =
- expand_nodeinst ck_substs var_substs nd e in
- new_eqs, new_locals, new_expr_instance ck_substs var_substs expr outs
- | Include _ | Consts _ | SensorDecl _ | ActuatorDecl _ -> failwith "Internal error expand_expr"
- end
- | Expr_uclock (e,k) ->
- let new_eqs, new_locals, e' = expand_expr ck_substs var_substs e in
- let edesc = Expr_uclock (e',k) in
- new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
- | Expr_dclock (e,k) ->
+ let new_eqs, new_locals, e' = expand_expr ck_substs var_substs e in
+ let edesc = Expr_tail e' in
+ new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
+ | Expr_when (e, c) ->
+ let new_eqs, new_locals, e' = expand_expr ck_substs var_substs e in
+ let edesc = Expr_when (e', c) in
+ new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
+ | Expr_whennot (e, c) ->
+ let new_eqs, new_locals, e' = expand_expr ck_substs var_substs e in
+ let edesc = Expr_whennot (e', c) in
+ new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
+ | Expr_merge (c, e1, e2) ->
+ let new_eqs1, new_locals1, e1' = expand_expr ck_substs var_substs e1 in
+ let new_eqs2, new_locals2, e2' = expand_expr ck_substs var_substs e2 in
+ let edesc = Expr_merge (c, e1', e2') in
+ ( new_eqs1 @ new_eqs2,
+ new_locals1 @ new_locals2,
+ new_expr_instance ck_substs var_substs expr edesc )
+ | Expr_appl (id, e, r) -> (
+ let decl = Hashtbl.find node_table id in
+ match decl.top_decl_desc with
+ | ImportedNode _ ->
let new_eqs, new_locals, e' = expand_expr ck_substs var_substs e in
- let edesc = Expr_dclock (e',k) in
+ let edesc = Expr_appl (id, e', r) in
new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
- | Expr_phclock (e,q) ->
- let new_eqs, new_locals, e' = expand_expr ck_substs var_substs e in
- let edesc = Expr_phclock (e',q) in
- new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
- | Expr_pre _ | Expr_arrow _ -> assert false (* Not used in the Prelude part of the code *)
+ | Node nd ->
+ let new_eqs, new_locals, outs =
+ expand_nodeinst ck_substs var_substs nd e
+ in
+ new_eqs, new_locals, new_expr_instance ck_substs var_substs expr outs
+ | Include _ | Consts _ | SensorDecl _ | ActuatorDecl _ ->
+ failwith "Internal error expand_expr")
+ | Expr_uclock (e, k) ->
+ let new_eqs, new_locals, e' = expand_expr ck_substs var_substs e in
+ let edesc = Expr_uclock (e', k) in
+ new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
+ | Expr_dclock (e, k) ->
+ let new_eqs, new_locals, e' = expand_expr ck_substs var_substs e in
+ let edesc = Expr_dclock (e', k) in
+ new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
+ | Expr_phclock (e, q) ->
+ let new_eqs, new_locals, e' = expand_expr ck_substs var_substs e in
+ let edesc = Expr_phclock (e', q) in
+ new_eqs, new_locals, new_expr_instance ck_substs var_substs expr edesc
+ | Expr_pre _ | Expr_arrow _ ->
+ assert false
+ (* Not used in the Prelude part of the code *)
(* Expands an equation *)
and expand_eq ck_substs var_substs eq =
let new_eqs, new_locals, expr = expand_expr ck_substs var_substs eq.eq_rhs in
let lhs' = List.map (subst_var var_substs) eq.eq_lhs in
- let eq' = {eq_lhs = lhs'; eq_rhs = expr; eq_loc = eq.eq_loc} in
+ let eq' = { eq_lhs = lhs'; eq_rhs = expr; eq_loc = eq.eq_loc } in
new_eqs, new_locals, eq'
(* Expands a set of equations *)
and expand_eqs ck_substs var_substs eqs =
List.fold_left
- (fun (acc_eqs,acc_locals) eq ->
+ (fun (acc_eqs, acc_locals) eq ->
let new_eqs, new_locals, eq' = expand_eq ck_substs var_substs eq in
- (eq'::(new_eqs@acc_eqs)), (new_locals@acc_locals))
- ([],[]) eqs
+ eq' :: (new_eqs @ acc_eqs), new_locals @ acc_locals)
+ ([], []) eqs
-(* Expands the body of a node, replacing recursively all the node calls
- it contains by the body of the corresponding node. *)
+(* Expands the body of a node, replacing recursively all the node calls it
+ contains by the body of the corresponding node. *)
let expand_node nd =
let new_eqs, new_locals =
- expand_eqs (Hashtbl.create 10) (Hashtbl.create 10) nd.node_eqs in
- {node_id = nd.node_id;
- node_type = nd.node_type;
- node_clock = nd.node_clock;
- node_inputs = nd.node_inputs;
- node_outputs = nd.node_outputs;
- node_locals = new_locals@nd.node_locals;
- node_asserts = nd.node_asserts;
- node_eqs = new_eqs;
- node_spec = nd.node_spec;
- node_annot = nd.node_annot}
+ expand_eqs (Hashtbl.create 10) (Hashtbl.create 10) nd.node_eqs
+ in
+ {
+ node_id = nd.node_id;
+ node_type = nd.node_type;
+ node_clock = nd.node_clock;
+ node_inputs = nd.node_inputs;
+ node_outputs = nd.node_outputs;
+ node_locals = new_locals @ nd.node_locals;
+ node_asserts = nd.node_asserts;
+ node_eqs = new_eqs;
+ node_spec = nd.node_spec;
+ node_annot = nd.node_annot;
+ }
let expand_program () =
- if !Options.main_node = "" then
- raise (Corelang.Error No_main_specified);
+ if !Options.main_node = "" then raise (Corelang.Error No_main_specified);
let main =
- try
- Hashtbl.find node_table !Options.main_node
- with Not_found ->
- raise (Corelang.Error Main_not_found)
+ try Hashtbl.find node_table !Options.main_node
+ with Not_found -> raise (Corelang.Error Main_not_found)
in
match main.top_decl_desc with
| Include _ | Consts _ | ImportedNode _ | SensorDecl _ | ActuatorDecl _ ->
- raise (Corelang.Error Main_wrong_kind)
+ raise (Corelang.Error Main_wrong_kind)
| Node nd ->
- expand_node nd
+ expand_node nd
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/features/machine_types/machine_types.ml b/src/features/machine_types/machine_types.ml
index bc7d3a3f7adef45ddcba239073771c16a00f5c0a..c7e6d53895efbef901c08d7895b35df6cce9d726 100644
--- a/src/features/machine_types/machine_types.ml
+++ b/src/features/machine_types/machine_types.ml
@@ -3,49 +3,40 @@
In each node, node local annotations can specify the actual type of the
implementation uintXX, intXX, floatXX ...
- The module provide utility functions to query the model:
- - get_var_machine_type varid nodeid returns the string denoting the actual type
-
- The actual type is used at different stages of the coompilation
- - early stage: limited typing, ie validity of operation are checked
- - a first version ensures that the actual type is a subtype of the declared/infered ones
- eg uint8 is a valid subtype of int
- - a future implementation could ensures that operations are valid
- - each standard or unspecified operation should be homogeneous :
- op: real -> real -> real is valid for any same subtype t of real: op: t -> t -> t
- - specific nodes that explicitely defined subtypes could be used to perform casts
- eg. a int2uint8 (i: int) returns (j: int) with annotations specifying i as int and j as uint8
- - C backend: any print of a typed variable should rely on the actual machine type when provided
- - EMF backend: idem
- - Horn backend: an option could enforce the bounds provided by the machine
- type or implement the cycling behavior for integer subtypes
- - Salsa plugin: the information should be propagated to the plugin.
- One can also imagine that results of the analysis could specify or
- substitute a type by a subtype. Eg. the analysis detects that a float32 is enough for variable z and
- the annotation is added to the node.
-
-
-A posisble behavior could be
-- an option to ensure type checking
-- dedicated conversion functions that, in C, would generate cast or calls to simple identity functions (to be inlined)
-
-
-
-TODO
-EMF: rajouter les memoires dans les caracteristiques du node
- gerer les types plus finement:
- propager les types machines aux variables fraiches creees par la normalisation
-
-*)
+ The module provide utility functions to query the model: -
+ get_var_machine_type varid nodeid returns the string denoting the actual type
+
+ The actual type is used at different stages of the coompilation - early
+ stage: limited typing, ie validity of operation are checked - a first version
+ ensures that the actual type is a subtype of the declared/infered ones eg
+ uint8 is a valid subtype of int - a future implementation could ensures that
+ operations are valid - each standard or unspecified operation should be
+ homogeneous : op: real -> real -> real is valid for any same subtype t of
+ real: op: t -> t -> t - specific nodes that explicitely defined subtypes
+ could be used to perform casts eg. a int2uint8 (i: int) returns (j: int) with
+ annotations specifying i as int and j as uint8 - C backend: any print of a
+ typed variable should rely on the actual machine type when provided - EMF
+ backend: idem - Horn backend: an option could enforce the bounds provided by
+ the machine type or implement the cycling behavior for integer subtypes -
+ Salsa plugin: the information should be propagated to the plugin. One can
+ also imagine that results of the analysis could specify or substitute a type
+ by a subtype. Eg. the analysis detects that a float32 is enough for variable
+ z and the annotation is added to the node.
+
+ A posisble behavior could be - an option to ensure type checking - dedicated
+ conversion functions that, in C, would generate cast or calls to simple
+ identity functions (to be inlined)
+
+ TODO EMF: rajouter les memoires dans les caracteristiques du node gerer les
+ types plus finement: propager les types machines aux variables fraiches
+ creees par la normalisation *)
open Lustre_types
let is_active = false
-
-let keyword = ["machine_types"]
-module MT =
-struct
+let keyword = [ "machine_types" ]
+module MT = struct
type int_typ =
| Tint8_t
| Tint16_t
@@ -58,25 +49,41 @@ struct
let pp_int fmt t =
match t with
- | Tint8_t -> Format.fprintf fmt "int8"
- | Tint16_t -> Format.fprintf fmt "int16"
- | Tint32_t -> Format.fprintf fmt "int32"
- | Tint64_t -> Format.fprintf fmt "int64"
- | Tuint8_t -> Format.fprintf fmt "uint8"
- | Tuint16_t -> Format.fprintf fmt "uint16"
- | Tuint32_t -> Format.fprintf fmt "uint32"
- | Tuint64_t -> Format.fprintf fmt "uint64"
+ | Tint8_t ->
+ Format.fprintf fmt "int8"
+ | Tint16_t ->
+ Format.fprintf fmt "int16"
+ | Tint32_t ->
+ Format.fprintf fmt "int32"
+ | Tint64_t ->
+ Format.fprintf fmt "int64"
+ | Tuint8_t ->
+ Format.fprintf fmt "uint8"
+ | Tuint16_t ->
+ Format.fprintf fmt "uint16"
+ | Tuint32_t ->
+ Format.fprintf fmt "uint32"
+ | Tuint64_t ->
+ Format.fprintf fmt "uint64"
let pp_c_int fmt t =
match t with
- | Tint8_t -> Format.fprintf fmt "int8_t"
- | Tint16_t -> Format.fprintf fmt "int16_t"
- | Tint32_t -> Format.fprintf fmt "int32_t"
- | Tint64_t -> Format.fprintf fmt "int64_t"
- | Tuint8_t -> Format.fprintf fmt "uint8_t"
- | Tuint16_t -> Format.fprintf fmt "uint16_t"
- | Tuint32_t -> Format.fprintf fmt "uint32_t"
- | Tuint64_t -> Format.fprintf fmt "uint64_t"
+ | Tint8_t ->
+ Format.fprintf fmt "int8_t"
+ | Tint16_t ->
+ Format.fprintf fmt "int16_t"
+ | Tint32_t ->
+ Format.fprintf fmt "int32_t"
+ | Tint64_t ->
+ Format.fprintf fmt "int64_t"
+ | Tuint8_t ->
+ Format.fprintf fmt "uint8_t"
+ | Tuint16_t ->
+ Format.fprintf fmt "uint16_t"
+ | Tuint32_t ->
+ Format.fprintf fmt "uint32_t"
+ | Tuint64_t ->
+ Format.fprintf fmt "uint64_t"
type t =
| MTint of int_typ option
@@ -85,178 +92,201 @@ struct
| MTstring
open Format
+
let pp fmt t =
match t with
| MTint None ->
- fprintf fmt "int"
+ fprintf fmt "int"
| MTint (Some s) ->
- fprintf fmt "%a" pp_int s
+ fprintf fmt "%a" pp_int s
| MTreal None ->
- fprintf fmt "real"
+ fprintf fmt "real"
| MTreal (Some s) ->
- fprintf fmt "%s" s
+ fprintf fmt "%s" s
| MTbool ->
- fprintf fmt "bool"
+ fprintf fmt "bool"
| MTstring ->
- fprintf fmt "string"
+ fprintf fmt "string"
let pp_c fmt t =
match t with
| MTint (Some s) ->
- fprintf fmt "%a" pp_c_int s
+ fprintf fmt "%a" pp_c_int s
| MTreal (Some s) ->
- fprintf fmt "%s" s
- | MTint None
- | MTreal None
- | MTbool
- | MTstring -> assert false
-
-
- let is_scalar_type t =
- match t with
- | MTbool
- | MTint _
- | MTreal _ -> true
- | _ -> false
+ fprintf fmt "%s" s
+ | MTint None | MTreal None | MTbool | MTstring ->
+ assert false
+ let is_scalar_type t =
+ match t with MTbool | MTint _ | MTreal _ -> true | _ -> false
- let is_numeric_type t =
- match t with
- | MTint _
- | MTreal _ -> true
- | _ -> false
+ let is_numeric_type t = match t with MTint _ | MTreal _ -> true | _ -> false
let is_int_type t = match t with MTint _ -> true | _ -> false
+
let is_real_type t = match t with MTreal _ -> true | _ -> false
+
let is_bool_type t = t = MTbool
-
- let is_dimension_type t =
- match t with
- | MTint _
- | MTbool -> true
- | _ -> false
+
+ let is_dimension_type t = match t with MTint _ | MTbool -> true | _ -> false
let type_int_builder = MTint None
+
let type_real_builder = MTreal None
+
let type_bool_builder = MTbool
+
let type_string_builder = MTstring
let unify _ _ = ()
+
let is_unifiable b1 b2 =
match b1, b2 with
- | MTint _ , MTint _
+ | MTint _, MTint _
| MTreal _, MTreal _
| MTstring, MTstring
- | MTbool, MTbool -> true
- | _ -> false
+ | MTbool, MTbool ->
+ true
+ | _ ->
+ false
let is_exportable b =
match b with
- | MTstring
- | MTbool
- | MTreal None
- | MTint None -> false
- | _ -> true
+ | MTstring | MTbool | MTreal None | MTint None ->
+ false
+ | _ ->
+ true
end
module MTypes = Types.Make (MT)
let type_uint8 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tuint8_t)))
+
let type_uint16 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tuint16_t)))
+
let type_uint32 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tuint32_t)))
+
let type_uint64 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tuint64_t)))
+
let type_int8 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tint8_t)))
+
let type_int16 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tint16_t)))
+
let type_int32 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tint32_t)))
+
let type_int64 = MTypes.new_ty (MTypes.Tbasic (MT.MTint (Some MT.Tint64_t)))
-
-module ConvTypes =
- struct
- type type_expr = MTypes.type_expr
-
- let map_type_basic f_basic =
- let rec map_type_basic e =
- { MTypes.tid = e.Types.tid;
- MTypes.tdesc = map_type_basic_desc (Types.type_desc e)
- }
- and map_type_basic_desc td =
- let mape = map_type_basic in
- match td with
- | Types.Tbasic b -> f_basic b
- | Types.Tconst c -> MTypes.Tconst c
- | Types.Tenum e -> MTypes.Tenum e
- | Types.Tvar -> MTypes.Tvar
- | Types.Tunivar -> MTypes.Tunivar
-
- | Types.Tclock te -> MTypes.Tclock (mape te)
- | Types.Tarrow (te1, te2) -> MTypes.Tarrow (mape te1, mape te2)
- | Types.Ttuple tel -> MTypes.Ttuple (List.map mape tel)
- | Types.Tstruct id_te_l -> MTypes.Tstruct (List.map (fun (id, te) -> id, mape te) id_te_l)
- | Types.Tarray (de, te) -> MTypes.Tarray (de, mape te)
- | Types.Tstatic (de, te) -> MTypes.Tstatic (de, mape te)
- | Types.Tlink te -> MTypes.Tlink (mape te)
- in
- map_type_basic
-
- let import main_typ =
- let import_basic b =
- if Types.BasicT.is_int_type b then MTypes.type_int else
- if Types.BasicT.is_real_type b then MTypes.type_real else
- if Types.BasicT.is_bool_type b then MTypes.type_bool else
- (Format.eprintf "importing %a with issues!@.@?" Types.print_ty main_typ; assert false)
- in
- map_type_basic import_basic main_typ
-
-
- let map_mtype_basic f_basic =
- let rec map_mtype_basic e =
- { Types.tid = e.MTypes.tid;
- Types.tdesc = map_mtype_basic_desc (MTypes.type_desc e)
- }
- and map_mtype_basic_desc td =
- let mape = map_mtype_basic in
- match td with
- | MTypes.Tbasic b ->
- (* Format.eprintf "supposely basic mtype: %a@." MTypes.BasicT.pp b; *)
- f_basic b
- | MTypes.Tconst c -> Types.Tconst c
- | MTypes.Tenum e -> Types.Tenum e
- | MTypes.Tvar -> Types.Tvar
- | MTypes.Tunivar -> Types.Tunivar
-
- | MTypes.Tclock te -> Types.Tclock (mape te)
- | MTypes.Tarrow (te1, te2) -> Types.Tarrow (mape te1, mape te2)
- | MTypes.Ttuple tel -> Types.Ttuple (List.map mape tel)
- | MTypes.Tstruct id_te_l -> Types.Tstruct (List.map (fun (id, te) -> id, mape te) id_te_l)
- | MTypes.Tarray (de, te) -> Types.Tarray (de, mape te)
- | MTypes.Tstatic (de, te) -> Types.Tstatic (de, mape te)
- | MTypes.Tlink te -> Types.Tlink (mape te)
- in
- map_mtype_basic
-
- let export machine_type =
- let export_basic b =
- if MTypes.BasicT.is_int_type b then Types.type_int else
- if MTypes.BasicT.is_real_type b then Types.type_real else
- if MTypes.BasicT.is_bool_type b then Types.type_bool else
- (
- Format.eprintf "unhandled basic mtype is %a. Issues while dealing with basic type %a@.@?" MTypes.print_ty machine_type MTypes.BasicT.pp b;
- assert false
- )
- in
- map_mtype_basic export_basic machine_type
-
- end
+module ConvTypes = struct
+ type type_expr = MTypes.type_expr
+
+ let map_type_basic f_basic =
+ let rec map_type_basic e =
+ {
+ MTypes.tid = e.Types.tid;
+ MTypes.tdesc = map_type_basic_desc (Types.type_desc e);
+ }
+ and map_type_basic_desc td =
+ let mape = map_type_basic in
+ match td with
+ | Types.Tbasic b ->
+ f_basic b
+ | Types.Tconst c ->
+ MTypes.Tconst c
+ | Types.Tenum e ->
+ MTypes.Tenum e
+ | Types.Tvar ->
+ MTypes.Tvar
+ | Types.Tunivar ->
+ MTypes.Tunivar
+ | Types.Tclock te ->
+ MTypes.Tclock (mape te)
+ | Types.Tarrow (te1, te2) ->
+ MTypes.Tarrow (mape te1, mape te2)
+ | Types.Ttuple tel ->
+ MTypes.Ttuple (List.map mape tel)
+ | Types.Tstruct id_te_l ->
+ MTypes.Tstruct (List.map (fun (id, te) -> id, mape te) id_te_l)
+ | Types.Tarray (de, te) ->
+ MTypes.Tarray (de, mape te)
+ | Types.Tstatic (de, te) ->
+ MTypes.Tstatic (de, mape te)
+ | Types.Tlink te ->
+ MTypes.Tlink (mape te)
+ in
+ map_type_basic
+
+ let import main_typ =
+ let import_basic b =
+ if Types.BasicT.is_int_type b then MTypes.type_int
+ else if Types.BasicT.is_real_type b then MTypes.type_real
+ else if Types.BasicT.is_bool_type b then MTypes.type_bool
+ else (
+ Format.eprintf "importing %a with issues!@.@?" Types.print_ty main_typ;
+ assert false)
+ in
+ map_type_basic import_basic main_typ
+
+ let map_mtype_basic f_basic =
+ let rec map_mtype_basic e =
+ {
+ Types.tid = e.MTypes.tid;
+ Types.tdesc = map_mtype_basic_desc (MTypes.type_desc e);
+ }
+ and map_mtype_basic_desc td =
+ let mape = map_mtype_basic in
+ match td with
+ | MTypes.Tbasic b ->
+ (* Format.eprintf "supposely basic mtype: %a@." MTypes.BasicT.pp b; *)
+ f_basic b
+ | MTypes.Tconst c ->
+ Types.Tconst c
+ | MTypes.Tenum e ->
+ Types.Tenum e
+ | MTypes.Tvar ->
+ Types.Tvar
+ | MTypes.Tunivar ->
+ Types.Tunivar
+ | MTypes.Tclock te ->
+ Types.Tclock (mape te)
+ | MTypes.Tarrow (te1, te2) ->
+ Types.Tarrow (mape te1, mape te2)
+ | MTypes.Ttuple tel ->
+ Types.Ttuple (List.map mape tel)
+ | MTypes.Tstruct id_te_l ->
+ Types.Tstruct (List.map (fun (id, te) -> id, mape te) id_te_l)
+ | MTypes.Tarray (de, te) ->
+ Types.Tarray (de, mape te)
+ | MTypes.Tstatic (de, te) ->
+ Types.Tstatic (de, mape te)
+ | MTypes.Tlink te ->
+ Types.Tlink (mape te)
+ in
+ map_mtype_basic
+
+ let export machine_type =
+ let export_basic b =
+ if MTypes.BasicT.is_int_type b then Types.type_int
+ else if MTypes.BasicT.is_real_type b then Types.type_real
+ else if MTypes.BasicT.is_bool_type b then Types.type_bool
+ else (
+ Format.eprintf
+ "unhandled basic mtype is %a. Issues while dealing with basic type \
+ %a@.@?"
+ MTypes.print_ty machine_type MTypes.BasicT.pp b;
+ assert false)
+ in
+ map_mtype_basic export_basic machine_type
+end
module Typing = Typing.Make (MTypes) (ConvTypes)
-
+
(* Associate to each (node_id, var_id) its machine type *)
-let machine_type_table : (var_decl, MTypes.type_expr) Hashtbl.t = Hashtbl.create 13
+let machine_type_table : (var_decl, MTypes.type_expr) Hashtbl.t =
+ Hashtbl.create 13
(* Store the node signatures, with machine types when available *)
let typing_env = ref Env.initial
-
+
let is_specified v =
(* Format.eprintf "looking for var %a@." Printers.pp_var v; *)
Hashtbl.mem machine_type_table v
@@ -264,30 +294,35 @@ let is_specified v =
let pp_table fmt =
Format.fprintf fmt "@[<v 0>[";
Hashtbl.iter
- (fun v typ -> Format.fprintf fmt "%a -> %a,@ " Printers.pp_var v MTypes.print_ty typ )
+ (fun v typ ->
+ Format.fprintf fmt "%a -> %a,@ " Printers.pp_var v MTypes.print_ty typ)
machine_type_table;
Format.fprintf fmt "@]"
-
let get_specified_type v =
(* Format.eprintf "Looking for variable %a in table [%t]@.@?" *)
(* Printers.pp_var v *)
(* pp_table; *)
- Hashtbl.find machine_type_table v
+ Hashtbl.find machine_type_table v
let is_exportable v =
- is_specified v && (
- let typ = get_specified_type v in
- match (MTypes.dynamic_type typ).MTypes.tdesc with
- | MTypes.Tbasic b -> MT.is_exportable b
- | MTypes.Tconst _ -> false (* Enumerated types are not "machine type" customizeable *)
- | _ -> assert false (* TODO deal with other constructs *)
- )
+ is_specified v
+ &&
+ let typ = get_specified_type v in
+ match (MTypes.dynamic_type typ).MTypes.tdesc with
+ | MTypes.Tbasic b ->
+ MT.is_exportable b
+ | MTypes.Tconst _ ->
+ false (* Enumerated types are not "machine type" customizeable *)
+ | _ ->
+ assert false
+
+(* TODO deal with other constructs *)
(* could depend on the actual computed type *)
-let type_name typ =
+let type_name typ =
MTypes.print_ty Format.str_formatter typ;
- Format.flush_str_formatter ()
+ Format.flush_str_formatter ()
let pp_var_type fmt v =
let typ = get_specified_type v in
@@ -296,124 +331,144 @@ let pp_var_type fmt v =
let pp_c_var_type fmt v =
let typ = get_specified_type v in
MTypes.print_ty_param MT.pp_c fmt typ
-
+
(************** Checking types ******************)
-
+
let erroneous_annotation loc =
Format.eprintf "Invalid annotation for machine_type at loc %a@."
Location.pp_loc loc;
assert false
-
let valid_subtype subtype typ =
let mismatch subtyp typ =
- Format.eprintf "Subtype mismatch %a vs %a@." MTypes.print_ty subtyp Types.print_ty typ; false
+ Format.eprintf "Subtype mismatch %a vs %a@." MTypes.print_ty subtyp
+ Types.print_ty typ;
+ false
in
match (MTypes.dynamic_type subtype).MTypes.tdesc with
- | MTypes.Tconst c -> Types.is_const_type typ c
- | MTypes.Tbasic MT.MTint _ -> Types.is_int_type typ
- | MTypes.Tbasic MT.MTreal _ -> Types.is_real_type typ
- | MTypes.Tbasic MT.MTbool -> Types.is_bool_type typ
- | _ -> mismatch subtype typ
-
+ | MTypes.Tconst c ->
+ Types.is_const_type typ c
+ | MTypes.Tbasic (MT.MTint _) ->
+ Types.is_int_type typ
+ | MTypes.Tbasic (MT.MTreal _) ->
+ Types.is_real_type typ
+ | MTypes.Tbasic MT.MTbool ->
+ Types.is_bool_type typ
+ | _ ->
+ mismatch subtype typ
+
let type_of_name name =
match name with
- | "uint8" -> type_uint8
- | "uint16" -> type_uint16
- | "uint32" -> type_uint32
- | "uint64" -> type_uint64
- | "int8" -> type_int8
- | "int16" -> type_int16
- | "int32" -> type_int32
- | "int64" -> type_int64
- | _ -> assert false (* unknown custom machine type *)
-
+ | "uint8" ->
+ type_uint8
+ | "uint16" ->
+ type_uint16
+ | "uint32" ->
+ type_uint32
+ | "uint64" ->
+ type_uint64
+ | "int8" ->
+ type_int8
+ | "int16" ->
+ type_int16
+ | "int32" ->
+ type_int32
+ | "int64" ->
+ type_int64
+ | _ ->
+ assert false
+(* unknown custom machine type *)
+
let register_var var typ =
(* let typ = type_of_name type_name in *)
- if valid_subtype typ var.var_type then (
- Hashtbl.add machine_type_table var typ
- )
- else
- erroneous_annotation var.var_loc
-
+ if valid_subtype typ var.var_type then Hashtbl.add machine_type_table var typ
+ else erroneous_annotation var.var_loc
+
(* let register_var_opt var type_name_opt = *)
(* match type_name_opt with *)
(* | None -> () *)
(* | Some type_name -> register_var var type_name *)
-
+
(************** Registering annotations ******************)
-
let register_node vars annots =
- List.fold_left (fun accu annot ->
- let annl = annot.annots in
- List.fold_left (fun accu (kwd, value) ->
- if kwd = keyword then
- let expr = value.eexpr_qfexpr in
- match Corelang.expr_list_of_expr expr with
- | [var_id; type_name] -> (
- match var_id.expr_desc, type_name.expr_desc with
- | Expr_ident var_id, Expr_const (Const_string type_name) ->
- let var = List.find (fun v -> v.var_id = var_id) vars in
- Log.report ~level:2 (fun fmt ->
- Format.fprintf fmt "Recorded type %s for variable %a (parent node is %s)@ "
- type_name
- Printers.pp_var var
- (match var.var_parent_nodeid with Some id -> id | None -> "unknown")
- );
- let typ = type_of_name type_name in
- register_var var typ;
- var::accu
- | _ -> erroneous_annotation expr.expr_loc
- )
- | _ -> erroneous_annotation expr.expr_loc
- else
- accu
- ) accu annl
- ) [] annots
-
+ List.fold_left
+ (fun accu annot ->
+ let annl = annot.annots in
+ List.fold_left
+ (fun accu (kwd, value) ->
+ if kwd = keyword then
+ let expr = value.eexpr_qfexpr in
+ match Corelang.expr_list_of_expr expr with
+ | [ var_id; type_name ] -> (
+ match var_id.expr_desc, type_name.expr_desc with
+ | Expr_ident var_id, Expr_const (Const_string type_name) ->
+ let var = List.find (fun v -> v.var_id = var_id) vars in
+ Log.report ~level:2 (fun fmt ->
+ Format.fprintf fmt
+ "Recorded type %s for variable %a (parent node is %s)@ "
+ type_name Printers.pp_var var
+ (match var.var_parent_nodeid with
+ | Some id ->
+ id
+ | None ->
+ "unknown"));
+ let typ = type_of_name type_name in
+ register_var var typ;
+ var :: accu
+ | _ ->
+ erroneous_annotation expr.expr_loc)
+ | _ ->
+ erroneous_annotation expr.expr_loc
+ else accu)
+ accu annl)
+ [] annots
let check_node nd vars =
-(* TODO check that all access to vars are valid *)
+ (* TODO check that all access to vars are valid *)
()
-
+
let type_of_vlist vars =
- let tyl = List.map (fun v -> if is_specified v then get_specified_type v else
- ConvTypes.import v.var_type
- ) vars in
+ let tyl =
+ List.map
+ (fun v ->
+ if is_specified v then get_specified_type v
+ else ConvTypes.import v.var_type)
+ vars
+ in
MTypes.type_of_type_list tyl
-
let load prog =
let init_env =
- Env.fold (fun id typ env ->
- Env.add_value env id (ConvTypes.import typ)
- )
- Basic_library.type_env Env.initial in
+ Env.fold
+ (fun id typ env -> Env.add_value env id (ConvTypes.import typ))
+ Basic_library.type_env Env.initial
+ in
let env =
- List.fold_left (fun type_env top ->
- match top.top_decl_desc with
- | Node nd ->
- (* Format.eprintf "Registeing node %s@." nd.node_id; *)
- let vars = nd.node_inputs @ nd.node_outputs @ nd.node_locals in
- let constrained_vars = register_node vars nd.node_annot in
- check_node nd constrained_vars;
-
- (* Computing the node type *)
- let ty_ins = type_of_vlist nd.node_inputs in
- let ty_outs = type_of_vlist nd.node_outputs in
- let ty_node = MTypes.new_ty (MTypes.Tarrow (ty_ins,ty_outs)) in
- Typing.generalize ty_node;
- let env = Env.add_value type_env nd.node_id ty_node in
- (* Format.eprintf "Env: %a" (Env.pp_env MTypes.print_ty) env; *)
- env
-
- | _ -> type_env
- (* | ImportedNode ind -> *)
- (* let vars = ind.nodei_inputs @ ind.nodei_outputs in *)
- (* register_node ind.nodei_id vars ind.nodei_annot *)
-(* | _ -> () TODO: shall we load something for Open statements? *)
- ) init_env prog
+ List.fold_left
+ (fun type_env top ->
+ match top.top_decl_desc with
+ | Node nd ->
+ (* Format.eprintf "Registeing node %s@." nd.node_id; *)
+ let vars = nd.node_inputs @ nd.node_outputs @ nd.node_locals in
+ let constrained_vars = register_node vars nd.node_annot in
+ check_node nd constrained_vars;
+
+ (* Computing the node type *)
+ let ty_ins = type_of_vlist nd.node_inputs in
+ let ty_outs = type_of_vlist nd.node_outputs in
+ let ty_node = MTypes.new_ty (MTypes.Tarrow (ty_ins, ty_outs)) in
+ Typing.generalize ty_node;
+ let env = Env.add_value type_env nd.node_id ty_node in
+ (* Format.eprintf "Env: %a" (Env.pp_env MTypes.print_ty) env; *)
+ env
+ | _ ->
+ type_env
+ (* | ImportedNode ind -> *)
+ (* let vars = ind.nodei_inputs @ ind.nodei_outputs in *)
+ (* register_node ind.nodei_id vars ind.nodei_annot *)
+ (* | _ -> () TODO: shall we load something for Open statements? *))
+ init_env prog
in
typing_env := env
@@ -421,61 +476,57 @@ let type_expr (parentid, init_vars) expr =
let init_env = !typing_env in
(* Format.eprintf "Init env: %a@." (Env.pp_env MTypes.print_ty) init_env; *)
(* Rebuilding the variables environment from accumulated knowledge *)
- let env,vars = (* First, we add non specified variables *)
- List.fold_left (fun (env, vars) v ->
- if not (is_specified v) then
- let env = Env.add_value env v.var_id (ConvTypes.import v.var_type) in
- env, v::vars
- else
- env, vars
- ) (init_env, []) init_vars
+ let env, vars =
+ (* First, we add non specified variables *)
+ List.fold_left
+ (fun (env, vars) v ->
+ if not (is_specified v) then
+ let env = Env.add_value env v.var_id (ConvTypes.import v.var_type) in
+ env, v :: vars
+ else env, vars)
+ (init_env, []) init_vars
in
-
+
(* Then declared ones *)
let env, vars =
- Hashtbl.fold (fun vdecl machine_type (env, vds) ->
- if vdecl.var_parent_nodeid = Some parentid then (
- (* Format.eprintf "Adding variable %a to the environement@.@?" Printers.pp_var vdecl; *)
- let env = Env.add_value env vdecl.var_id machine_type in
- env, vdecl::vds
- )
- else
- env, vds
- ) machine_type_table (env, vars)
+ Hashtbl.fold
+ (fun vdecl machine_type (env, vds) ->
+ if vdecl.var_parent_nodeid = Some parentid then
+ (* Format.eprintf "Adding variable %a to the environement@.@?"
+ Printers.pp_var vdecl; *)
+ let env = Env.add_value env vdecl.var_id machine_type in
+ env, vdecl :: vds
+ else env, vds)
+ machine_type_table (env, vars)
in
-
- (* Format.eprintf "env with local vars: %a@." (Env.pp_env MTypes.print_ty) env; *)
+ (* Format.eprintf "env with local vars: %a@." (Env.pp_env MTypes.print_ty)
+ env; *)
(* Format.eprintf "expr = %a@." Printers.pp_expr expr; *)
(* let res = *)
- Typing.type_expr
- (env,vars)
- false (* not in main node *)
- false (* no a constant *)
- expr
- (* in *)
- (* Format.eprintf "typing ok = %a@." MTypes.print_ty res; *)
- (* res *)
-
-(* Typing the expression (vars = expr) in node
-
-*)
+ Typing.type_expr (env, vars) false (* not in main node *) false
+ (* no a constant *) expr
+
+(* in *)
+(* Format.eprintf "typing ok = %a@." MTypes.print_ty res; *)
+(* res *)
+
+(* Typing the expression (vars = expr) in node *)
let type_def node vars expr =
(* Format.eprintf "Typing def %a = %a@.@." *)
(* (Utils.fprintf_list ~sep:", " Printers.pp_var) vars *)
(* Printers.pp_expr expr *)
(* ; *)
- let typ = type_expr node expr in
- (* Format.eprintf "Type is %a. Saving stuff@.@." MTypes.print_ty typ; *)
- let typ = MTypes.type_list_of_type typ in
- List.iter2 register_var vars typ
+ let typ = type_expr node expr in
+ (* Format.eprintf "Type is %a. Saving stuff@.@." MTypes.print_ty typ; *)
+ let typ = MTypes.type_list_of_type typ in
+ List.iter2 register_var vars typ
let has_machine_type () =
let annl = Annotations.get_expr_annotations keyword in
(* Format.eprintf "has _mchine _type annotations: %i@." (List.length annl); *)
List.length annl > 0
-
+
(* Local Variables: *)
(* compile-command:"make -C ../.." *)
(* End: *)
-
diff --git a/src/global.ml b/src/global.ml
index cad402379b20774bb6a36ea7307f66b9e2e3d42a..95cc5a64006ee523855a897f74e089a1faa88b90 100644
--- a/src/global.ml
+++ b/src/global.ml
@@ -1,22 +1,26 @@
module Types = Types.Main
-let type_env : (Types.type_expr Env.t) ref = ref Env.initial (* Basic_library.type_env *)
-let clock_env : (Clocks.clock_expr Env.t) ref = ref Env.initial (*Basic_library.clock_env *)
+let type_env : Types.type_expr Env.t ref = ref Env.initial
+(* Basic_library.type_env *)
+
+let clock_env : Clocks.clock_expr Env.t ref = ref Env.initial
+(*Basic_library.clock_env *)
+
let basename = ref ""
+
let main_node = ref ""
-module TypeEnv =
- struct
- let lookup_value ident = Env.lookup_value !type_env ident
- let exists_value ident = Env.exists_value !type_env ident
- let iter f = Env.iter !type_env f
- let pp pp_fun fmt () = Env.pp_env pp_fun fmt !type_env
- end
-
-let initialize () =
- begin
- main_node := !Options.main_node;
- end
+module TypeEnv = struct
+ let lookup_value ident = Env.lookup_value !type_env ident
+
+ let exists_value ident = Env.exists_value !type_env ident
+
+ let iter f = Env.iter !type_env f
+
+ let pp pp_fun fmt () = Env.pp_env pp_fun fmt !type_env
+end
+
+let initialize () = main_node := !Options.main_node
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/init_predef.ml b/src/init_predef.ml
index 0bab5149e2220ff089ad6a8d35a5a20a19c09939..9c9c2115d398d3908bdec2888fd2e3702d397df8 100644
--- a/src/init_predef.ml
+++ b/src/init_predef.ml
@@ -9,25 +9,26 @@
(* *)
(********************************************************************)
-
-(** Base types and predefined operator types. *)
open Init
+(** Base types and predefined operator types. *)
let init_zero = new_univar ()
let init_un =
let univ = new_univar () in
- new_init Isucc(univ)
+ new_init Isucc univ
-let rec init_omega =
- { init_desc = Isucc init_omega ; iid = -1 }
+let rec init_omega = { init_desc = Isucc init_omega; iid = -1 }
let is_omega init =
let rec search path init =
- match init.init_desc with
- | Isucc init' -> List.mem init path or search (init::path) init'
- | _ -> false
- in search [] init
+ match init.init_desc with
+ | Isucc init' ->
+ List.mem init path or search (init :: path) init'
+ | _ ->
+ false
+ in
+ search [] init
let init_unary_poly_op =
let univ = new_univar () in
@@ -39,34 +40,56 @@ let init_pre_op =
let init_arrow_op =
let univ = new_univar () in
- new_init (Iarrow (new_init (Ituple [univ; init_un]), univ))
+ new_init (Iarrow (new_init (Ituple [ univ; init_un ]), univ))
let init_fby_op_1 =
let univ = new_univar () in
- new_init (Iarrow (init_zero,init_zero))
+ new_init (Iarrow (init_zero, init_zero))
-let init_fby_op_2 =
- init_pre_op
+let init_fby_op_2 = init_pre_op
let init_bin_poly_op =
let univ = new_univar () in
- new_init (Iarrow (new_init (Ituple [univ;univ]), univ))
+ new_init (Iarrow (new_init (Ituple [ univ; univ ]), univ))
let init_ter_poly_op =
let univ = new_univar () in
- new_init (Iarrow (new_init (Ituple [univ;univ;univ]), univ))
+ new_init (Iarrow (new_init (Ituple [ univ; univ; univ ]), univ))
let env =
let init_env = Env.initial in
- let env' =
- List.fold_right (fun op env -> Env.add_value env op init_unary_poly_op)
- ["uminus"; "not"] init_env in
- let env' =
- List.fold_right (fun op env -> Env.add_value env op init_binary_poly_op)
- ["+"; "-"; "*"; "/"; "mod"; "&&"; "||"; "xor"; "impl"; "<"; "<="; ">"; ">="; "!="; "="] env' in
- let env' =
- List.fold_right (fun op env -> Env.add_value env op init_ternary_poly_op)
- ["ite"] init_env in
+ let env' =
+ List.fold_right
+ (fun op env -> Env.add_value env op init_unary_poly_op)
+ [ "uminus"; "not" ] init_env
+ in
+ let env' =
+ List.fold_right
+ (fun op env -> Env.add_value env op init_binary_poly_op)
+ [
+ "+";
+ "-";
+ "*";
+ "/";
+ "mod";
+ "&&";
+ "||";
+ "xor";
+ "impl";
+ "<";
+ "<=";
+ ">";
+ ">=";
+ "!=";
+ "=";
+ ]
+ env'
+ in
+ let env' =
+ List.fold_right
+ (fun op env -> Env.add_value env op init_ternary_poly_op)
+ [ "ite" ] init_env
+ in
env'
(* Local Variables: *)
diff --git a/src/inliner.ml b/src/inliner.ml
index 1b8a90330c0495108537e71081ae1af5986fdd7b..fb31a3deecd3d9cc7a6eff2b85680565f0c4b28f 100644
--- a/src/inliner.ml
+++ b/src/inliner.ml
@@ -14,518 +14,598 @@ open Corelang
open Utils
(* Local annotations are declared with the following key /inlining/: true *)
-let keyword = ["inlining"]
+let keyword = [ "inlining" ]
-let is_inline_expr expr =
-match expr.expr_annot with
-| Some ann ->
- List.exists (fun (key, _) -> key = keyword) ann.annots
-| None -> false
+let is_inline_expr expr =
+ match expr.expr_annot with
+ | Some ann ->
+ List.exists (fun (key, _) -> key = keyword) ann.annots
+ | None ->
+ false
-let check_node_name id = (fun t ->
- match t.top_decl_desc with
- | Node nd -> nd.node_id = id
- | _ -> false)
+let check_node_name id t =
+ match t.top_decl_desc with Node nd -> nd.node_id = id | _ -> false
let is_node_var node v =
- try
- ignore (Corelang.get_node_var v node); true
- with Not_found -> false
+ try
+ ignore (Corelang.get_node_var v node);
+ true
+ with Not_found -> false
(* let rename_expr rename expr = expr_replace_var rename expr *)
-(*
-let rename_eq rename eq =
- { eq with
- eq_lhs = List.map rename eq.eq_lhs;
- eq_rhs = rename_expr rename eq.eq_rhs
- }
-*)
-
+(* let rename_eq rename eq = { eq with eq_lhs = List.map rename eq.eq_lhs;
+ eq_rhs = rename_expr rename eq.eq_rhs } *)
+
let rec add_expr_reset_cond cond expr =
let aux = add_expr_reset_cond cond in
- let new_desc =
+ let new_desc =
match expr.expr_desc with
- | Expr_const _
- | Expr_ident _ -> expr.expr_desc
- | Expr_tuple el -> Expr_tuple (List.map aux el)
- | Expr_ite (c, t, e) -> Expr_ite (aux c, aux t, aux e)
-
- | Expr_arrow (e1, e2) ->
+ | Expr_const _ | Expr_ident _ ->
+ expr.expr_desc
+ | Expr_tuple el ->
+ Expr_tuple (List.map aux el)
+ | Expr_ite (c, t, e) ->
+ Expr_ite (aux c, aux t, aux e)
+ | Expr_arrow (e1, e2) ->
(* we replace the expression e1 -> e2 by e1 -> (if cond then e1 else e2) *)
let e1 = aux e1 and e2 = aux e2 in
(* inlining is performed before typing. we can leave the fields free *)
let new_e2 = mkexpr expr.expr_loc (Expr_ite (cond, e1, e2)) in
- Expr_arrow (e1, new_e2)
-
- | Expr_fby _ -> assert false (* TODO: deal with fby. This hasn't been much handled yet *)
-
- | Expr_array el -> Expr_array (List.map aux el)
- | Expr_access (e, dim) -> Expr_access (aux e, dim)
- | Expr_power (e, dim) -> Expr_power (aux e, dim)
- | Expr_pre e -> Expr_pre (aux e)
- | Expr_when (e, id, l) -> Expr_when (aux e, id, l)
- | Expr_merge (id, cases) -> Expr_merge (id, List.map (fun (l,e) -> l, aux e) cases)
-
- | Expr_appl (id, args, reset_opt) ->
+ Expr_arrow (e1, new_e2)
+ | Expr_fby _ ->
+ assert false (* TODO: deal with fby. This hasn't been much handled yet *)
+ | Expr_array el ->
+ Expr_array (List.map aux el)
+ | Expr_access (e, dim) ->
+ Expr_access (aux e, dim)
+ | Expr_power (e, dim) ->
+ Expr_power (aux e, dim)
+ | Expr_pre e ->
+ Expr_pre (aux e)
+ | Expr_when (e, id, l) ->
+ Expr_when (aux e, id, l)
+ | Expr_merge (id, cases) ->
+ Expr_merge (id, List.map (fun (l, e) -> l, aux e) cases)
+ | Expr_appl (id, args, reset_opt) ->
(* we "add" cond to the reset field. *)
- let new_reset = match reset_opt with
- None -> cond
- | Some cond' -> mkpredef_call cond'.expr_loc "||" [cond; cond']
+ let new_reset =
+ match reset_opt with
+ | None ->
+ cond
+ | Some cond' ->
+ mkpredef_call cond'.expr_loc "||" [ cond; cond' ]
in
Expr_appl (id, args, Some new_reset)
-
-
in
+
{ expr with expr_desc = new_desc }
let add_eq_reset_cond cond eq =
{ eq with eq_rhs = add_expr_reset_cond cond eq.eq_rhs }
-(*
-let get_static_inputs input_arg_list =
- List.fold_right (fun (vdecl, arg) res ->
- if vdecl.var_dec_const
- then (vdecl.var_id, Corelang.dimension_of_expr arg) :: res
- else res)
- input_arg_list []
-
-let get_carrier_inputs input_arg_list =
- List.fold_right (fun (vdecl, arg) res ->
- if Corelang.is_clock_dec_type vdecl.var_dec_type.ty_dec_desc
- then (vdecl.var_id, ident_of_expr arg) :: res
- else res)
- input_arg_list []
-*)
-(*
- expr, locals', eqs = inline_call id args' reset locals node nodes
-
-We select the called node equations and variables.
- renamed_inputs = args
+(* let get_static_inputs input_arg_list = List.fold_right (fun (vdecl, arg) res
+ -> if vdecl.var_dec_const then (vdecl.var_id, Corelang.dimension_of_expr arg)
+ :: res else res) input_arg_list []
+
+ let get_carrier_inputs input_arg_list = List.fold_right (fun (vdecl, arg) res
+ -> if Corelang.is_clock_dec_type vdecl.var_dec_type.ty_dec_desc then
+ (vdecl.var_id, ident_of_expr arg) :: res else res) input_arg_list [] *)
+(* expr, locals', eqs = inline_call id args' reset locals node nodes
+
+ We select the called node equations and variables. renamed_inputs = args
renamed_eqs
-the resulting expression is tuple_of_renamed_outputs
-
-TODO: convert the specification/annotation/assert and inject them
-*)
+ the resulting expression is tuple_of_renamed_outputs
+
+ TODO: convert the specification/annotation/assert and inject them *)
(** [inline_call node loc uid args reset locals caller] returns a tuple (expr,
- locals, eqs, asserts)
-*)
+ locals, eqs, asserts) *)
let inline_call node loc uid args reset locals caller =
let rename v =
- if v = tag_true || v = tag_false || not (is_node_var node v) then v else
- Corelang.mk_new_node_name caller (Format.sprintf "%s_%i_%s" node.node_id uid v)
+ if v = tag_true || v = tag_false || not (is_node_var node v) then v
+ else
+ Corelang.mk_new_node_name caller
+ (Format.sprintf "%s_%i_%s" node.node_id uid v)
in
let eqs, auts = get_node_eqs node in
let eqs' = List.map (rename_eq (fun x -> x) rename) eqs in
let auts' = List.map (rename_aut (fun x -> x) rename) auts in
- let input_arg_list = List.combine node.node_inputs (Corelang.expr_list_of_expr args) in
- let static_inputs, dynamic_inputs = List.partition (fun (vdecl, _) -> vdecl.var_dec_const) input_arg_list in
- let static_inputs = List.map (fun (vdecl, arg) -> vdecl, Corelang.dimension_of_expr arg) static_inputs in
- let carrier_inputs, _ = List.partition (fun (vdecl, _) -> Corelang.is_clock_dec_type vdecl.var_dec_type.ty_dec_desc) dynamic_inputs in
- let carrier_inputs = List.map (fun (vdecl, arg) -> vdecl, Corelang.ident_of_expr arg) carrier_inputs in
+ let input_arg_list =
+ List.combine node.node_inputs (Corelang.expr_list_of_expr args)
+ in
+ let static_inputs, dynamic_inputs =
+ List.partition (fun (vdecl, _) -> vdecl.var_dec_const) input_arg_list
+ in
+ let static_inputs =
+ List.map
+ (fun (vdecl, arg) -> vdecl, Corelang.dimension_of_expr arg)
+ static_inputs
+ in
+ let carrier_inputs, _ =
+ List.partition
+ (fun (vdecl, _) ->
+ Corelang.is_clock_dec_type vdecl.var_dec_type.ty_dec_desc)
+ dynamic_inputs
+ in
+ let carrier_inputs =
+ List.map
+ (fun (vdecl, arg) -> vdecl, Corelang.ident_of_expr arg)
+ carrier_inputs
+ in
let rename_static v =
- try
- snd (List.find (fun (vdecl, _) -> v = vdecl.var_id) static_inputs)
- with Not_found -> Dimension.mkdim_ident loc v in
+ try snd (List.find (fun (vdecl, _) -> v = vdecl.var_id) static_inputs)
+ with Not_found -> Dimension.mkdim_ident loc v
+ in
let rename_carrier v =
- try
- snd (List.find (fun (vdecl, _) -> v = vdecl.var_id) carrier_inputs)
- with Not_found -> v in
+ try snd (List.find (fun (vdecl, _) -> v = vdecl.var_id) carrier_inputs)
+ with Not_found -> v
+ in
let rename_var v =
let vdecl =
Corelang.mkvar_decl v.var_loc
- (rename v.var_id,
- { v.var_dec_type with ty_dec_desc = Corelang.rename_static rename_static v.var_dec_type.ty_dec_desc },
- { v.var_dec_clock with ck_dec_desc = Corelang.rename_carrier rename_carrier v.var_dec_clock.ck_dec_desc },
- v.var_dec_const,
- Utils.option_map (rename_expr (fun x -> x) rename) v.var_dec_value,
- v.var_parent_nodeid (* we keep the original parent name *)
- ) in
- begin
- (*
- (try
- Format.eprintf "Inliner.inline_call unify %a %a@." Types.print_ty vdecl.var_type Dimension.pp_dimension (List.assoc v.var_id static_inputs);
- Typing.unify vdecl.var_type (Type_predef.type_static (List.assoc v.var_id static_inputs) (Types.new_var ()))
- with Not_found -> ());
- (try
- Clock_calculus.unify vdecl.var_clock (Clock_predef.ck_carrier (List.assoc v.var_id carrier_inputs) (Clocks.new_var true))
- with Not_found -> ());
- (*Format.eprintf "Inliner.inline_call res=%a@." Printers.pp_var vdecl;*)
- *)
- vdecl
- end
+ ( rename v.var_id,
+ {
+ v.var_dec_type with
+ ty_dec_desc =
+ Corelang.rename_static rename_static v.var_dec_type.ty_dec_desc;
+ },
+ {
+ v.var_dec_clock with
+ ck_dec_desc =
+ Corelang.rename_carrier rename_carrier v.var_dec_clock.ck_dec_desc;
+ },
+ v.var_dec_const,
+ Utils.option_map (rename_expr (fun x -> x) rename) v.var_dec_value,
+ v.var_parent_nodeid (* we keep the original parent name *) )
+ in
+ (* (try Format.eprintf "Inliner.inline_call unify %a %a@." Types.print_ty
+ vdecl.var_type Dimension.pp_dimension (List.assoc v.var_id
+ static_inputs); Typing.unify vdecl.var_type (Type_predef.type_static
+ (List.assoc v.var_id static_inputs) (Types.new_var ())) with Not_found ->
+ ()); (try Clock_calculus.unify vdecl.var_clock (Clock_predef.ck_carrier
+ (List.assoc v.var_id carrier_inputs) (Clocks.new_var true)) with
+ Not_found -> ()); (*Format.eprintf "Inliner.inline_call res=%a@."
+ Printers.pp_var vdecl;*) *)
+ vdecl
(*Format.eprintf "Inliner.rename_var %a@." Printers.pp_var v;*)
in
let inputs' = List.map (fun (vdecl, _) -> rename_var vdecl) dynamic_inputs in
let outputs' = List.map rename_var node.node_outputs in
let locals' =
- (List.map (fun (vdecl, arg) -> let vdecl' = rename_var vdecl in { vdecl' with var_dec_value = Some (Corelang.expr_of_dimension arg) }) static_inputs)
- @ (List.map rename_var node.node_locals)
-in
+ List.map
+ (fun (vdecl, arg) ->
+ let vdecl' = rename_var vdecl in
+ { vdecl' with var_dec_value = Some (Corelang.expr_of_dimension arg) })
+ static_inputs
+ @ List.map rename_var node.node_locals
+ in
(* checking we are at the appropriate (early) step: node_checks and
node_gencalls should be empty (not yet assigned) *)
assert (node.node_checks = []);
assert (node.node_gencalls = []);
(* Expressing reset locally in equations *)
- let eqs_r' =
- let all_eqs = (List.map (fun eq -> Eq eq) eqs') @ (List.map (fun aut -> Aut aut) auts') in
+ let eqs_r' =
+ let all_eqs =
+ List.map (fun eq -> Eq eq) eqs' @ List.map (fun aut -> Aut aut) auts'
+ in
match reset with
- None -> all_eqs
- | Some cond -> (
- assert (auts' = []); (* TODO: we do not handle properly automaton in case of reset call *)
+ | None ->
+ all_eqs
+ | Some cond ->
+ assert (auts' = []);
+ (* TODO: we do not handle properly automaton in case of reset call *)
List.map (fun eq -> Eq (add_eq_reset_cond cond eq)) eqs'
- )
- in
- let assign_inputs = Eq (mkeq loc (List.map (fun v -> v.var_id) inputs',
- expr_of_expr_list args.expr_loc (List.map snd dynamic_inputs))) in
- let expr = expr_of_expr_list loc (List.map expr_of_vdecl outputs')
in
- let asserts' = (* We rename variables in assert expressions *)
- List.map
- (fun a ->
- {a with assert_expr =
- let expr = a.assert_expr in
- rename_expr (fun x -> x) rename expr
- })
- node.node_asserts
+ let assign_inputs =
+ Eq
+ (mkeq loc
+ ( List.map (fun v -> v.var_id) inputs',
+ expr_of_expr_list args.expr_loc (List.map snd dynamic_inputs) ))
in
- let annots' =
- Plugins.inline_annots rename node.node_annot
+ let expr = expr_of_expr_list loc (List.map expr_of_vdecl outputs') in
+ let asserts' =
+ (* We rename variables in assert expressions *)
+ List.map
+ (fun a ->
+ {
+ a with
+ assert_expr =
+ (let expr = a.assert_expr in
+ rename_expr (fun x -> x) rename expr);
+ })
+ node.node_asserts
in
- expr,
- inputs'@outputs'@locals'@locals,
- assign_inputs::eqs_r',
- asserts',
- annots'
-
-
+ let annots' = Plugins.inline_annots rename node.node_annot in
+ ( expr,
+ inputs' @ outputs' @ locals' @ locals,
+ assign_inputs :: eqs_r',
+ asserts',
+ annots' )
let inline_table = Hashtbl.create 23
-(*
- new_expr, new_locals, new_eqs = inline_expr expr locals node nodes
-
+(* new_expr, new_locals, new_eqs = inline_expr expr locals node nodes
+
Each occurence of a node in nodes in the expr should be replaced by fresh
- variables and the code of called node instance added to new_eqs
-
-*)
-let rec inline_expr ?(selection_on_annotation=false) expr locals node nodes =
- let inline_expr = inline_expr ~selection_on_annotation:selection_on_annotation in
- let inline_node = inline_node ~selection_on_annotation:selection_on_annotation in
- let inline_tuple el =
- List.fold_right (fun e (el_tail, locals, eqs, asserts, annots) ->
- let e', locals', eqs', asserts', annots' = inline_expr e locals node nodes in
- e'::el_tail, locals', eqs'@eqs, asserts@asserts', annots@annots'
- ) el ([], locals, [], [], [])
- in
- let inline_pair e1 e2 =
- let el', l', eqs', asserts', annots' = inline_tuple [e1;e2] in
+ variables and the code of called node instance added to new_eqs *)
+let rec inline_expr ?(selection_on_annotation = false) expr locals node nodes =
+ let inline_expr = inline_expr ~selection_on_annotation in
+ let inline_node = inline_node ~selection_on_annotation in
+ let inline_tuple el =
+ List.fold_right
+ (fun e (el_tail, locals, eqs, asserts, annots) ->
+ let e', locals', eqs', asserts', annots' =
+ inline_expr e locals node nodes
+ in
+ e' :: el_tail, locals', eqs' @ eqs, asserts @ asserts', annots @ annots')
+ el ([], locals, [], [], [])
+ in
+ let inline_pair e1 e2 =
+ let el', l', eqs', asserts', annots' = inline_tuple [ e1; e2 ] in
match el' with
- | [e1'; e2'] -> e1', e2', l', eqs', asserts', annots'
- | _ -> assert false
+ | [ e1'; e2' ] ->
+ e1', e2', l', eqs', asserts', annots'
+ | _ ->
+ assert false
in
- let inline_triple e1 e2 e3 =
- let el', l', eqs', asserts', annots' = inline_tuple [e1;e2;e3] in
+ let inline_triple e1 e2 e3 =
+ let el', l', eqs', asserts', annots' = inline_tuple [ e1; e2; e3 ] in
match el' with
- | [e1'; e2'; e3'] -> e1', e2', e3', l', eqs', asserts', annots'
- | _ -> assert false
+ | [ e1'; e2'; e3' ] ->
+ e1', e2', e3', l', eqs', asserts', annots'
+ | _ ->
+ assert false
in
-
+
match expr.expr_desc with
| Expr_appl (id, args, reset) ->
- let args', locals', eqs', asserts', annots' = inline_expr args locals node nodes in
- if List.exists (check_node_name id) nodes && (* the current node call is provided
- as arguments nodes *)
- (not selection_on_annotation || is_inline_expr expr) (* and if selection on annotation is activated,
- it is explicitely inlined here *)
- then (
- (* Format.eprintf "Inlining call to %s in expression %a@." id Printers.pp_expr expr; *)
- (* The node should be inlined *)
- (* let _ = Format.eprintf "Inlining call to %s@." id in *)
- let called = try List.find (check_node_name id) nodes
- with Not_found -> (assert false) in
- let called = node_of_top called in
- let called' = inline_node called nodes in
- let expr, locals', eqs'', asserts'', annots'' =
- inline_call called' expr.expr_loc expr.expr_tag args' reset locals' node in
- expr, locals', eqs'@eqs'', asserts'@asserts'', annots'@annots''
- )
- else
- (* let _ = Format.eprintf "Not inlining call to %s@." id in *)
- { expr with expr_desc = Expr_appl(id, args', reset)},
- locals',
- eqs',
- asserts',
- annots'
-
+ let args', locals', eqs', asserts', annots' =
+ inline_expr args locals node nodes
+ in
+ if
+ List.exists (check_node_name id) nodes
+ && (* the current node call is provided as arguments nodes *)
+ ((not selection_on_annotation) || is_inline_expr expr)
+ (* and if selection on annotation is activated, it is explicitely inlined
+ here *)
+ then
+ (* Format.eprintf "Inlining call to %s in expression %a@." id
+ Printers.pp_expr expr; *)
+ (* The node should be inlined *)
+ (* let _ = Format.eprintf "Inlining call to %s@." id in *)
+ let called =
+ try List.find (check_node_name id) nodes
+ with Not_found -> assert false
+ in
+ let called = node_of_top called in
+ let called' = inline_node called nodes in
+ let expr, locals', eqs'', asserts'', annots'' =
+ inline_call called' expr.expr_loc expr.expr_tag args' reset locals' node
+ in
+ expr, locals', eqs' @ eqs'', asserts' @ asserts'', annots' @ annots''
+ else
+ (* let _ = Format.eprintf "Not inlining call to %s@." id in *)
+ ( { expr with expr_desc = Expr_appl (id, args', reset) },
+ locals',
+ eqs',
+ asserts',
+ annots' )
(* For other cases, we just keep the structure, but convert sub-expressions *)
- | Expr_const _
- | Expr_ident _ -> expr, locals, [], [], []
- | Expr_tuple el ->
- let el', l', eqs', asserts', annots' = inline_tuple el in
- { expr with expr_desc = Expr_tuple el' }, l', eqs', asserts', annots'
+ | Expr_const _ | Expr_ident _ ->
+ expr, locals, [], [], []
+ | Expr_tuple el ->
+ let el', l', eqs', asserts', annots' = inline_tuple el in
+ { expr with expr_desc = Expr_tuple el' }, l', eqs', asserts', annots'
| Expr_ite (g, t, e) ->
- let g', t', e', l', eqs', asserts', annots' = inline_triple g t e in
- { expr with expr_desc = Expr_ite (g', t', e') }, l', eqs', asserts', annots'
+ let g', t', e', l', eqs', asserts', annots' = inline_triple g t e in
+ { expr with expr_desc = Expr_ite (g', t', e') }, l', eqs', asserts', annots'
| Expr_arrow (e1, e2) ->
- let e1', e2', l', eqs', asserts', annots' = inline_pair e1 e2 in
- { expr with expr_desc = Expr_arrow (e1', e2') } , l', eqs', asserts', annots'
+ let e1', e2', l', eqs', asserts', annots' = inline_pair e1 e2 in
+ { expr with expr_desc = Expr_arrow (e1', e2') }, l', eqs', asserts', annots'
| Expr_fby (e1, e2) ->
- let e1', e2', l', eqs', asserts', annots' = inline_pair e1 e2 in
- { expr with expr_desc = Expr_fby (e1', e2') }, l', eqs', asserts', annots'
+ let e1', e2', l', eqs', asserts', annots' = inline_pair e1 e2 in
+ { expr with expr_desc = Expr_fby (e1', e2') }, l', eqs', asserts', annots'
| Expr_array el ->
- let el', l', eqs', asserts', annots' = inline_tuple el in
- { expr with expr_desc = Expr_array el' }, l', eqs', asserts', annots'
+ let el', l', eqs', asserts', annots' = inline_tuple el in
+ { expr with expr_desc = Expr_array el' }, l', eqs', asserts', annots'
| Expr_access (e, dim) ->
- let e', l', eqs', asserts', annots' = inline_expr e locals node nodes in
- { expr with expr_desc = Expr_access (e', dim) }, l', eqs', asserts', annots'
+ let e', l', eqs', asserts', annots' = inline_expr e locals node nodes in
+ { expr with expr_desc = Expr_access (e', dim) }, l', eqs', asserts', annots'
| Expr_power (e, dim) ->
- let e', l', eqs', asserts', annots' = inline_expr e locals node nodes in
- { expr with expr_desc = Expr_power (e', dim) }, l', eqs', asserts', annots'
+ let e', l', eqs', asserts', annots' = inline_expr e locals node nodes in
+ { expr with expr_desc = Expr_power (e', dim) }, l', eqs', asserts', annots'
| Expr_pre e ->
- let e', l', eqs', asserts', annots' = inline_expr e locals node nodes in
- { expr with expr_desc = Expr_pre e' }, l', eqs', asserts', annots'
+ let e', l', eqs', asserts', annots' = inline_expr e locals node nodes in
+ { expr with expr_desc = Expr_pre e' }, l', eqs', asserts', annots'
| Expr_when (e, id, label) ->
- let e', l', eqs', asserts', annots' = inline_expr e locals node nodes in
- { expr with expr_desc = Expr_when (e', id, label) }, l', eqs', asserts', annots'
+ let e', l', eqs', asserts', annots' = inline_expr e locals node nodes in
+ ( { expr with expr_desc = Expr_when (e', id, label) },
+ l',
+ eqs',
+ asserts',
+ annots' )
| Expr_merge (id, branches) ->
- let el, l', eqs', asserts', annots' = inline_tuple (List.map snd branches) in
- let branches' = List.map2 (fun (label, _) v -> label, v) branches el in
- { expr with expr_desc = Expr_merge (id, branches') }, l', eqs', asserts', annots'
-
-and inline_node ?(selection_on_annotation=false) node nodes =
+ let el, l', eqs', asserts', annots' =
+ inline_tuple (List.map snd branches)
+ in
+ let branches' = List.map2 (fun (label, _) v -> label, v) branches el in
+ ( { expr with expr_desc = Expr_merge (id, branches') },
+ l',
+ eqs',
+ asserts',
+ annots' )
+
+and inline_node ?(selection_on_annotation = false) node nodes =
try copy_node (Hashtbl.find inline_table node.node_id)
with Not_found ->
- let inline_expr = inline_expr ~selection_on_annotation:selection_on_annotation in
+ let inline_expr = inline_expr ~selection_on_annotation in
let eqs, auts = get_node_eqs node in
- assert (auts = []); (* No inlining of automaton yet. One should visit each
- handler eqs and perform similar computation *)
- let new_locals, stmts, asserts, annots =
- List.fold_left (fun (locals, stmts, asserts, annots) eq ->
- let eq_rhs', locals', new_stmts', asserts', annots' =
- inline_expr eq.eq_rhs locals node nodes
- in
- locals', Eq { eq with eq_rhs = eq_rhs' }::new_stmts'@stmts, asserts'@asserts, annots'@annots
- ) (node.node_locals, [], node.node_asserts, node.node_annot) eqs
+ assert (auts = []);
+ (* No inlining of automaton yet. One should visit each handler eqs and
+ perform similar computation *)
+ let new_locals, stmts, asserts, annots =
+ List.fold_left
+ (fun (locals, stmts, asserts, annots) eq ->
+ let eq_rhs', locals', new_stmts', asserts', annots' =
+ inline_expr eq.eq_rhs locals node nodes
+ in
+ ( locals',
+ Eq { eq with eq_rhs = eq_rhs' } :: new_stmts' @ stmts,
+ asserts' @ asserts,
+ annots' @ annots ))
+ (node.node_locals, [], node.node_asserts, node.node_annot)
+ eqs
in
- let inlined =
- { node with
- node_locals = new_locals;
- node_stmts = stmts;
- node_asserts = asserts;
- node_annot = annots;
+ let inlined =
+ {
+ node with
+ node_locals = new_locals;
+ node_stmts = stmts;
+ node_asserts = asserts;
+ node_annot = annots;
}
in
- begin
- (*Format.eprintf "inline node:<< %a@.>>@." Printers.pp_node inlined;*)
- Hashtbl.add inline_table node.node_id inlined;
- inlined
- end
+ (*Format.eprintf "inline node:<< %a@.>>@." Printers.pp_node inlined;*)
+ Hashtbl.add inline_table node.node_id inlined;
+ inlined
let inline_all_calls node nodes =
let nd = match node.top_decl_desc with Node nd -> nd | _ -> assert false in
{ node with top_decl_desc = Node (inline_node nd nodes) }
-
-
-
-
let witness filename main_name orig inlined (* type_env clock_env *) =
let loc = Location.dummy_loc in
let rename_local_node nodes prefix id =
- if List.exists (check_node_name id) nodes then
- prefix ^ id
- else
- id
+ if List.exists (check_node_name id) nodes then prefix ^ id else id
in
- let main_orig_node = match (List.find (check_node_name main_name) orig).top_decl_desc with
- Node nd -> nd | _ -> assert false in
-
+ let main_orig_node =
+ match (List.find (check_node_name main_name) orig).top_decl_desc with
+ | Node nd ->
+ nd
+ | _ ->
+ assert false
+ in
+
let orig_rename = rename_local_node orig "orig_" in
let inlined_rename = rename_local_node inlined "inlined_" in
- let identity = (fun x -> x) in
- let is_node top = match top.top_decl_desc with Node _ -> true | _ -> false in
- let orig = rename_prog orig_rename (* f_node *) identity (* f_var *) identity (* f_const *) orig in
+ let identity x = x in
+ let is_node top =
+ match top.top_decl_desc with Node _ -> true | _ -> false
+ in
+ let orig =
+ rename_prog orig_rename (* f_node *) identity (* f_var *) identity
+ (* f_const *) orig
+ in
let inlined = rename_prog inlined_rename identity identity inlined in
let nodes_origs, others = List.partition is_node orig in
let nodes_inlined, _ = List.partition is_node inlined in
- (* One ok_i boolean variable per output var *)
+ (* One ok_i boolean variable per output var *)
let nb_outputs = List.length main_orig_node.node_outputs in
let ok_ident = "OK" in
- let ok_i = List.map (fun id ->
- mkvar_decl
- loc
- (Format.sprintf "%s_%i" ok_ident id,
- {ty_dec_desc=Tydec_bool; ty_dec_loc=loc},
- {ck_dec_desc=Ckdec_any; ck_dec_loc=loc},
- false,
- None,
- None
- )
- ) (Utils.enumerate nb_outputs)
+ let ok_i =
+ List.map
+ (fun id ->
+ mkvar_decl loc
+ ( Format.sprintf "%s_%i" ok_ident id,
+ { ty_dec_desc = Tydec_bool; ty_dec_loc = loc },
+ { ck_dec_desc = Ckdec_any; ck_dec_loc = loc },
+ false,
+ None,
+ None ))
+ (Utils.enumerate nb_outputs)
in
(* OK = ok_1 and ok_2 and ... ok_n-1 *)
- let ok_output = mkvar_decl
- loc
- (ok_ident,
- {ty_dec_desc=Tydec_bool; ty_dec_loc=loc},
- {ck_dec_desc=Ckdec_any; ck_dec_loc=loc},
- false,
- None,
- None
- )
+ let ok_output =
+ mkvar_decl loc
+ ( ok_ident,
+ { ty_dec_desc = Tydec_bool; ty_dec_loc = loc },
+ { ck_dec_desc = Ckdec_any; ck_dec_loc = loc },
+ false,
+ None,
+ None )
in
let main_ok_expr =
let mkv x = mkexpr loc (Expr_ident x) in
match ok_i with
- | [] -> assert false
- | [x] -> mkv x.var_id
- | hd::tl ->
- List.fold_left (fun accu elem ->
- mkpredef_call loc "&&" [mkv elem.var_id; accu]
- ) (mkv hd.var_id) tl
+ | [] ->
+ assert false
+ | [ x ] ->
+ mkv x.var_id
+ | hd :: tl ->
+ List.fold_left
+ (fun accu elem -> mkpredef_call loc "&&" [ mkv elem.var_id; accu ])
+ (mkv hd.var_id) tl
in
(* Building main node *)
-
let ok_i_eq =
- { eq_loc = loc;
+ {
+ eq_loc = loc;
eq_lhs = List.map (fun v -> v.var_id) ok_i;
- eq_rhs =
- let inputs = expr_of_expr_list loc (List.map (fun v -> mkexpr loc (Expr_ident v.var_id)) main_orig_node.node_inputs) in
- let call_orig =
- mkexpr loc (Expr_appl ("orig_" ^ main_name, inputs, None)) in
- let call_inlined =
- mkexpr loc (Expr_appl ("inlined_" ^ main_name, inputs, None)) in
- let args = mkexpr loc (Expr_tuple [call_orig; call_inlined]) in
- mkexpr loc (Expr_appl ("=", args, None))
- } in
- let ok_eq =
- { eq_loc = loc;
- eq_lhs = [ok_ident];
- eq_rhs = main_ok_expr;
- } in
- let main_node = {
- node_id = "check";
- node_type = Types.new_var ();
- node_clock = Clocks.new_var true;
- node_inputs = main_orig_node.node_inputs;
- node_outputs = [ok_output];
- node_locals = ok_i;
- node_gencalls = [];
- node_checks = [];
- node_asserts = [];
- node_stmts = [Eq ok_i_eq; Eq ok_eq];
- node_dec_stateless = false;
- node_stateless = None;
- node_spec = Some
- (Contract
- (mk_contract_guarantees None
- (mkeexpr loc (mkexpr loc (Expr_ident ok_ident)))
- )
- );
- node_annot = [];
- node_iscontract = true;
+ eq_rhs =
+ (let inputs =
+ expr_of_expr_list loc
+ (List.map
+ (fun v -> mkexpr loc (Expr_ident v.var_id))
+ main_orig_node.node_inputs)
+ in
+ let call_orig =
+ mkexpr loc (Expr_appl ("orig_" ^ main_name, inputs, None))
+ in
+ let call_inlined =
+ mkexpr loc (Expr_appl ("inlined_" ^ main_name, inputs, None))
+ in
+ let args = mkexpr loc (Expr_tuple [ call_orig; call_inlined ]) in
+ mkexpr loc (Expr_appl ("=", args, None)));
+ }
+ in
+ let ok_eq = { eq_loc = loc; eq_lhs = [ ok_ident ]; eq_rhs = main_ok_expr } in
+ let main_node =
+ {
+ node_id = "check";
+ node_type = Types.new_var ();
+ node_clock = Clocks.new_var true;
+ node_inputs = main_orig_node.node_inputs;
+ node_outputs = [ ok_output ];
+ node_locals = ok_i;
+ node_gencalls = [];
+ node_checks = [];
+ node_asserts = [];
+ node_stmts = [ Eq ok_i_eq; Eq ok_eq ];
+ node_dec_stateless = false;
+ node_stateless = None;
+ node_spec =
+ Some
+ (Contract
+ (mk_contract_guarantees None
+ (mkeexpr loc (mkexpr loc (Expr_ident ok_ident)))));
+ node_annot = [];
+ node_iscontract = true;
}
in
- let main = [{ top_decl_desc = Node main_node; top_decl_loc = loc; top_decl_owner = filename; top_decl_itf = false }] in
- let new_prog = others@nodes_origs@nodes_inlined@main in
-(*
- let _ = Typing.type_prog type_env new_prog in
- let _ = Clock_calculus.clock_prog clock_env new_prog in
-*)
-
- let witness_file = (Options_management.get_witness_dir filename) ^ "/" ^ "inliner_witness.lus" in
+ let main =
+ [
+ {
+ top_decl_desc = Node main_node;
+ top_decl_loc = loc;
+ top_decl_owner = filename;
+ top_decl_itf = false;
+ };
+ ]
+ in
+ let new_prog = others @ nodes_origs @ nodes_inlined @ main in
+
+ (* let _ = Typing.type_prog type_env new_prog in let _ =
+ Clock_calculus.clock_prog clock_env new_prog in *)
+ let witness_file =
+ Options_management.get_witness_dir filename ^ "/" ^ "inliner_witness.lus"
+ in
let witness_out = open_out witness_file in
let witness_fmt = Format.formatter_of_out_channel witness_out in
- begin
- List.iter (fun vdecl -> Typing.try_unify Type_predef.type_bool vdecl.var_type vdecl.var_loc) (ok_output::ok_i);
- Format.fprintf witness_fmt
- "(* Generated lustre file to check validity of inlining process *)@.";
- Printers.pp_prog witness_fmt new_prog;
- Format.fprintf witness_fmt "@.";
- ()
- end (* xx *)
+ List.iter
+ (fun vdecl ->
+ Typing.try_unify Type_predef.type_bool vdecl.var_type vdecl.var_loc)
+ (ok_output :: ok_i);
+ Format.fprintf witness_fmt
+ "(* Generated lustre file to check validity of inlining process *)@.";
+ Printers.pp_prog witness_fmt new_prog;
+ Format.fprintf witness_fmt "@.";
+ ()
+(* xx *)
let global_inline prog (*type_env clock_env*) =
(* We select the main node desc *)
let main_node, other_nodes, _ =
List.fold_right
- (fun top (main_opt, nodes, others) ->
- match top.top_decl_desc with
- | Node nd when nd.node_id = !Options.main_node ->
- Some top, nodes, others
- | Node _ -> main_opt, top::nodes, others
- | _ -> main_opt, nodes, top::others)
- prog (None, [], [])
+ (fun top (main_opt, nodes, others) ->
+ match top.top_decl_desc with
+ | Node nd when nd.node_id = !Options.main_node ->
+ Some top, nodes, others
+ | Node _ ->
+ main_opt, top :: nodes, others
+ | _ ->
+ main_opt, nodes, top :: others)
+ prog (None, [], [])
in
(* Recursively each call of a node in the top node is replaced *)
let main_node = Utils.desome main_node in
let main_node' = inline_all_calls main_node other_nodes in
- let res = List.map (fun top -> if check_node_name !Options.main_node top then main_node' else top) prog in
- (* Code snippet from unstable branch. May be used when reactivating witnesses.
- let res = main_node'::other_tops in
- if !Options.witnesses then (
- witness
- basename
- (match main_node.top_decl_desc with Node nd -> nd.node_id | _ -> assert false)
- prog res type_env clock_env
- );
-*)
+ let res =
+ List.map
+ (fun top ->
+ if check_node_name !Options.main_node top then main_node' else top)
+ prog
+ in
+ (* Code snippet from unstable branch. May be used when reactivating witnesses.
+ let res = main_node'::other_tops in if !Options.witnesses then ( witness
+ basename (match main_node.top_decl_desc with Node nd -> nd.node_id | _ ->
+ assert false) prog res type_env clock_env ); *)
res
let pp_inline_calls fmt prog =
let local_anns = Annotations.get_expr_annotations keyword in
- let nodes_with_anns = List.fold_left (fun accu (k, _) -> ISet.add k accu) ISet.empty local_anns in
+ let nodes_with_anns =
+ List.fold_left (fun accu (k, _) -> ISet.add k accu) ISet.empty local_anns
+ in
Format.fprintf fmt "@[<v 0>Inlined expresssions in node (by tags):@ %a@]"
- (fprintf_list ~sep:""
- (fun fmt top ->
- match top.top_decl_desc with
- | Node nd when ISet.mem nd.node_id nodes_with_anns ->
- Format.fprintf fmt "%s: {@[<v 0>%a}@]@ "
- nd.node_id
- (fprintf_list ~sep:"@ " (fun fmt tag -> Format.fprintf fmt "%i" tag))
- (List.fold_left
- (fun accu (id, tag) -> if id = nd.node_id then tag::accu else accu)
- []
- local_anns
- )
- (* | Node nd -> Format.fprintf fmt "%s: no inline annotations" nd.node_id *)
- | _ -> ()
- ))
+ (fprintf_list ~sep:"" (fun fmt top ->
+ match top.top_decl_desc with
+ | Node nd when ISet.mem nd.node_id nodes_with_anns ->
+ Format.fprintf fmt "%s: {@[<v 0>%a}@]@ " nd.node_id
+ (fprintf_list ~sep:"@ " (fun fmt tag ->
+ Format.fprintf fmt "%i" tag))
+ (List.fold_left
+ (fun accu (id, tag) ->
+ if id = nd.node_id then tag :: accu else accu)
+ [] local_anns)
+ (* | Node nd -> Format.fprintf fmt "%s: no inline annotations"
+ nd.node_id *)
+ | _ ->
+ ()))
prog
-
-
+
let local_inline prog (* type_env clock_env *) =
Log.report ~level:2 (fun fmt -> Format.fprintf fmt ".. @[<v 2>Inlining@,");
let local_anns = Annotations.get_expr_annotations keyword in
- let prog =
+ let prog =
if local_anns != [] then (
- let nodes_with_anns = List.fold_left (fun accu (k, _) -> ISet.add k accu) ISet.empty local_anns in
- ISet.iter (fun node_id -> Log.report ~level:2 (fun fmt -> Format.fprintf fmt "Node %s has local expression annotations@ " node_id))
- nodes_with_anns;
- List.fold_right (fun top accu ->
- ( match top.top_decl_desc with
- | Node nd when ISet.mem nd.node_id nodes_with_anns ->
- Log.report ~level:2 (fun fmt -> Format.fprintf fmt "[local inline] Processing node %s@ " nd.node_id);
- let inlined_node = inline_node ~selection_on_annotation:true nd prog in
- (* Format.eprintf "Before inline@.%a@.After:@.%a@." *)
- (* Printers.pp_node nd *)
- (* Printers.pp_node inlined_node; *)
- { top with top_decl_desc = Node inlined_node }
-
- | _ -> top
- )::accu) prog []
-
- )
+ let nodes_with_anns =
+ List.fold_left
+ (fun accu (k, _) -> ISet.add k accu)
+ ISet.empty local_anns
+ in
+ ISet.iter
+ (fun node_id ->
+ Log.report ~level:2 (fun fmt ->
+ Format.fprintf fmt "Node %s has local expression annotations@ "
+ node_id))
+ nodes_with_anns;
+ List.fold_right
+ (fun top accu ->
+ (match top.top_decl_desc with
+ | Node nd when ISet.mem nd.node_id nodes_with_anns ->
+ Log.report ~level:2 (fun fmt ->
+ Format.fprintf fmt "[local inline] Processing node %s@ "
+ nd.node_id);
+ let inlined_node =
+ inline_node ~selection_on_annotation:true nd prog
+ in
+ (* Format.eprintf "Before inline@.%a@.After:@.%a@." *)
+ (* Printers.pp_node nd *)
+ (* Printers.pp_node inlined_node; *)
+ { top with top_decl_desc = Node inlined_node }
+ | _ ->
+ top)
+ :: accu)
+ prog [])
else (
- Log.report ~level:2 (fun fmt -> Format.fprintf fmt "No local inline information!@ ");
- prog
- )
+ Log.report ~level:2 (fun fmt ->
+ Format.fprintf fmt "No local inline information!@ ");
+ prog)
in
Log.report ~level:2 (fun fmt -> Format.fprintf fmt "@]@,");
prog
diff --git a/src/log.ml b/src/log.ml
index 98914a5fd3efeed5e964aff8876248c0989e2d7c..8a651f3025939a5c321d4bb6dadf92b5008a7fec 100644
--- a/src/log.ml
+++ b/src/log.ml
@@ -9,17 +9,12 @@
(* *)
(********************************************************************)
-let report
- ?plugin:(modulename="")
- ?(verbose_level=Options.verbose_level)
- ~level:level p =
-if !verbose_level >= level then
- if modulename="" then
- Format.eprintf "%t" p
- else
- Format.eprintf "[%s] @[%t@]" modulename p
+let report ?plugin:(modulename = "") ?(verbose_level = Options.verbose_level)
+ ~level p =
+ if !verbose_level >= level then
+ if modulename = "" then Format.eprintf "%t" p
+ else Format.eprintf "[%s] @[%t@]" modulename p
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
-
diff --git a/src/lusic.ml b/src/lusic.ml
index b3a05705391ba2a7e692187a9df4d5407163c080..0ecdc2556e3763d0b09af04cd9d3ba894ff2a6b9 100644
--- a/src/lusic.ml
+++ b/src/lusic.ml
@@ -1,4 +1,3 @@
-
(********************************************************************)
(* *)
(* The LustreC compiler toolset / The LustreC Development Team *)
@@ -13,72 +12,58 @@
open Lustre_types
(********************************************************************************************)
-(* Lusic to/from Header Printing functions *)
+(* Lusic to/from Header Printing functions *)
(********************************************************************************************)
-type lusic =
-{
- obsolete : bool;
- from_lusi : bool;
- contents : top_decl list;
-}
+type lusic = { obsolete : bool; from_lusi : bool; contents : top_decl list }
(* extracts a header from a program representing module owner = dirname/basename *)
let extract_header dirname basename prog =
let owner = dirname ^ "/" ^ basename in
List.fold_right
(fun decl header ->
- (* Format.eprintf "Lusic.extract_header: header = %B, owner = %s, decl_owner = %s@."
- * decl.top_decl_itf owner decl.top_decl_owner; *)
- if decl.top_decl_itf || decl.top_decl_owner <> owner then header
- else match decl.top_decl_desc with
- | Node nd ->
- { decl with top_decl_desc =
- ImportedNode (Corelang.get_node_interface nd) }
- :: header
- | ImportedNode _ -> header
- | Const _ | TypeDef _ | Include _ | Open _ -> decl :: header)
+ (* Format.eprintf "Lusic.extract_header: header = %B, owner = %s, decl_owner = %s@."
+ * decl.top_decl_itf owner decl.top_decl_owner; *)
+ if decl.top_decl_itf || decl.top_decl_owner <> owner then header
+ else
+ match decl.top_decl_desc with
+ | Node nd ->
+ {
+ decl with
+ top_decl_desc = ImportedNode (Corelang.get_node_interface nd);
+ }
+ :: header
+ | ImportedNode _ ->
+ header
+ | Const _ | TypeDef _ | Include _ | Open _ ->
+ decl :: header)
prog []
let check_obsolete lusic basename =
- if lusic.obsolete then raise (Error.Error (Location.dummy_loc, Error.Wrong_number basename))
+ if lusic.obsolete then
+ raise (Error.Error (Location.dummy_loc, Error.Wrong_number basename))
(* encode and write a header in a file *)
let write_lusic lusi (header : top_decl list) basename extension =
let target_name = basename ^ extension in
let outchan = open_out_bin target_name in
- begin
- (*Format.eprintf "write_lusic: %i items.@." (List.length header);*)
- Marshal.to_channel outchan (Version.number, lusi : string * bool) [];
- Marshal.to_channel outchan (header : top_decl list) [];
- close_out outchan
- end
+ (*Format.eprintf "write_lusic: %i items.@." (List.length header);*)
+ Marshal.to_channel outchan (Version.number, lusi : string * bool) [];
+ Marshal.to_channel outchan (header : top_decl list) [];
+ close_out outchan
(* read and decode a header from a file *)
let read_lusic basename extension =
let source_name = basename ^ extension in
let inchan = open_in_bin source_name in
- let number, from_lusi = (Marshal.from_channel inchan : string * bool) in
- if number <> Version.number
- then
- begin
- close_in inchan;
- {
- obsolete = true;
- from_lusi = from_lusi;
- contents = [];
- }
- end
- else
- begin
- let lusic = (Marshal.from_channel inchan : top_decl list) in
- close_in inchan;
- {
- obsolete = false;
- from_lusi = from_lusi;
- contents = lusic;
- }
- end
+ let (number, from_lusi) = (Marshal.from_channel inchan : string * bool) in
+ if number <> Version.number then (
+ close_in inchan;
+ { obsolete = true; from_lusi; contents = [] })
+ else
+ let lusic = (Marshal.from_channel inchan : top_decl list) in
+ close_in inchan;
+ { obsolete = false; from_lusi; contents = lusic }
(* let print_lusic_to_h basename extension =
* let lusic = read_lusic basename extension in
diff --git a/src/lustre_live.ml b/src/lustre_live.ml
index 0c7e40556c5051c4e1199bf9c34e8f2e61346f3d..f38e65cd0fe7f401199123024ff56e1bec1e27e9 100644
--- a/src/lustre_live.ml
+++ b/src/lustre_live.ml
@@ -13,13 +13,11 @@ open Lustre_types
open Dimension
open Utils
open ISet
-module Live = Map.Make(Int)
+module Live = Map.Make (Int)
-let pp_live fmt l =
- Live.bindings
+let pp_live fmt l = Live.bindings
-let assigned s eq =
- union s (of_list eq.eq_lhs)
+let assigned s eq = union s (of_list eq.eq_lhs)
let rec occur_dim_expr s d =
match d.dim_desc with
@@ -31,22 +29,20 @@ let rec occur_dim_expr s d =
occur_dim_expr (occur_dim_expr (occur_dim_expr s e) t) f
| Dlink d ->
occur_dim_expr s d
- | _ -> s
+ | _ ->
+ s
let rec occur_expr s e =
match e.expr_desc with
| Expr_ident x ->
add x s
- | Expr_tuple es
- | Expr_array es ->
+ | Expr_tuple es | Expr_array es ->
List.fold_left occur_expr s es
| Expr_ite (e, t, f) ->
occur_expr (occur_expr (occur_expr s e) t) f
- | Expr_arrow (e1, e2)
- | Expr_fby (e1, e2) ->
+ | Expr_arrow (e1, e2) | Expr_fby (e1, e2) ->
occur_expr (occur_expr s e1) e2
- | Expr_access (e, d)
- | Expr_power (e, d) ->
+ | Expr_access (e, d) | Expr_power (e, d) ->
occur_expr (occur_dim_expr s d) e
| Expr_pre e ->
occur_expr s e
@@ -56,48 +52,53 @@ let rec occur_expr s e =
List.fold_left (fun s (_, e) -> occur_expr s e) (add x s) les
| Expr_appl (_, e, r) ->
occur_expr (match r with Some r -> occur_expr s r | None -> s) e
- | _ -> s
+ | _ ->
+ s
-let occur s eq =
- occur_expr s eq.eq_rhs
+let occur s eq = occur_expr s eq.eq_rhs
-let live: (ident, ISet.t Live.t) Hashtbl.t = Hashtbl.create 32
+let live : (ident, ISet.t Live.t) Hashtbl.t = Hashtbl.create 32
-let of_var_decls =
- List.fold_left (fun s v -> add v.var_id s) empty
+let of_var_decls = List.fold_left (fun s v -> add v.var_id s) empty
let set_live_of nid outputs locals sorted_eqs =
let outputs = of_var_decls outputs in
let locals = of_var_decls locals in
let vars = union locals outputs in
let no_occur_after i =
- let occ, _ = List.fold_left (fun (s, j) eq ->
- if j <= i then (s, j + 1) else (occur s eq, j + 1))
- (empty, 0) sorted_eqs in
+ let occ, _ =
+ List.fold_left
+ (fun (s, j) eq -> if j <= i then s, j + 1 else occur s eq, j + 1)
+ (empty, 0) sorted_eqs
+ in
diff locals occ
in
- let l, _, _ = List.fold_left (fun (l, asg, i) eq ->
- let asg = inter (assigned asg eq) vars in
- let noc = no_occur_after i in
- let liv = diff asg noc in
- Live.add (i + 1) liv l, asg, i + 1)
- (Live.add 0 empty Live.empty, empty, 0) sorted_eqs in
+ let l, _, _ =
+ List.fold_left
+ (fun (l, asg, i) eq ->
+ let asg = inter (assigned asg eq) vars in
+ let noc = no_occur_after i in
+ let liv = diff asg noc in
+ Live.add (i + 1) liv l, asg, i + 1)
+ (Live.add 0 empty Live.empty, empty, 0)
+ sorted_eqs
+ in
Log.report ~level:6 (fun fmt ->
- Format.(fprintf fmt "Live variables of %s: %a@;@;" nid
- (pp_print_list ~pp_open_box:pp_open_vbox0
- (fun fmt (i, l) -> fprintf fmt "%i: %a" i pp_iset l))
- (Live.bindings l)));
+ Format.(
+ fprintf fmt "Live variables of %s: %a@;@;" nid
+ (pp_print_list ~pp_open_box:pp_open_vbox0 (fun fmt (i, l) ->
+ fprintf fmt "%i: %a" i pp_iset l))
+ (Live.bindings l)));
Hashtbl.add live nid l
-let live_i nid i =
- Live.find i (Hashtbl.find live nid)
+let live_i nid i = Live.find i (Hashtbl.find live nid)
let inter_live_i_with nid i =
let li = live_i nid i in
List.filter (fun v -> mem v.var_id li)
let existential_vars nid i eq =
- let li' = live_i nid (i-1) in
+ let li' = live_i nid (i - 1) in
let li = live_i nid i in
let d = diff (union li' (assigned empty eq)) li in
List.filter (fun v -> mem v.var_id d)
diff --git a/src/lustre_types.ml b/src/lustre_types.ml
index e0aa487f1b2a2c37e8ac8308cd0c06ea844b2f83..19538aaf6669c2a5c3691ad1c4579eec8ead29c0 100644
--- a/src/lustre_types.ml
+++ b/src/lustre_types.ml
@@ -9,15 +9,15 @@
(* *)
(********************************************************************)
-
type ident = Utils.ident
+
type rat = Utils.rat
+
type tag = Utils.tag
+
type label = Utils.ident
-type type_dec =
- {ty_dec_desc: type_dec_desc;
- ty_dec_loc: Location.t}
+type type_dec = { ty_dec_desc : type_dec_desc; ty_dec_loc : Location.t }
and type_dec_desc =
| Tydec_any
@@ -31,68 +31,62 @@ and type_dec_desc =
| Tydec_struct of (ident * type_dec_desc) list
| Tydec_array of Dimension.dim_expr * type_dec_desc
-type typedec_desc =
- {tydec_id: ident}
-
-type typedef_desc =
- {tydef_id: ident;
- tydef_desc: type_dec_desc}
+type typedec_desc = { tydec_id : ident }
-type clock_dec =
- {ck_dec_desc: clock_dec_desc;
- ck_dec_loc: Location.t}
+type typedef_desc = { tydef_id : ident; tydef_desc : type_dec_desc }
-and clock_dec_desc =
- | Ckdec_any
- | Ckdec_bool of (ident * ident) list
+type clock_dec = { ck_dec_desc : clock_dec_desc; ck_dec_loc : Location.t }
+and clock_dec_desc = Ckdec_any | Ckdec_bool of (ident * ident) list
type constant =
| Const_int of int
| Const_real of Real.t
| Const_array of constant list
| Const_tag of label
- | Const_string of string (* used only for annotations *)
- | Const_modeid of string (* used only for annotations *)
+ | Const_string of string
+ (* used only for annotations *)
+ | Const_modeid of string
+ (* used only for annotations *)
| Const_struct of (label * constant) list
type quantifier_type = Exists | Forall
-type var_decl =
- {var_id: ident;
- var_orig:bool;
- var_dec_type: type_dec;
- var_dec_clock: clock_dec;
- var_dec_const: bool;
- var_dec_value: expr option;
- mutable var_parent_nodeid: ident option;
- mutable var_type: Types.type_expr;
- mutable var_clock: Clocks.clock_expr;
- var_loc: Location.t}
+type var_decl = {
+ var_id : ident;
+ var_orig : bool;
+ var_dec_type : type_dec;
+ var_dec_clock : clock_dec;
+ var_dec_const : bool;
+ var_dec_value : expr option;
+ mutable var_parent_nodeid : ident option;
+ mutable var_type : Types.type_expr;
+ mutable var_clock : Clocks.clock_expr;
+ var_loc : Location.t;
+}
+(* The tag of an expression is a unique identifier used to distinguish different
+ instances of the same node *)
(** The core language and its ast. Every element of the ast contains its
- location in the program text. The type and clock of an ast element
- is mutable (and initialized to dummy values). This avoids to have to
- duplicate ast structures (e.g. ast, typed_ast, clocked_ast). *)
-
-
-
-(* The tag of an expression is a unique identifier used to distinguish
- different instances of the same node *)
-and expr =
- {expr_tag: tag;
- expr_desc: expr_desc;
- mutable expr_type: Types.type_expr;
- mutable expr_clock: Clocks.clock_expr;
- mutable expr_delay: Delay.delay_expr;
- mutable expr_annot: expr_annot option;
- expr_loc: Location.t}
+ location in the program text. The type and clock of an ast element is
+ mutable (and initialized to dummy values). This avoids to have to duplicate
+ ast structures (e.g. ast, typed_ast, clocked_ast). *)
+
+and expr = {
+ expr_tag : tag;
+ expr_desc : expr_desc;
+ mutable expr_type : Types.type_expr;
+ mutable expr_clock : Clocks.clock_expr;
+ mutable expr_delay : Delay.delay_expr;
+ mutable expr_annot : expr_annot option;
+ expr_loc : Location.t;
+}
and expr_desc =
| Expr_const of constant
| Expr_ident of ident
| Expr_tuple of expr list
- | Expr_ite of expr * expr * expr
+ | Expr_ite of expr * expr * expr
| Expr_arrow of expr * expr
| Expr_fby of expr * expr
| Expr_array of expr list
@@ -104,160 +98,152 @@ and expr_desc =
| Expr_appl of call_t
and call_t = ident * expr * expr option
- (* The third part denotes the boolean condition for resetting *)
-
-and eq =
- {eq_lhs: ident list;
- eq_rhs: expr;
- eq_loc: Location.t}
-
- (* The tag of an expression is a unique identifier used to distinguish
- different instances of the same node *)
-and eexpr =
- {eexpr_tag: tag;
- eexpr_qfexpr: expr;
- eexpr_quantifiers: (quantifier_type * var_decl list) list;
- eexpr_name: string option;
- mutable eexpr_type: Types.type_expr;
- mutable eexpr_clock: Clocks.clock_expr;
- (* mutable eexpr_normalized: (var_decl * eq list * var_decl list) option; *)
- eexpr_loc: Location.t}
-
-and expr_annot =
- {annots: (string list * eexpr) list;
- annot_loc: Location.t}
-
-type contract_mode =
- {
- mode_id: ident;
- require: eexpr list;
- ensure: eexpr list;
- mode_loc: Location.t
- }
-
-type contract_import =
- { import_nodeid: ident;
- inputs: expr;
- outputs: expr;
- import_loc: Location.t }
-
-
-
-type offset =
-| Index of Dimension.dim_expr
-| Field of label
-
-type assert_t =
- {
- assert_expr: expr;
- assert_loc: Location.t;
- }
-
-type statement =
-| Eq of eq
-| Aut of automata_desc
-
-and automata_desc =
- {aut_id : ident;
- aut_handlers: handler_desc list;
- aut_loc: Location.t}
-
-and handler_desc =
- {hand_state: ident;
- hand_unless: (Location.t * expr * bool * ident) list;
- hand_until: (Location.t * expr * bool * ident) list;
- hand_locals: var_decl list;
- hand_stmts: statement list;
- hand_asserts: assert_t list;
- hand_annots: expr_annot list;
- hand_loc: Location.t}
-
-type contract_desc =
- {
- consts: var_decl list;
- locals: var_decl list;
- stmts: statement list;
- assume: eexpr list;
- guarantees: eexpr list;
- modes: contract_mode list;
- imports: contract_import list;
- spec_loc: Location.t;
- }
-
-type node_spec_t = Contract of contract_desc
- | NodeSpec of ident
-
-type node_desc =
- {node_id: ident;
- mutable node_type: Types.type_expr;
- mutable node_clock: Clocks.clock_expr;
- node_inputs: var_decl list;
- node_outputs: var_decl list;
- node_locals: var_decl list;
- mutable node_gencalls: expr list;
- mutable node_checks: Dimension.dim_expr list;
- node_asserts: assert_t list;
- node_stmts: statement list;
- mutable node_dec_stateless: bool;
- mutable node_stateless: bool option;
- node_spec: node_spec_t option;
- node_annot: expr_annot list;
- node_iscontract: bool;
- }
-
-type imported_node_desc =
- {nodei_id: ident;
- mutable nodei_type: Types.type_expr;
- mutable nodei_clock: Clocks.clock_expr;
- nodei_inputs: var_decl list;
- nodei_outputs: var_decl list;
- nodei_stateless: bool;
- nodei_spec: node_spec_t option;
- (* nodei_annot: expr_annot list; *)
- nodei_prototype: string option;
- nodei_in_lib: string list;
- }
-
-type const_desc =
- {const_id: ident;
- const_loc: Location.t;
- const_value: constant;
- mutable const_type: Types.type_expr;
- }
-
-
+(* The third part denotes the boolean condition for resetting *)
+
+and eq = { eq_lhs : ident list; eq_rhs : expr; eq_loc : Location.t }
+
+(* The tag of an expression is a unique identifier used to distinguish different
+ instances of the same node *)
+and eexpr = {
+ eexpr_tag : tag;
+ eexpr_qfexpr : expr;
+ eexpr_quantifiers : (quantifier_type * var_decl list) list;
+ eexpr_name : string option;
+ mutable eexpr_type : Types.type_expr;
+ mutable eexpr_clock : Clocks.clock_expr;
+ (* mutable eexpr_normalized: (var_decl * eq list * var_decl list) option; *)
+ eexpr_loc : Location.t;
+}
+
+and expr_annot = { annots : (string list * eexpr) list; annot_loc : Location.t }
+
+type contract_mode = {
+ mode_id : ident;
+ require : eexpr list;
+ ensure : eexpr list;
+ mode_loc : Location.t;
+}
+
+type contract_import = {
+ import_nodeid : ident;
+ inputs : expr;
+ outputs : expr;
+ import_loc : Location.t;
+}
+
+type offset = Index of Dimension.dim_expr | Field of label
+
+type assert_t = { assert_expr : expr; assert_loc : Location.t }
+
+type statement = Eq of eq | Aut of automata_desc
+
+and automata_desc = {
+ aut_id : ident;
+ aut_handlers : handler_desc list;
+ aut_loc : Location.t;
+}
+
+and handler_desc = {
+ hand_state : ident;
+ hand_unless : (Location.t * expr * bool * ident) list;
+ hand_until : (Location.t * expr * bool * ident) list;
+ hand_locals : var_decl list;
+ hand_stmts : statement list;
+ hand_asserts : assert_t list;
+ hand_annots : expr_annot list;
+ hand_loc : Location.t;
+}
+
+type contract_desc = {
+ consts : var_decl list;
+ locals : var_decl list;
+ stmts : statement list;
+ assume : eexpr list;
+ guarantees : eexpr list;
+ modes : contract_mode list;
+ imports : contract_import list;
+ spec_loc : Location.t;
+}
+
+type node_spec_t = Contract of contract_desc | NodeSpec of ident
+
+type node_desc = {
+ node_id : ident;
+ mutable node_type : Types.type_expr;
+ mutable node_clock : Clocks.clock_expr;
+ node_inputs : var_decl list;
+ node_outputs : var_decl list;
+ node_locals : var_decl list;
+ mutable node_gencalls : expr list;
+ mutable node_checks : Dimension.dim_expr list;
+ node_asserts : assert_t list;
+ node_stmts : statement list;
+ mutable node_dec_stateless : bool;
+ mutable node_stateless : bool option;
+ node_spec : node_spec_t option;
+ node_annot : expr_annot list;
+ node_iscontract : bool;
+}
+
+type imported_node_desc = {
+ nodei_id : ident;
+ mutable nodei_type : Types.type_expr;
+ mutable nodei_clock : Clocks.clock_expr;
+ nodei_inputs : var_decl list;
+ nodei_outputs : var_decl list;
+ nodei_stateless : bool;
+ nodei_spec : node_spec_t option;
+ (* nodei_annot: expr_annot list; *)
+ nodei_prototype : string option;
+ nodei_in_lib : string list;
+}
+
+type const_desc = {
+ const_id : ident;
+ const_loc : Location.t;
+ const_value : constant;
+ mutable const_type : Types.type_expr;
+}
+
type top_decl_desc =
| Node of node_desc
| Const of const_desc
| ImportedNode of imported_node_desc
- | Open of bool * string (* the boolean set to true denotes a local
- lusi vs a lusi installed at system level *)
- | Include of string (* the boolean set to true denotes a local
- lus vs a lus installed at system level *)
+ | Open of bool * string
+ (* the boolean set to true denotes a local lusi vs a lusi installed at system
+ level *)
+ | Include of string
+ (* the boolean set to true denotes a local lus vs a lus installed at system
+ level *)
| TypeDef of typedef_desc
-
-type top_decl =
- {top_decl_desc: top_decl_desc; (* description of the symbol *)
- top_decl_owner: Location.filename; (* the module where it is defined *)
- top_decl_itf: bool; (* header or source file ? *)
- top_decl_loc: Location.t} (* the location where it is defined *)
+
+type top_decl = {
+ top_decl_desc : top_decl_desc;
+ (* description of the symbol *)
+ top_decl_owner : Location.filename;
+ (* the module where it is defined *)
+ top_decl_itf : bool;
+ (* header or source file ? *)
+ top_decl_loc : Location.t;
+}
+(* the location where it is defined *)
type program_t = top_decl list
type dep_t = {
- local: bool;
- name: ident;
- content: program_t;
- is_stateful: bool
- }
+ local : bool;
+ name : ident;
+ content : program_t;
+ is_stateful : bool;
+}
type spec_types =
| LocalContract of contract_desc
| TopContract of top_decl list
let tag_true = "true"
-let tag_false = "false"
+let tag_false = "false"
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/lustre_utils.ml b/src/lustre_utils.ml
index e82c9c647f2a495b5a7e8ba2281b03bdd8758177..92b19db8e0531d8bad89fbafb1c6d2db4e1cbe05 100644
--- a/src/lustre_utils.ml
+++ b/src/lustre_utils.ml
@@ -1,33 +1,33 @@
open Lustre_types
-let expr_of_vars loc vl =
- Corelang.expr_of_expr_list loc
- (List.map Corelang.expr_of_vdecl vl)
-
-
+let expr_of_vars loc vl =
+ Corelang.expr_of_expr_list loc (List.map Corelang.expr_of_vdecl vl)
+
(* Create a node that checks whether two other nodes have the same output *)
let check_eq nd1 nd2 =
(* TODO: check that nd1 and nd2 have the same signature *)
- let check_nd = Corelang.copy_node nd1 in (* to keep the type info *)
- let loc = Location.dummy_loc in
+ let check_nd = Corelang.copy_node nd1 in
+ (* to keep the type info *)
+ let loc = Location.dummy_loc in
let ok_var =
Corelang.mkvar_decl loc ~orig:false
- ("__OK",
- Corelang.mktyp loc Tydec_bool,
- Corelang.mkclock loc Ckdec_any,
- false,
- None,
- None)
+ ( "__OK",
+ Corelang.mktyp loc Tydec_bool,
+ Corelang.mkclock loc Ckdec_any,
+ false,
+ None,
+ None )
in
let input_e = expr_of_vars loc check_nd.node_inputs in
let mk_stmt nd out_vars =
- let call_e = Corelang.mkexpr loc (Expr_appl (nd.node_id, input_e , None)) in
- Eq (
- Corelang.mkeq loc
- (List.map (fun v -> v.var_id) out_vars, call_e)) in
+ let call_e = Corelang.mkexpr loc (Expr_appl (nd.node_id, input_e, None)) in
+ Eq (Corelang.mkeq loc (List.map (fun v -> v.var_id) out_vars, call_e))
+ in
let copy_vars vl post =
- let f v = { (Corelang.copy_var_decl v) with var_id = v.var_id ^ "_" ^ post } in
+ let f v =
+ { (Corelang.copy_var_decl v) with var_id = v.var_id ^ "_" ^ post }
+ in
List.map f vl
in
let out_vars1 = copy_vars nd1.node_outputs "1" in
@@ -35,93 +35,71 @@ let check_eq nd1 nd2 =
let call_n1 = mk_stmt nd1 out_vars1 in
let call_n2 = mk_stmt nd2 out_vars2 in
let build_eq v1 v2 =
- let pair = expr_of_vars loc [v1;v2] in
+ let pair = expr_of_vars loc [ v1; v2 ] in
Corelang.mkexpr loc (Expr_appl ("=", pair, None))
in
let rec build_ok vl1 vl2 =
match vl1, vl2 with
- | [v1], [v2] -> build_eq v1 v2
- | hd1::tl1, hd2::tl2 ->
- let e1 = (build_eq hd1 hd2) in
- let e2 = build_ok tl1 tl2 in
- let e = Corelang.mkexpr loc (Expr_tuple [e1; e2]) in
- Corelang.mkexpr loc (Expr_appl ("&&", e, None))
- | _ -> assert false
+ | [ v1 ], [ v2 ] ->
+ build_eq v1 v2
+ | hd1 :: tl1, hd2 :: tl2 ->
+ let e1 = build_eq hd1 hd2 in
+ let e2 = build_ok tl1 tl2 in
+ let e = Corelang.mkexpr loc (Expr_tuple [ e1; e2 ]) in
+ Corelang.mkexpr loc (Expr_appl ("&&", e, None))
+ | _ ->
+ assert false
in
- let ok_expr = build_ok out_vars1 out_vars2 in
- let ok_stmt = Eq (Corelang.mkeq loc ([ok_var.var_id], ok_expr)) in
+ let ok_expr = build_ok out_vars1 out_vars2 in
+ let ok_stmt = Eq (Corelang.mkeq loc ([ ok_var.var_id ], ok_expr)) in
(* Building contract *)
- let ok_e = Corelang.expr_of_vdecl ok_var in
- let contract = {
- consts = [];
- locals = [];
- stmts = [];
- assume = [];
- guarantees = [Corelang.mkeexpr loc ok_e];
- modes = [];
- imports = [];
- spec_loc = loc;
-
- }
+ let ok_e = Corelang.expr_of_vdecl ok_var in
+ let contract =
+ {
+ consts = [];
+ locals = [];
+ stmts = [];
+ assume = [];
+ guarantees = [ Corelang.mkeexpr loc ok_e ];
+ modes = [];
+ imports = [];
+ spec_loc = loc;
+ }
in
- let check_nd = { check_nd with
- node_id = "check_eq_" ^ nd1.node_id ^ "_" ^ nd2.node_id;
- node_outputs = [ok_var];
- node_locals = out_vars1 @ out_vars2;
- node_stmts = [call_n1; call_n2; ok_stmt];
- node_spec = Some (Contract contract);
- }
+ let check_nd =
+ {
+ check_nd with
+ node_id = "check_eq_" ^ nd1.node_id ^ "_" ^ nd2.node_id;
+ node_outputs = [ ok_var ];
+ node_locals = out_vars1 @ out_vars2;
+ node_stmts = [ call_n1; call_n2; ok_stmt ];
+ node_spec = Some (Contract contract);
+ }
in
-
Global.type_env := Typing.type_node !Global.type_env check_nd loc;
Global.clock_env := Clock_calculus.clock_node !Global.clock_env loc check_nd;
-
- check_nd
- (*
- TODO:
+ check_nd
+(* TODO:
- construire
+ construire
- les variables temporaires pour les outputs de l'un et de l'autre
- les statements d'appels de nodes
- ok = and (o1 = o2)
+ les variables temporaires pour les outputs de l'un et de l'autre les
+ statements d'appels de nodes ok = and (o1 = o2)
- et on ajoute le contrat guarantee ok
- in
- check_nd
+ et on ajoute le contrat guarantee ok in check_nd *)
- *)
-
- (* (\* Build the contract: guarentee output = orig_node(input) *\)
- *
- * let local_outputs = List.map (fun v -> { (Corelang.copy_var_decl v) with var_id = v.var_id ^ "_local" } ) copy_nd.node_outputs in
- * let input_e = expr_of_vars copy_nd.node_inputs in
- * let call_orig_e =
- * Corelang.mkexpr loc (Expr_appl (orig_nd.node_id, input_e , None)) in
- * let build_orig_outputs =
- * Eq (
- * Corelang.mkeq loc
- * (List.map (fun v -> v.var_id) local_outputs, call_orig_e)) in
- * let eq_expr = Corelang.expr_of_expr_list loc (
- * List.map2 (fun v1 v2 ->
- * let args = expr_of_vars [v1;v2] in
- * Corelang.mkexpr loc (Expr_appl ("=", args, None)))
- * copy_nd.node_outputs local_outputs
- * )
- * in
- * let contract = {
- * consts = [];
- * locals = local_outputs;
- * stmts = [build_orig_outputs];
- * assume = [];
- * guarantees = [Corelang.mkeexpr loc eq_expr];
- * modes = [];
- * imports = [];
- * spec_loc = loc;
- *
- * }
- * in *)
-
+(* (\* Build the contract: guarentee output = orig_node(input) *\) * * let
+ local_outputs = List.map (fun v -> { (Corelang.copy_var_decl v) with var_id =
+ v.var_id ^ "_local" } ) copy_nd.node_outputs in * let input_e = expr_of_vars
+ copy_nd.node_inputs in * let call_orig_e = * Corelang.mkexpr loc (Expr_appl
+ (orig_nd.node_id, input_e , None)) in * let build_orig_outputs = * Eq ( *
+ Corelang.mkeq loc * (List.map (fun v -> v.var_id) local_outputs,
+ call_orig_e)) in * let eq_expr = Corelang.expr_of_expr_list loc ( * List.map2
+ (fun v1 v2 -> * let args = expr_of_vars [v1;v2] in * Corelang.mkexpr loc
+ (Expr_appl ("=", args, None))) * copy_nd.node_outputs local_outputs * ) * in
+ * let contract = { * consts = []; * locals = local_outputs; * stmts =
+ [build_orig_outputs]; * assume = []; * guarantees = [Corelang.mkeexpr loc
+ eq_expr]; * modes = []; * imports = []; * spec_loc = loc; * * } * in *)
diff --git a/src/machine_code.ml b/src/machine_code.ml
index 7a9c7ce033e40d7c9417ec1d95e29db89bf3c971..9251adcc2d218831b6de3ac900422e3e6ba8fe45 100644
--- a/src/machine_code.ml
+++ b/src/machine_code.ml
@@ -23,9 +23,8 @@ exception NormalizationError
(* Questions:
- - where are used the mconst. They contain initialization of
- constant in nodes. But they do not seem to be used by c_backend *)
-
+ - where are used the mconst. They contain initialization of constant in
+ nodes. But they do not seem to be used by c_backend *)
(* translate_<foo> : vars -> context -> <foo> -> machine code/expression *)
(* the context contains m : state aka memory variables *)
@@ -34,28 +33,25 @@ exception NormalizationError
(* d : local variables *)
(* s : step instructions *)
-(* Machine processing requires knowledge about variables and local
- variables. Local could be memories while other could not. *)
-type machine_env = {
- is_local: string -> bool;
- get_var: string -> var_decl
-}
-
+(* Machine processing requires knowledge about variables and local variables.
+ Local could be memories while other could not. *)
+type machine_env = { is_local : string -> bool; get_var : string -> var_decl }
let build_env inputs locals outputs =
let all = List.sort_uniq VDeclModule.compare (locals @ inputs @ outputs) in
- { is_local = (fun id -> List.exists (fun v -> v.var_id = id) locals);
- get_var = (fun id -> try List.find (fun v -> v.var_id = id) all with Not_found ->
- (* Format.eprintf "Impossible to find variable %s in set %a@.@?"
- * id
- * VSet.pp all; *)
- raise Not_found)
+ {
+ is_local = (fun id -> List.exists (fun v -> v.var_id = id) locals);
+ get_var =
+ (fun id ->
+ try List.find (fun v -> v.var_id = id) all
+ with Not_found ->
+ (* Format.eprintf "Impossible to find variable %s in set %a@.@?" * id
+ * VSet.pp all; *)
+ raise Not_found);
}
-
-
(****************************************************************)
-(* Basic functions to translate to machine values, instructions *)
+(* Basic functions to translate to machine values, instructions *)
(****************************************************************)
let translate_ident env id =
@@ -64,48 +60,44 @@ let translate_ident env id =
try
let var_id = env.get_var id in
vdecl_to_val var_id
- with Not_found ->
-
- (* id is a constant *)
- try
- let vdecl = (Corelang.var_decl_of_const
- (const_of_top (Hashtbl.find Corelang.consts_table id)))
- in
- vdecl_to_val vdecl
- with Not_found ->
-
- (* id is a tag, getting its type in the list of declared enums *)
- try
- id_to_tag id
- with Not_found ->
- Format.eprintf "internal error: Machine_code.translate_ident %s@.@?" id;
- assert false
-
-
-(* specialize predefined (polymorphic) operators wrt their instances,
- so that the C semantics is preserved *)
+ with Not_found -> (
+ (* id is a constant *)
+ try
+ let vdecl =
+ Corelang.var_decl_of_const
+ (const_of_top (Hashtbl.find Corelang.consts_table id))
+ in
+ vdecl_to_val vdecl
+ with Not_found -> (
+ (* id is a tag, getting its type in the list of declared enums *)
+ try id_to_tag id
+ with Not_found ->
+ Format.eprintf "internal error: Machine_code.translate_ident %s@.@?" id;
+ assert false))
+
+(* specialize predefined (polymorphic) operators wrt their instances, so that
+ the C semantics is preserved *)
let specialize_to_c expr =
match expr.expr_desc with
| Expr_appl (id, e, r) ->
- if List.exists (fun e -> Types.is_bool_type e.expr_type) (expr_list_of_expr e)
- then let id =
- match id with
- | "=" -> "equi"
- | "!=" -> "xor"
- | _ -> id in
+ if
+ List.exists
+ (fun e -> Types.is_bool_type e.expr_type)
+ (expr_list_of_expr e)
+ then
+ let id = match id with "=" -> "equi" | "!=" -> "xor" | _ -> id in
{ expr with expr_desc = Expr_appl (id, e, r) }
else expr
- | _ -> expr
+ | _ ->
+ expr
let specialize_op expr =
- match !Options.output with
- | "C" -> specialize_to_c expr
- | _ -> expr
+ match !Options.output with "C" -> specialize_to_c expr | _ -> expr
let rec translate_expr env expr =
let expr = specialize_op expr in
let translate_expr = translate_expr env in
- let value_desc =
+ let value_desc =
match expr.expr_desc with
| Expr_const v ->
Cst v
@@ -115,21 +107,20 @@ let rec translate_expr env expr =
Array (List.map translate_expr el)
| Expr_access (t, i) ->
Access (translate_expr t, translate_expr (expr_of_dimension i))
- | Expr_power (e, n) ->
+ | Expr_power (e, n) ->
Power (translate_expr e, translate_expr (expr_of_dimension n))
| Expr_when (e1, _, _) ->
(translate_expr e1).value_desc
| Expr_appl (id, e, _) when Basic_library.is_expr_internal_fun expr ->
let nd = node_from_name id in
Fun (node_name nd, List.map translate_expr (expr_list_of_expr e))
- | Expr_ite (g,t,e) when Backends.is_functional () ->
- (* special treatment depending on the active backend. For
- functional ones, like horn backend, ite are preserved in
- expression. While they are removed for C or Java backends. *)
- Fun ("ite", [translate_expr g; translate_expr t; translate_expr e])
+ | Expr_ite (g, t, e) when Backends.is_functional () ->
+ (* special treatment depending on the active backend. For functional ones,
+ like horn backend, ite are preserved in expression. While they are
+ removed for C or Java backends. *)
+ Fun ("ite", [ translate_expr g; translate_expr t; translate_expr e ])
| _ ->
- Format.eprintf "Normalization error for backend %s: %a@."
- !Options.output
+ Format.eprintf "Normalization error for backend %s: %a@." !Options.output
Printers.pp_expr expr;
raise NormalizationError
in
@@ -137,7 +128,8 @@ let rec translate_expr env expr =
let translate_guard env expr =
match expr.expr_desc with
- | Expr_ident x -> translate_ident env x
+ | Expr_ident x ->
+ translate_ident env x
| _ ->
Format.eprintf "internal error: translate_guard %a@." Printers.pp_expr expr;
assert false
@@ -147,85 +139,87 @@ let rec translate_act env (y, expr) =
let translate_guard = translate_guard env in
(* let translate_ident = translate_ident env in *)
let translate_expr = translate_expr env in
- let lustre_eq = Corelang.mkeq Location.dummy_loc ([y.var_id], expr) in
+ let lustre_eq = Corelang.mkeq Location.dummy_loc ([ y.var_id ], expr) in
match expr.expr_desc with
| Expr_ite (c, t, e) ->
let c = translate_guard c in
let t, spec_t = translate_act (y, t) in
let e, spec_e = translate_act (y, e) in
- mk_conditional ~lustre_eq c [t] [e],
- mk_conditional_tr c spec_t spec_e
+ mk_conditional ~lustre_eq c [ t ] [ e ], mk_conditional_tr c spec_t spec_e
| Expr_merge (x, hl) ->
let var_x = env.get_var x in
- let hl, spec_hl = List.(split (map (fun (t, h) ->
- let h, spec_h = translate_act (y, h) in
- (t, [h]), (t, spec_h))
- hl)) in
- mk_branch' ~lustre_eq var_x hl,
- mk_branch_tr var_x spec_hl
+ let hl, spec_hl =
+ List.(
+ split
+ (map
+ (fun (t, h) ->
+ let h, spec_h = translate_act (y, h) in
+ (t, [ h ]), (t, spec_h))
+ hl))
+ in
+ mk_branch' ~lustre_eq var_x hl, mk_branch_tr var_x spec_hl
| _ ->
let e = translate_expr expr in
- mk_assign ~lustre_eq y e,
- mk_assign_tr y e
+ mk_assign ~lustre_eq y e, mk_assign_tr y e
-let get_memory env mems eq = match eq.eq_lhs, eq.eq_rhs.expr_desc with
- | ([x], Expr_pre _ | [x], Expr_fby _) when env.is_local x ->
+let get_memory env mems eq =
+ match eq.eq_lhs, eq.eq_rhs.expr_desc with
+ | ([ x ], Expr_pre _ | [ x ], Expr_fby _) when env.is_local x ->
let var_x = env.get_var x in
VSet.add var_x mems
- | _ -> mems
+ | _ ->
+ mems
-let get_memories env =
- List.fold_left (get_memory env) VSet.empty
+let get_memories env = List.fold_left (get_memory env) VSet.empty
(* Datastructure updated while visiting equations *)
type machine_ctx = {
(* memories *)
- m: ISet.t;
+ m : ISet.t;
(* Reset instructions *)
- si: instr_t list;
+ si : instr_t list;
(* Instances *)
- j: (Lustre_types.top_decl * Dimension.dim_expr list) IMap.t;
+ j : (Lustre_types.top_decl * Dimension.dim_expr list) IMap.t;
(* Step instructions *)
- s: instr_t list;
+ s : instr_t list;
(* Memory pack spec *)
- mp: mc_formula_t list;
+ mp : mc_formula_t list;
(* Transition spec *)
- t: (var_decl list (* inputs *)
- * var_decl list (* locals *)
- * var_decl list (* outputs *)
- * ISet.t (* memory footprint *)
- * mc_formula_t (* formula *)
- ) list;
+ t :
+ (var_decl list
+ (* inputs *)
+ * var_decl list
+ (* locals *)
+ * var_decl list
+ (* outputs *)
+ * ISet.t (* memory footprint *)
+ * mc_formula_t)
+ (* formula *)
+ list;
}
-let ctx_init = {
- m = ISet.empty;
- si = [];
- j = IMap.empty;
- s = [];
- mp = [];
- t = []
-}
+let ctx_init =
+ { m = ISet.empty; si = []; j = IMap.empty; s = []; mp = []; t = [] }
(****************************************************************)
-(* Main function to translate equations into this machine context we
- are building *)
+(* Main function to translate equations into this machine context we are
+ building *)
(****************************************************************)
-let mk_control v l inst =
- mkinstr
- (MBranch (vdecl_to_val v, [l, [inst]]))
+let mk_control v l inst = mkinstr (MBranch (vdecl_to_val v, [ l, [ inst ] ]))
let control_on_clock env ck inst =
- let rec aux (fspec, inst as acc) ck =
+ let rec aux ((fspec, inst) as acc) ck =
match (Clocks.repr ck).cdesc with
| Con (ck, cr, l) ->
let id = Clocks.const_of_carrier cr in
let v = env.get_var id in
- aux ((fun spec -> Imply (Equal (Var v, Tag l), fspec spec)),
- mk_control v l inst)
+ aux
+ ( (fun spec -> Imply (Equal (Var v, Tag l), fspec spec)),
+ mk_control v l inst )
ck
- | _ -> acc
+ | _ ->
+ acc
in
let fspec, inst = aux ((fun spec -> spec), inst) ck in
fspec, inst
@@ -234,60 +228,67 @@ let reset_instance env i r c =
match r with
| Some r ->
let r = translate_guard env r in
- let _, inst = control_on_clock env c
- (mk_conditional
- r
- [mkinstr (MSetReset i)]
- [mkinstr (MNoReset i)]) in
+ let _, inst =
+ control_on_clock env c
+ (mk_conditional r [ mkinstr (MSetReset i) ] [ mkinstr (MNoReset i) ])
+ in
Some r, [ inst ]
- | None -> None, []
+ | None ->
+ None, []
let translate_eq env ctx id inputs locals outputs i eq =
let translate_expr = translate_expr env in
let translate_act = translate_act env in
- let locals_pi = Lustre_live.inter_live_i_with id (i-1) locals in
- let outputs_pi = Lustre_live.inter_live_i_with id (i-1) outputs in
+ let locals_pi = Lustre_live.inter_live_i_with id (i - 1) locals in
+ let outputs_pi = Lustre_live.inter_live_i_with id (i - 1) outputs in
let locals_i = Lustre_live.inter_live_i_with id i locals in
let outputs_i = Lustre_live.inter_live_i_with id i outputs in
- let pred_mp ctx a =
- And [mk_memory_pack ~i:(i-1) id; a] :: ctx.mp in
+ let pred_mp ctx a = And [ mk_memory_pack ~i:(i - 1) id; a ] :: ctx.mp in
let pred_t ctx a =
- (inputs, locals_i, outputs_i, ctx.m,
- Exists
- (Lustre_live.existential_vars id i eq (locals @ outputs),
- And [
- mk_transition ~i:(i-1) id
- (vdecls_to_vals inputs)
- (vdecls_to_vals locals_pi)
- (vdecls_to_vals outputs_pi);
- a
- ]))
- :: ctx.t in
+ ( inputs,
+ locals_i,
+ outputs_i,
+ ctx.m,
+ Exists
+ ( Lustre_live.existential_vars id i eq (locals @ outputs),
+ And
+ [
+ mk_transition ~i:(i - 1) id (vdecls_to_vals inputs)
+ (vdecls_to_vals locals_pi)
+ (vdecls_to_vals outputs_pi);
+ a;
+ ] ) )
+ :: ctx.t
+ in
let control_on_clock ck inst spec_mp spec_t ctx =
let fspec, inst = control_on_clock env ck inst in
- { ctx with
- s = { inst with
- instr_spec = [
+ {
+ ctx with
+ s =
+ {
+ inst with
+ instr_spec =
+ [
mk_memory_pack ~i id;
- mk_transition ~i id
- (vdecls_to_vals inputs)
- (vdecls_to_vals locals_i)
- (vdecls_to_vals outputs_i)
- ] }
- :: ctx.s;
+ mk_transition ~i id (vdecls_to_vals inputs)
+ (vdecls_to_vals locals_i) (vdecls_to_vals outputs_i);
+ ];
+ }
+ :: ctx.s;
mp = pred_mp ctx spec_mp;
t = pred_t ctx (fspec spec_t);
}
in
let reset_instance = reset_instance env in
let mkinstr' = mkinstr ~lustre_eq:eq in
- let ctl ?(ck=eq.eq_rhs.expr_clock) instr =
- control_on_clock ck (mkinstr' instr) in
+ let ctl ?(ck = eq.eq_rhs.expr_clock) instr =
+ control_on_clock ck (mkinstr' instr)
+ in
- (* Format.eprintf "translate_eq %a with clock %a@."
- Printers.pp_node_eq eq Clocks.print_ck eq.eq_rhs.expr_clock; *)
+ (* Format.eprintf "translate_eq %a with clock %a@." Printers.pp_node_eq eq
+ Clocks.print_ck eq.eq_rhs.expr_clock; *)
match eq.eq_lhs, eq.eq_rhs.expr_desc with
- | [x], Expr_arrow (e1, e2) ->
+ | [ x ], Expr_arrow (e1, e2) ->
let var_x = env.get_var x in
let td = Arrow.arrow_top_decl () in
let inst = new_instance td eq.eq_rhs.expr_tag in
@@ -295,18 +296,19 @@ let translate_eq env ctx id inputs locals outputs i eq =
let c2 = translate_expr e2 in
assert (c1.value_desc = Cst (Const_tag "true"));
assert (c2.value_desc = Cst (Const_tag "false"));
- let ctx = ctl
- (MStep ([var_x], inst, [c1; c2]))
+ let ctx =
+ ctl
+ (MStep ([ var_x ], inst, [ c1; c2 ]))
(mk_memory_pack ~inst (node_name td))
- (mk_transition ~inst (node_name td) [] [] [vdecl_to_val var_x])
+ (mk_transition ~inst (node_name td) [] [] [ vdecl_to_val var_x ])
ctx
in
- { ctx with
+ {
+ ctx with
si = mkinstr (MSetReset inst) :: ctx.si;
j = IMap.add inst (td, []) ctx.j;
}
-
- | [x], Expr_pre e when env.is_local x ->
+ | [ x ], Expr_pre e when env.is_local x ->
let var_x = env.get_var x in
let e = translate_expr e in
ctl
@@ -314,20 +316,20 @@ let translate_eq env ctx id inputs locals outputs i eq =
(mk_state_variable_pack var_x)
(mk_state_assign_tr var_x e)
{ ctx with m = ISet.add x ctx.m }
-
- | [x], Expr_fby (e1, e2) when env.is_local x ->
+ | [ x ], Expr_fby (e1, e2) when env.is_local x ->
let var_x = env.get_var x in
let e2 = translate_expr e2 in
- let ctx = ctl
+ let ctx =
+ ctl
(MStateAssign (var_x, e2))
(mk_state_variable_pack var_x)
(mk_state_assign_tr var_x e2)
{ ctx with m = ISet.add x ctx.m }
in
- { ctx with
+ {
+ ctx with
si = mkinstr' (MStateAssign (var_x, translate_expr e1)) :: ctx.si;
}
-
| p, Expr_appl (f, arg, r)
when not (Basic_library.is_expr_internal_fun eq.eq_rhs) ->
let var_p = List.map (fun v -> env.get_var v) p in
@@ -336,100 +338,109 @@ let translate_eq env ctx id inputs locals outputs i eq =
let node_f = node_from_name f in
let call_f = node_f, NodeDep.filter_static_inputs (node_inputs node_f) el in
let inst = new_instance node_f eq.eq_rhs.expr_tag in
- let env_cks = List.fold_right (fun arg cks -> arg.expr_clock :: cks)
- el [eq.eq_rhs.expr_clock] in
- let call_ck = Clock_calculus.compute_root_clock
- (Clock_predef.ck_tuple env_cks) in
+ let env_cks =
+ List.fold_right
+ (fun arg cks -> arg.expr_clock :: cks)
+ el [ eq.eq_rhs.expr_clock ]
+ in
+ let call_ck =
+ Clock_calculus.compute_root_clock (Clock_predef.ck_tuple env_cks)
+ in
let r, reset_inst = reset_instance inst r call_ck in
- let ctx = ctl
- ~ck:call_ck
+ let ctx =
+ ctl ~ck:call_ck
(MStep (var_p, inst, vl))
(mk_memory_pack ~inst (node_name node_f))
(mk_transition ?r ~inst (node_name node_f) vl [] (vdecls_to_vals var_p))
ctx
in
- (*Clocks.new_var true in
- Clock_calculus.unify_imported_clock (Some call_ck) eq.eq_rhs.expr_clock eq.eq_rhs.expr_loc;
- Format.eprintf "call %a: %a: %a@," Printers.pp_expr eq.eq_rhs Clocks.print_ck (Clock_predef.ck_tuple env_cks) Clocks.print_ck call_ck;*)
- { ctx with
- si = if Stateless.check_node node_f
- then ctx.si else mkinstr (MSetReset inst) :: ctx.si;
+ (*Clocks.new_var true in Clock_calculus.unify_imported_clock (Some call_ck)
+ eq.eq_rhs.expr_clock eq.eq_rhs.expr_loc; Format.eprintf "call %a: %a:
+ %a@," Printers.pp_expr eq.eq_rhs Clocks.print_ck (Clock_predef.ck_tuple
+ env_cks) Clocks.print_ck call_ck;*)
+ {
+ ctx with
+ si =
+ (if Stateless.check_node node_f then ctx.si
+ else mkinstr (MSetReset inst) :: ctx.si);
j = IMap.add inst call_f ctx.j;
- s = (if Stateless.check_node node_f then [] else reset_inst)
- @ ctx.s;
+ s = (if Stateless.check_node node_f then [] else reset_inst) @ ctx.s;
}
-
- | [x], _ ->
+ | [ x ], _ ->
let var_x = env.get_var x in
let instr, spec = translate_act (var_x, eq.eq_rhs) in
control_on_clock eq.eq_rhs.expr_clock instr True spec ctx
-
| _ ->
Format.eprintf "internal error: Machine_code.translate_eq %a@?"
Printers.pp_node_eq eq;
assert false
let constant_equations locals =
- List.fold_left (fun eqs vdecl ->
- if vdecl.var_dec_const
- then
- { eq_lhs = [vdecl.var_id];
+ List.fold_left
+ (fun eqs vdecl ->
+ if vdecl.var_dec_const then
+ {
+ eq_lhs = [ vdecl.var_id ];
eq_rhs = desome vdecl.var_dec_value;
- eq_loc = vdecl.var_loc
- } :: eqs
+ eq_loc = vdecl.var_loc;
+ }
+ :: eqs
else eqs)
[] locals
let translate_eqs env ctx id inputs locals outputs eqs =
- List.fold_left (fun (ctx, i) eq ->
+ List.fold_left
+ (fun (ctx, i) eq ->
let ctx = translate_eq env ctx id inputs locals outputs i eq in
ctx, i + 1)
(ctx, 1) eqs
|> fst
-
(****************************************************************)
-(* Processing nodes *)
+(* Processing nodes *)
(****************************************************************)
let process_asserts nd =
-
- let exprl = List.map (fun assert_ -> assert_.assert_expr ) nd.node_asserts in
- if Backends.is_functional () then
- [], [], exprl
- else (* Each assert(e) is associated to a fresh variable v and declared as
- v=e; assert (v); *)
+ let exprl = List.map (fun assert_ -> assert_.assert_expr) nd.node_asserts in
+ if Backends.is_functional () then [], [], exprl
+ else
+ (* Each assert(e) is associated to a fresh variable v and declared as v=e;
+ assert (v); *)
let _, vars, eql, assertl =
- List.fold_left (fun (i, vars, eqlist, assertlist) expr ->
+ List.fold_left
+ (fun (i, vars, eqlist, assertlist) expr ->
let loc = expr.expr_loc in
let var_id = nd.node_id ^ "_assert_" ^ string_of_int i in
let assert_var =
- mkvar_decl
- loc
- ~orig:false (* fresh var *)
- (var_id,
- mktyp loc Tydec_bool,
- mkclock loc Ckdec_any,
- false, (* not a constant *)
- None, (* no default value *)
- Some nd.node_id
- )
+ mkvar_decl loc ~orig:false
+ (* fresh var *)
+ ( var_id,
+ mktyp loc Tydec_bool,
+ mkclock loc Ckdec_any,
+ false,
+ (* not a constant *)
+ None,
+ (* no default value *)
+ Some nd.node_id )
in
- assert_var.var_type <- Type_predef.type_bool (* Types.new_ty (Types.Tbool) *);
- let eq = mkeq loc ([var_id], expr) in
- (i+1,
- assert_var::vars,
- eq::eqlist,
- {expr with expr_desc = Expr_ident var_id}::assertlist)
- ) (1, [], [], []) exprl
+ assert_var.var_type <- Type_predef.type_bool
+ (* Types.new_ty (Types.Tbool) *);
+ let eq = mkeq loc ([ var_id ], expr) in
+ ( i + 1,
+ assert_var :: vars,
+ eq :: eqlist,
+ { expr with expr_desc = Expr_ident var_id } :: assertlist ))
+ (1, [], [], []) exprl
in
vars, eql, assertl
let translate_core env nid sorted_eqs inputs locals outputs =
let constant_eqs = constant_equations locals in
- (* Compute constants' instructions *)
- let ctx0 = translate_eqs env ctx_init nid inputs locals outputs constant_eqs in
+ (* Compute constants' instructions *)
+ let ctx0 =
+ translate_eqs env ctx_init nid inputs locals outputs constant_eqs
+ in
assert (ctx0.si = []);
assert (IMap.is_empty ctx0.j);
@@ -444,16 +455,17 @@ let memory_pack_0 nd =
{
mpname = nd;
mpindex = Some 0;
- mpformula = And [StateVarPack ResetFlag; Equal (Memory ResetFlag, Val zero)]
+ mpformula =
+ And [ StateVarPack ResetFlag; Equal (Memory ResetFlag, Val zero) ];
}
let memory_pack_toplevel nd i =
{
mpname = nd;
mpindex = None;
- mpformula = Ternary (Memory ResetFlag,
- StateVarPack ResetFlag,
- mk_memory_pack ~i nd.node_id)
+ mpformula =
+ Ternary
+ (Memory ResetFlag, StateVarPack ResetFlag, mk_memory_pack ~i nd.node_id);
}
let transition_0 nd =
@@ -464,7 +476,7 @@ let transition_0 nd =
tlocals = [];
toutputs = [];
tformula = True;
- tfootprint = ISet.empty
+ tfootprint = ISet.empty;
}
let transition_toplevel nd i =
@@ -474,12 +486,14 @@ let transition_toplevel nd i =
tinputs = nd.node_inputs;
tlocals = [];
toutputs = nd.node_outputs;
- tformula = ExistsMem (nd.node_id,
- Predicate (ResetCleared nd.node_id),
- mk_transition nd.node_id ~i
- (vdecls_to_vals (nd.node_inputs))
- []
- (vdecls_to_vals nd.node_outputs));
+ tformula =
+ ExistsMem
+ ( nd.node_id,
+ Predicate (ResetCleared nd.node_id),
+ mk_transition nd.node_id ~i
+ (vdecls_to_vals nd.node_inputs)
+ []
+ (vdecls_to_vals nd.node_outputs) );
tfootprint = ISet.empty;
}
@@ -487,7 +501,9 @@ let translate_decl nd sch =
(* Format.eprintf "Translating node %s@." nd.node_id; *)
(* Extracting eqs, variables .. *)
let eqs, auts = get_node_eqs nd in
- assert (auts = []); (* Automata should be expanded by now *)
+ assert (auts = []);
+
+ (* Automata should be expanded by now *)
(* In case of non functional backend (eg. C), additional local variables have
to be declared for each assert *)
@@ -505,23 +521,30 @@ let translate_decl nd sch =
(* Format.eprintf "ok1@.@?"; *)
let schedule = sch.Scheduling_type.schedule in
(* Format.eprintf "ok2@.@?"; *)
- let sorted_eqs, unused = Scheduling.sort_equations_from_schedule eqs schedule in
+ let sorted_eqs, unused =
+ Scheduling.sort_equations_from_schedule eqs schedule
+ in
+
(* Format.eprintf "ok3@.locals=%a@.inout:%a@?"
* VSet.pp locals
* VSet.pp inout_vars
* ; *)
-
let equations = assert_instrs @ sorted_eqs in
let mems = get_memories env equations in
(* Removing computed memories from locals. We also removed unused variables. *)
- let locals = List.filter
- (fun v -> not (VSet.mem v mems) && not (List.mem v.var_id unused)) locals in
+ let locals =
+ List.filter
+ (fun v -> (not (VSet.mem v mems)) && not (List.mem v.var_id unused))
+ locals
+ in
(* Compute live sets for spec *)
Lustre_live.set_live_of nd.node_id nd.node_outputs locals equations;
(* Translate equations *)
- let ctx, ctx0_s = translate_core env nd.node_id equations
- nd.node_inputs locals nd.node_outputs in
+ let ctx, ctx0_s =
+ translate_core env nd.node_id equations nd.node_inputs locals
+ nd.node_outputs
+ in
(* Format.eprintf "ok4@.@?"; *)
@@ -529,17 +552,17 @@ let translate_decl nd sch =
let mmap = IMap.bindings ctx.j in
let mmemory_packs =
memory_pack_0 nd
- :: List.mapi (fun i f ->
- {
- mpname = nd;
- mpindex = Some (i + 1);
- mpformula = red f
- }) (List.rev ctx.mp)
- @ [memory_pack_toplevel nd (List.length ctx.mp)]
+ ::
+ List.mapi
+ (fun i f -> { mpname = nd; mpindex = Some (i + 1); mpformula = red f })
+ (List.rev ctx.mp)
+ @ [ memory_pack_toplevel nd (List.length ctx.mp) ]
in
let mtransitions =
transition_0 nd
- :: List.mapi (fun i (tinputs, tlocals, toutputs, tfootprint, f) ->
+ ::
+ List.mapi
+ (fun i (tinputs, tlocals, toutputs, tfootprint, f) ->
{
tname = nd;
tindex = Some (i + 1);
@@ -547,48 +570,53 @@ let translate_decl nd sch =
tlocals;
toutputs;
tformula = red f;
- tfootprint
- }) (List.rev ctx.t)
- @ [transition_toplevel nd (List.length ctx.t)]
+ tfootprint;
+ })
+ (List.rev ctx.t)
+ @ [ transition_toplevel nd (List.length ctx.t) ]
+ in
+ let clear_reset =
+ mkinstr
+ ~instr_spec:
+ [
+ mk_memory_pack ~i:0 nd.node_id;
+ mk_transition ~i:0 nd.node_id (vdecls_to_vals nd.node_inputs) [] [];
+ ]
+ MClearReset
in
- let clear_reset = mkinstr ~instr_spec:[
- mk_memory_pack ~i:0 nd.node_id;
- mk_transition ~i:0 nd.node_id
- (vdecls_to_vals nd.node_inputs)
- []
- []] MClearReset in
{
mname = nd;
mmemory = VSet.elements mems;
mcalls = mmap;
- minstances = List.filter (fun (_, (n,_)) -> not (Stateless.check_node n)) mmap;
+ minstances =
+ List.filter (fun (_, (n, _)) -> not (Stateless.check_node n)) mmap;
minit = List.rev ctx.si;
mconst = List.rev ctx0_s;
mstatic = List.filter (fun v -> v.var_dec_const) nd.node_inputs;
- mstep = {
- step_inputs = nd.node_inputs;
- step_outputs = nd.node_outputs;
- step_locals = locals;
- step_checks = List.map (fun d -> d.Dimension.dim_loc,
- translate_expr env
- (expr_of_dimension d))
- nd.node_checks;
- step_instrs = clear_reset ::
- (* special treatment depending on the active backend. For horn backend,
- common branches are not merged while they are in C or Java
- backends. *)
- (if !Backends.join_guards then
- join_guards_list (List.rev ctx.s)
- else
- List.rev ctx.s);
- step_asserts = List.map (translate_expr env) nd_node_asserts;
- };
-
- (* Processing spec: there is no processing performed here. Contract
- have been processed already. Either one of the other machine is a
- cocospec node, or the current one is a cocospec node. Contract do
- not contain any statement or import. *)
-
+ mstep =
+ {
+ step_inputs = nd.node_inputs;
+ step_outputs = nd.node_outputs;
+ step_locals = locals;
+ step_checks =
+ List.map
+ (fun d ->
+ d.Dimension.dim_loc, translate_expr env (expr_of_dimension d))
+ nd.node_checks;
+ step_instrs =
+ clear_reset
+ ::
+ (* special treatment depending on the active backend. For horn
+ backend, common branches are not merged while they are in C or Java
+ backends. *)
+ (if !Backends.join_guards then join_guards_list (List.rev ctx.s)
+ else List.rev ctx.s);
+ step_asserts = List.map (translate_expr env) nd_node_asserts;
+ };
+ (* Processing spec: there is no processing performed here. Contract have
+ been processed already. Either one of the other machine is a cocospec
+ node, or the current one is a cocospec node. Contract do not contain any
+ statement or import. *)
mspec = { mnode_spec = nd.node_spec; mtransitions; mmemory_packs };
mannot = nd.node_annot;
msch = Some sch;
@@ -600,10 +628,10 @@ let translate_prog decls node_schs =
let machines =
List.map
(fun decl ->
- let node = node_of_top decl in
- let sch = IMap.find node.node_id node_schs in
- translate_decl node sch
- ) nodes
+ let node = node_of_top decl in
+ let sch = IMap.find node.node_id node_schs in
+ translate_decl node sch)
+ nodes
in
machines
diff --git a/src/machine_code.mli b/src/machine_code.mli
index f646b982850e10b60a1caa0b720b4ed7f6e9ac35..2347e209f4278ba43fa8247e1b8d34f31c9bdb95 100644
--- a/src/machine_code.mli
+++ b/src/machine_code.mli
@@ -1,4 +1,4 @@
-val translate_prog:
+val translate_prog :
Lustre_types.program_t ->
- Scheduling_type.schedule_report Utils.IMap.t ->
+ Scheduling_type.schedule_report Utils.IMap.t ->
Machine_code_types.machine_t list
diff --git a/src/machine_code_common.ml b/src/machine_code_common.ml
index 342a7520f8e97eb56c32ee75a3b69149f4c336ec..3248efb87811035e6162a86ff9193b142508a398 100644
--- a/src/machine_code_common.ml
+++ b/src/machine_code_common.ml
@@ -6,288 +6,299 @@ open Utils.Format
let print_statelocaltag = true
-let is_memory m id =
- (List.exists (fun o -> o.var_id = id.var_id) m.mmemory)
+let is_memory m id = List.exists (fun o -> o.var_id = id.var_id) m.mmemory
-let is_reset_flag id =
- id.var_id = "_reset"
+let is_reset_flag id = id.var_id = "_reset"
-let pp_vdecl fmt v =
- pp_print_string fmt v.var_id
+let pp_vdecl fmt v = pp_print_string fmt v.var_id
let rec pp_val m fmt v =
let pp_val = pp_val m in
match v.value_desc with
- | Cst c -> Printers.pp_const fmt c
- | Var v ->
+ | Cst c ->
+ Printers.pp_const fmt c
+ | Var v ->
if is_memory m v then
- if print_statelocaltag then
- fprintf fmt "{%s}" v.var_id
- else
- pp_print_string fmt v.var_id
- else
- if print_statelocaltag then
- fprintf fmt "%s" v.var_id
- else
- pp_vdecl fmt v
- | Array vl -> pp_print_bracketed pp_val fmt vl
- | Access (t, i) -> fprintf fmt "%a[%a]" pp_val t pp_val i
- | Power (v, n) -> fprintf fmt "(%a^%a)" pp_val v pp_val n
- | Fun (n, vl) -> fprintf fmt "%s%a" n (pp_print_parenthesized pp_val) vl
- | ResetFlag -> fprintf fmt "RESET"
+ if print_statelocaltag then fprintf fmt "{%s}" v.var_id
+ else pp_print_string fmt v.var_id
+ else if print_statelocaltag then fprintf fmt "%s" v.var_id
+ else pp_vdecl fmt v
+ | Array vl ->
+ pp_print_bracketed pp_val fmt vl
+ | Access (t, i) ->
+ fprintf fmt "%a[%a]" pp_val t pp_val i
+ | Power (v, n) ->
+ fprintf fmt "(%a^%a)" pp_val v pp_val n
+ | Fun (n, vl) ->
+ fprintf fmt "%s%a" n (pp_print_parenthesized pp_val) vl
+ | ResetFlag ->
+ fprintf fmt "RESET"
module PrintSpec = struct
-
let pp_reg fmt = function
- | ResetFlag -> pp_print_string fmt "{RESET}"
- | StateVar v -> fprintf fmt "{OUT:%a}" pp_vdecl v
-
- let pp_expr: type a. machine_t -> formatter -> (value_t, a) expression_t -> unit =
- fun m fmt -> function
- | Val v -> pp_val m fmt v
- | Tag t -> pp_print_string fmt t
- | Var v -> pp_vdecl fmt v
- | Memory r -> pp_reg fmt r
+ | ResetFlag ->
+ pp_print_string fmt "{RESET}"
+ | StateVar v ->
+ fprintf fmt "{OUT:%a}" pp_vdecl v
+
+ let pp_expr :
+ type a. machine_t -> formatter -> (value_t, a) expression_t -> unit =
+ fun m fmt -> function
+ | Val v ->
+ pp_val m fmt v
+ | Tag t ->
+ pp_print_string fmt t
+ | Var v ->
+ pp_vdecl fmt v
+ | Memory r ->
+ pp_reg fmt r
let pp_predicate m fmt p =
- let pp_expr: type a. formatter -> (value_t, a) expression_t -> unit =
- fun fmt e -> pp_expr m fmt e
+ let pp_expr : type a. formatter -> (value_t, a) expression_t -> unit =
+ fun fmt e -> pp_expr m fmt e
in
match p with
| Transition (f, inst, i, inputs, locals, outputs, _r, _mems) ->
- fprintf fmt "Transition_%a<%a>%a%a"
- pp_print_string f
- (pp_print_option ~none:(fun fmt () -> pp_print_string fmt "SELF")
- pp_print_string) inst
- (pp_print_option pp_print_int) i
- (pp_print_parenthesized pp_expr) (inputs @ locals @ outputs)
+ fprintf fmt "Transition_%a<%a>%a%a" pp_print_string f
+ (pp_print_option
+ ~none:(fun fmt () -> pp_print_string fmt "SELF")
+ pp_print_string)
+ inst
+ (pp_print_option pp_print_int)
+ i
+ (pp_print_parenthesized pp_expr)
+ (inputs @ locals @ outputs)
| Reset (f, inst, r) ->
- fprintf fmt "Reset_%a<%a> on %a"
- pp_print_string f
- pp_print_string inst
+ fprintf fmt "Reset_%a<%a> on %a" pp_print_string f pp_print_string inst
(pp_val m) r
| MemoryPack (f, inst, i) ->
- fprintf fmt "MemoryPack_%a<%a>%a"
- pp_print_string f
- (pp_print_option ~none:(fun fmt () -> pp_print_string fmt "SELF")
- pp_print_string) inst
- (pp_print_option pp_print_int) i
+ fprintf fmt "MemoryPack_%a<%a>%a" pp_print_string f
+ (pp_print_option
+ ~none:(fun fmt () -> pp_print_string fmt "SELF")
+ pp_print_string)
+ inst
+ (pp_print_option pp_print_int)
+ i
| ResetCleared f ->
fprintf fmt "ResetCleared_%a" pp_print_string f
- | Initialization -> ()
+ | Initialization ->
+ ()
let pp_spec m =
- let pp_expr: type a. formatter -> (value_t, a) expression_t -> unit =
- fun fmt e -> pp_expr m fmt e
+ let pp_expr : type a. formatter -> (value_t, a) expression_t -> unit =
+ fun fmt e -> pp_expr m fmt e
in
let rec pp_spec fmt f =
match f with
- | True -> pp_print_string fmt "true"
- | False -> pp_print_string fmt "false"
+ | True ->
+ pp_print_string fmt "true"
+ | False ->
+ pp_print_string fmt "false"
| Equal (a, b) ->
fprintf fmt "%a == %a" pp_expr a pp_expr b
| And fs ->
- pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ ∧ ")
- (fun fmt spec -> fprintf fmt "@[%a@]" pp_spec spec) fmt fs
+ pp_print_list
+ ~pp_sep:(fun fmt () -> fprintf fmt "@ ∧ ")
+ (fun fmt spec -> fprintf fmt "@[%a@]" pp_spec spec)
+ fmt fs
| Or fs ->
- pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ ∨ ")
- (fun fmt spec -> fprintf fmt "@[%a@]" pp_spec spec) fmt fs
+ pp_print_list
+ ~pp_sep:(fun fmt () -> fprintf fmt "@ ∨ ")
+ (fun fmt spec -> fprintf fmt "@[%a@]" pp_spec spec)
+ fmt fs
| Imply (a, b) ->
fprintf fmt "%a@ -> %a" pp_spec a pp_spec b
| Exists (xs, a) ->
fprintf fmt "@[<hv 2>∃ @[<h>%a,@]@ %a@]"
- (pp_comma_list Printers.pp_var) xs pp_spec a
+ (pp_comma_list Printers.pp_var)
+ xs pp_spec a
| Forall (xs, a) ->
fprintf fmt "@[<hv 2>∀ @[<h>%a,@]@ %a@]"
- (pp_comma_list Printers.pp_var) xs pp_spec a
+ (pp_comma_list Printers.pp_var)
+ xs pp_spec a
| Ternary (e, a, b) ->
- fprintf fmt "If %a Then (@[<hov>%a@]) Else (@[<hov>%a@])"
- pp_expr e pp_spec a pp_spec b
+ fprintf fmt "If %a Then (@[<hov>%a@]) Else (@[<hov>%a@])" pp_expr e
+ pp_spec a pp_spec b
| Predicate p ->
pp_predicate m fmt p
| StateVarPack r ->
fprintf fmt "StateVarPack<%a>" pp_reg r
| ExistsMem (_f, a, b) ->
- fprintf fmt "@[<hv 2>∃ MEM,@ %a@]" pp_spec (And [a; b])
+ fprintf fmt "@[<hv 2>∃ MEM,@ %a@]" pp_spec (And [ a; b ])
in
pp_spec
-
end
let pp_spec m =
if !Options.spec <> "no" then
- pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_prologue:pp_print_cut
+ pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_prologue:pp_print_cut
(fun fmt -> fprintf fmt "@[<h>--%@ %a@]" (PrintSpec.pp_spec m))
- else
- pp_print_nothing
+ else pp_print_nothing
let rec pp_instr m fmt i =
let pp_val = pp_val m in
let pp_branch = pp_branch m in
- begin match i.instr_desc with
- | MLocalAssign (i,v) -> fprintf fmt "%s := %a" i.var_id pp_val v
- | MStateAssign (i,v) -> fprintf fmt "{%s} := %a" i.var_id pp_val v
- | MResetAssign b -> fprintf fmt "RESET := %a" pp_print_bool b
- | MSetReset i -> fprintf fmt "set_reset %s" i
- | MClearReset -> fprintf fmt "clear_reset %s" m.mname.node_id
- | MNoReset i -> fprintf fmt "noreset %s" i
- | MStep (il, i, vl) ->
- fprintf fmt "%a := %s%a"
- (pp_comma_list pp_vdecl) il
- i
- (pp_print_parenthesized pp_val) vl
- | MBranch (g,hl) ->
- fprintf fmt "@[<v 2>case(%a) {@,%a@]@,}"
- pp_val g
- (pp_print_list ~pp_open_box:pp_open_vbox0 pp_branch) hl
- | MComment s -> pp_print_string fmt s
- | MSpec s -> pp_print_string fmt ("@" ^ s)
-
- end;
+ (match i.instr_desc with
+ | MLocalAssign (i, v) ->
+ fprintf fmt "%s := %a" i.var_id pp_val v
+ | MStateAssign (i, v) ->
+ fprintf fmt "{%s} := %a" i.var_id pp_val v
+ | MResetAssign b ->
+ fprintf fmt "RESET := %a" pp_print_bool b
+ | MSetReset i ->
+ fprintf fmt "set_reset %s" i
+ | MClearReset ->
+ fprintf fmt "clear_reset %s" m.mname.node_id
+ | MNoReset i ->
+ fprintf fmt "noreset %s" i
+ | MStep (il, i, vl) ->
+ fprintf fmt "%a := %s%a" (pp_comma_list pp_vdecl) il i
+ (pp_print_parenthesized pp_val)
+ vl
+ | MBranch (g, hl) ->
+ fprintf fmt "@[<v 2>case(%a) {@,%a@]@,}" pp_val g
+ (pp_print_list ~pp_open_box:pp_open_vbox0 pp_branch)
+ hl
+ | MComment s ->
+ pp_print_string fmt s
+ | MSpec s ->
+ pp_print_string fmt ("@" ^ s));
(* Annotation *)
(* let _ = *)
- (* match i.lustre_expr with None -> () | Some e -> fprintf fmt " -- original expr: %a" Printers.pp_expr e *)
+ (* match i.lustre_expr with None -> () | Some e -> fprintf fmt " -- original
+ expr: %a" Printers.pp_expr e *)
(* in *)
- begin match i.lustre_eq with
- | None -> ()
- | Some eq -> fprintf fmt " @[<h>-- original eq: %a@]" Printers.pp_node_eq eq
- end;
+ (match i.lustre_eq with
+ | None ->
+ ()
+ | Some eq ->
+ fprintf fmt " @[<h>-- original eq: %a@]" Printers.pp_node_eq eq);
pp_spec m fmt i.instr_spec
-
and pp_branch m fmt (t, h) =
fprintf fmt "@[<v 2>%s:@,%a@]" t
- (pp_print_list ~pp_open_box:pp_open_vbox0 (pp_instr m)) h
-
-let pp_instrs m =
- pp_print_list ~pp_open_box:pp_open_vbox0 (pp_instr m)
+ (pp_print_list ~pp_open_box:pp_open_vbox0 (pp_instr m))
+ h
+let pp_instrs m = pp_print_list ~pp_open_box:pp_open_vbox0 (pp_instr m)
(* merge log: get_node_def was in c0f8 *)
(* Returns the node/machine associated to id in m calls *)
let get_node_def id m =
try
- let (decl, _) = List.assoc id m.mcalls in
+ let decl, _ = List.assoc id m.mcalls in
Corelang.node_of_top decl
- with Not_found -> (
+ with Not_found ->
(* eprintf "Unable to find node %s in list [%a]@.@?" *)
(* id *)
- (* (Utils.fprintf_list ~sep:", " (fun fmt (n,_) -> fprintf fmt "%s" n)) m.mcalls *)
+ (* (Utils.fprintf_list ~sep:", " (fun fmt (n,_) -> fprintf fmt "%s" n))
+ m.mcalls *)
(* ; *)
raise Not_found
- )
-
+
(* merge log: machine_vars was in 44686 *)
-let machine_vars m = m.mstep.step_inputs @ m.mstep.step_locals @ m.mstep.step_outputs @ m.mmemory
+let machine_vars m =
+ m.mstep.step_inputs @ m.mstep.step_locals @ m.mstep.step_outputs @ m.mmemory
let pp_step m fmt s =
fprintf fmt
- "@[<v>\
- inputs : %a@ \
- outputs: %a@ \
- locals : %a@ \
- checks : %a@ \
- instrs : @[%a@]@ \
+ "@[<v>inputs : %a@ outputs: %a@ locals : %a@ checks : %a@ instrs : @[%a@]@ \
asserts : @[%a@]@]@ "
- (pp_comma_list Printers.pp_var) s.step_inputs
- (pp_comma_list Printers.pp_var) s.step_outputs
- (pp_comma_list Printers.pp_var) s.step_locals
+ (pp_comma_list Printers.pp_var)
+ s.step_inputs
+ (pp_comma_list Printers.pp_var)
+ s.step_outputs
+ (pp_comma_list Printers.pp_var)
+ s.step_locals
(pp_comma_list (fun fmt (_, c) -> pp_val m fmt c))
- s.step_checks
- (pp_instrs m) s.step_instrs
- (pp_comma_list (pp_val m)) s.step_asserts
+ s.step_checks (pp_instrs m) s.step_instrs
+ (pp_comma_list (pp_val m))
+ s.step_asserts
let pp_static_call fmt (node, args) =
- fprintf fmt "%s<%a>"
- (node_name node)
- (pp_comma_list Dimension.pp_dimension) args
+ fprintf fmt "%s<%a>" (node_name node)
+ (pp_comma_list Dimension.pp_dimension)
+ args
-let pp_instance fmt (o1, o2) =
- fprintf fmt "(%s, %a)"
- o1
- pp_static_call o2
+let pp_instance fmt (o1, o2) = fprintf fmt "(%s, %a)" o1 pp_static_call o2
let pp_memory_pack m fmt mp =
- fprintf fmt
- "@[<v 2>MemoryPack_%a<SELF>%a =@ %a@]"
- pp_print_string mp.mpname.node_id
- (pp_print_option pp_print_int) mp.mpindex
- (PrintSpec.pp_spec m) mp.mpformula
+ fprintf fmt "@[<v 2>MemoryPack_%a<SELF>%a =@ %a@]" pp_print_string
+ mp.mpname.node_id
+ (pp_print_option pp_print_int)
+ mp.mpindex (PrintSpec.pp_spec m) mp.mpformula
let pp_memory_packs m fmt =
if !Options.spec <> "no" then
- fprintf fmt
- "@[<v 2>memory_packs:@ %a@]"
- (pp_print_list (pp_memory_pack m))
- else
- pp_print_nothing fmt
+ fprintf fmt "@[<v 2>memory_packs:@ %a@]" (pp_print_list (pp_memory_pack m))
+ else pp_print_nothing fmt
let pp_transition m fmt t =
- fprintf fmt
- "@[<v 2>Transition_%a<SELF>%a%a =@ %a@]"
- pp_print_string t.tname.node_id
- (pp_print_option pp_print_int) t.tindex
- (pp_print_parenthesized pp_vdecl) (t.tinputs @ t.tlocals @ t.toutputs)
+ fprintf fmt "@[<v 2>Transition_%a<SELF>%a%a =@ %a@]" pp_print_string
+ t.tname.node_id
+ (pp_print_option pp_print_int)
+ t.tindex
+ (pp_print_parenthesized pp_vdecl)
+ (t.tinputs @ t.tlocals @ t.toutputs)
(PrintSpec.pp_spec m) t.tformula
let pp_transitions m fmt =
if !Options.spec <> "no" then
- fprintf fmt
- "@[<v 2>transitions:@ %a@]"
- (pp_print_list (pp_transition m))
- else
- pp_print_nothing fmt
+ fprintf fmt "@[<v 2>transitions:@ %a@]" (pp_print_list (pp_transition m))
+ else pp_print_nothing fmt
let pp_machine fmt m =
fprintf fmt
- "@[<v 2>machine %s@ \
- mem : %a@ \
- instances: %a@ \
- init : %a@ \
- const : %a@ \
- step :@ \
- @[<v 2>%a@]@ \
- spec : @[<v>%t@ %a@ @ %a@]@ \
- annot : @[%a@]@]@ "
+ "@[<v 2>machine %s@ mem : %a@ instances: %a@ init : %a@ const \
+ : %a@ step :@ @[<v 2>%a@]@ spec : @[<v>%t@ %a@ @ %a@]@ annot \
+ : @[%a@]@]@ "
m.mname.node_id
- (pp_comma_list Printers.pp_var) m.mmemory
- (pp_comma_list pp_instance) m.minstances
- (pp_instrs m) m.minit
- (pp_instrs m) m.mconst
- (pp_step m) m.mstep
- (fun fmt -> match m.mspec.mnode_spec with
- | None -> ()
- | Some (NodeSpec id) -> fprintf fmt "cocospec: %s" id
- | Some (Contract spec) -> Printers.pp_spec fmt spec)
- (pp_memory_packs m) m.mspec.mmemory_packs
- (pp_transitions m) m.mspec.mtransitions
- (pp_print_list Printers.pp_expr_annot) m.mannot
-
-let pp_machines =
- pp_print_list ~pp_open_box:pp_open_vbox0 pp_machine
+ (pp_comma_list Printers.pp_var)
+ m.mmemory
+ (pp_comma_list pp_instance)
+ m.minstances (pp_instrs m) m.minit (pp_instrs m) m.mconst (pp_step m)
+ m.mstep
+ (fun fmt ->
+ match m.mspec.mnode_spec with
+ | None ->
+ ()
+ | Some (NodeSpec id) ->
+ fprintf fmt "cocospec: %s" id
+ | Some (Contract spec) ->
+ Printers.pp_spec fmt spec)
+ (pp_memory_packs m) m.mspec.mmemory_packs (pp_transitions m)
+ m.mspec.mtransitions
+ (pp_print_list Printers.pp_expr_annot)
+ m.mannot
+
+let pp_machines = pp_print_list ~pp_open_box:pp_open_vbox0 pp_machine
let rec is_const_value v =
match v.value_desc with
- | Cst _ -> true
- | Fun (_, args) -> Basic_library.is_value_internal_fun v && List.for_all is_const_value args
- | _ -> false
+ | Cst _ ->
+ true
+ | Fun (_, args) ->
+ Basic_library.is_value_internal_fun v && List.for_all is_const_value args
+ | _ ->
+ false
(* Returns the declared stateless status and the computed one. *)
let get_stateless_status_node n =
- (n.node_dec_stateless,
- try
- Utils.desome n.node_stateless
- with _ -> failwith ("stateless status of machine " ^ n.node_id ^ " not computed"))
-
-let get_stateless_status_top_decl td = match td.top_decl_desc with
- | Node n -> get_stateless_status_node n
- | ImportedNode n -> n.nodei_stateless, false
- | _ -> true, false
-
-let get_stateless_status m =
- get_stateless_status_node m.mname
+ ( n.node_dec_stateless,
+ try Utils.desome n.node_stateless
+ with _ ->
+ failwith ("stateless status of machine " ^ n.node_id ^ " not computed") )
+
+let get_stateless_status_top_decl td =
+ match td.top_decl_desc with
+ | Node n ->
+ get_stateless_status_node n
+ | ImportedNode n ->
+ n.nodei_stateless, false
+ | _ ->
+ true, false
+
+let get_stateless_status m = get_stateless_status_node m.mname
let is_stateless m = m.minstances = [] && m.mmemory = []
@@ -299,16 +310,11 @@ let is_output m id =
let get_instr_spec i = i.instr_spec
-let mk_val v t =
- { value_desc = v;
- value_type = t;
- value_annot = None }
+let mk_val v t = { value_desc = v; value_type = t; value_annot = None }
-let vdecl_to_val vd =
- mk_val (Var vd) vd.var_type
+let vdecl_to_val vd = mk_val (Var vd) vd.var_type
-let vdecls_to_vals =
- List.map vdecl_to_val
+let vdecls_to_vals = List.map vdecl_to_val
let id_to_tag id =
let typ = (typedef_of_top (Hashtbl.find Corelang.tag_table id)).tydef_id in
@@ -319,9 +325,7 @@ let mk_conditional ?lustre_eq c t e =
(* (Ternary (Val c,
* And (List.map get_instr_spec t),
* And (List.map get_instr_spec e))) *)
- (MBranch(c, [
- (tag_true, t);
- (tag_false, e) ]))
+ (MBranch (c, [ tag_true, t; tag_false, e ]))
let mk_branch ?lustre_eq c br =
mkinstr ?lustre_eq
@@ -330,47 +334,56 @@ let mk_branch ?lustre_eq c br =
* br)) *)
(MBranch (c, br))
-let mk_branch' ?lustre_eq v =
- mk_branch ?lustre_eq (vdecl_to_val v)
+let mk_branch' ?lustre_eq v = mk_branch ?lustre_eq (vdecl_to_val v)
let mk_assign ?lustre_eq x v =
- mkinstr ?lustre_eq
- (* (Equal (Var x, Val v)) *)
- (MLocalAssign (x, v))
+ mkinstr ?lustre_eq (* (Equal (Var x, Val v)) *) (MLocalAssign (x, v))
let arrow_machine =
let state = "_first" in
- let var_state = dummy_var_decl state Type_predef.type_bool(* (Types.new_ty Types.Tbool) *) in
+ let var_state =
+ dummy_var_decl state Type_predef.type_bool
+ (* (Types.new_ty Types.Tbool) *)
+ in
let var_input1 = List.nth Arrow.arrow_desc.node_inputs 0 in
let var_input2 = List.nth Arrow.arrow_desc.node_inputs 1 in
let var_output = List.nth Arrow.arrow_desc.node_outputs 0 in
let cst b = mk_val (Cst (const_of_bool b)) Type_predef.type_bool in
- assert(var_input1.var_type = var_input2.var_type);
- let t_arg = var_input1.var_type in (* TODO Xavier: c'est bien la bonne def ? Guillaume: Bof preferable de reprendre le type des variables non ? *)
+ assert (var_input1.var_type = var_input2.var_type);
+ let t_arg = var_input1.var_type in
+ (* TODO Xavier: c'est bien la bonne def ? Guillaume: Bof preferable de
+ reprendre le type des variables non ? *)
{
mname = Arrow.arrow_desc;
- mmemory = [var_state];
+ mmemory = [ var_state ];
mcalls = [];
minstances = [];
- minit = [mkinstr (MStateAssign(var_state, cst true))];
+ minit = [ mkinstr (MStateAssign (var_state, cst true)) ];
mstatic = [];
mconst = [];
- mstep = {
- step_inputs = Arrow.arrow_desc.node_inputs;
- step_outputs = Arrow.arrow_desc.node_outputs;
- step_locals = [];
- step_checks = [];
- step_instrs = [mk_conditional (mk_val (Var var_state) Type_predef.type_bool)
- (List.map mkinstr
- [MStateAssign(var_state, cst false);
- MLocalAssign(var_output, mk_val (Var var_input1) t_arg)])
- (List.map mkinstr
- [MLocalAssign(var_output, mk_val (Var var_input2) t_arg)]) ];
- step_asserts = [];
- };
+ mstep =
+ {
+ step_inputs = Arrow.arrow_desc.node_inputs;
+ step_outputs = Arrow.arrow_desc.node_outputs;
+ step_locals = [];
+ step_checks = [];
+ step_instrs =
+ [
+ mk_conditional
+ (mk_val (Var var_state) Type_predef.type_bool)
+ (List.map mkinstr
+ [
+ MStateAssign (var_state, cst false);
+ MLocalAssign (var_output, mk_val (Var var_input1) t_arg);
+ ])
+ (List.map mkinstr
+ [ MLocalAssign (var_output, mk_val (Var var_input2) t_arg) ]);
+ ];
+ step_asserts = [];
+ };
mspec = { mnode_spec = None; mtransitions = []; mmemory_packs = [] };
mannot = [];
- msch = None
+ msch = None;
}
let empty_desc =
@@ -378,19 +391,19 @@ let empty_desc =
node_id = Arrow.arrow_id;
node_type = Types.bottom;
node_clock = Clocks.bottom;
- node_inputs= [];
- node_outputs= [];
- node_locals= [];
+ node_inputs = [];
+ node_outputs = [];
+ node_locals = [];
node_gencalls = [];
node_checks = [];
node_asserts = [];
- node_stmts= [];
+ node_stmts = [];
node_dec_stateless = true;
node_stateless = Some true;
node_spec = None;
node_annot = [];
node_iscontract = false;
-}
+ }
let empty_machine =
{
@@ -401,139 +414,167 @@ let empty_machine =
minit = [];
mstatic = [];
mconst = [];
- mstep = {
- step_inputs = [];
- step_outputs = [];
- step_locals = [];
- step_checks = [];
- step_instrs = [];
- step_asserts = [];
- };
+ mstep =
+ {
+ step_inputs = [];
+ step_outputs = [];
+ step_locals = [];
+ step_checks = [];
+ step_instrs = [];
+ step_asserts = [];
+ };
mspec = { mnode_spec = None; mtransitions = []; mmemory_packs = [] };
mannot = [];
- msch = None
+ msch = None;
}
let new_instance =
let cpt = ref (-1) in
fun callee tag ->
- begin
- let o =
- if Stateless.check_node callee then
- node_name callee
- else
- Printf.sprintf "ni_%d" (incr cpt; !cpt) in
- let o =
- if !Options.ansi && is_generic_node callee
- then Printf.sprintf "%s_inst_%d"
- o
- (incr cpt; !cpt)
- else o in
- o
- end
-
+ let o =
+ if Stateless.check_node callee then node_name callee
+ else
+ Printf.sprintf "ni_%d"
+ (incr cpt;
+ !cpt)
+ in
+ let o =
+ if !Options.ansi && is_generic_node callee then
+ Printf.sprintf "%s_inst_%d" o
+ (incr cpt;
+ !cpt)
+ else o
+ in
+ o
let get_machine_opt machines name =
List.fold_left
(fun res m ->
match res with
- | Some _ -> res
- | None -> if m.mname.node_id = name then Some m else None)
+ | Some _ ->
+ res
+ | None ->
+ if m.mname.node_id = name then Some m else None)
None machines
let get_machine machines node_name =
- try
- Utils.desome (get_machine_opt machines node_name)
- with Utils.DeSome ->
- eprintf "Unable to find machine %s in machines %a@.@?"
- node_name
- (Utils.fprintf_list ~sep:", " (fun fmt m -> pp_print_string fmt m.mname.node_id)) machines
- ; assert false
-
+ try Utils.desome (get_machine_opt machines node_name)
+ with Utils.DeSome ->
+ eprintf "Unable to find machine %s in machines %a@.@?" node_name
+ (Utils.fprintf_list ~sep:", " (fun fmt m ->
+ pp_print_string fmt m.mname.node_id))
+ machines;
+ assert false
+
let get_const_assign m id =
try
- match get_instr_desc (List.find
- (fun instr -> match get_instr_desc instr with
- | MLocalAssign (v, _) -> v == id
- | _ -> false)
- m.mconst
- ) with
- | MLocalAssign (_, e) -> e
- | _ -> assert false
+ match
+ get_instr_desc
+ (List.find
+ (fun instr ->
+ match get_instr_desc instr with
+ | MLocalAssign (v, _) ->
+ v == id
+ | _ ->
+ false)
+ m.mconst)
+ with
+ | MLocalAssign (_, e) ->
+ e
+ | _ ->
+ assert false
with Not_found -> assert false
-
let value_of_ident loc m id =
(* is is a state var *)
try
- let v = List.find (fun v -> v.var_id = id) m.mmemory
- in mk_val (Var v) v.var_type
- with Not_found ->
- try (* id is a node var *)
- let v = get_node_var id m.mname
- in mk_val (Var v) v.var_type
- with Not_found ->
- try (* id is a constant *)
- let c = Corelang.var_decl_of_const (const_of_top (Hashtbl.find Corelang.consts_table id))
- in mk_val (Var c) c.var_type
- with Not_found ->
- (* id is a tag *)
- let t = Const_tag id
- in mk_val (Cst t) (Typing.type_const loc t)
+ let v = List.find (fun v -> v.var_id = id) m.mmemory in
+ mk_val (Var v) v.var_type
+ with Not_found -> (
+ try
+ (* id is a node var *)
+ let v = get_node_var id m.mname in
+ mk_val (Var v) v.var_type
+ with Not_found -> (
+ try
+ (* id is a constant *)
+ let c =
+ Corelang.var_decl_of_const
+ (const_of_top (Hashtbl.find Corelang.consts_table id))
+ in
+ mk_val (Var c) c.var_type
+ with Not_found ->
+ (* id is a tag *)
+ let t = Const_tag id in
+ mk_val (Cst t) (Typing.type_const loc t)))
(* type of internal fun used in dimension expression *)
let type_of_value_appl f args =
- if List.mem f Basic_library.arith_funs
- then (List.hd args).value_type
+ if List.mem f Basic_library.arith_funs then (List.hd args).value_type
else Type_predef.type_bool
let rec value_of_dimension m dim =
match dim.Dimension.dim_desc with
- | Dimension.Dbool b ->
- mk_val (Cst (Const_tag (if b then tag_true else tag_false))) Type_predef.type_bool
- | Dimension.Dint i ->
- mk_val (Cst (Const_int i)) Type_predef.type_int
- | Dimension.Dident v -> value_of_ident dim.Dimension.dim_loc m v
+ | Dimension.Dbool b ->
+ mk_val
+ (Cst (Const_tag (if b then tag_true else tag_false)))
+ Type_predef.type_bool
+ | Dimension.Dint i ->
+ mk_val (Cst (Const_int i)) Type_predef.type_int
+ | Dimension.Dident v ->
+ value_of_ident dim.Dimension.dim_loc m v
| Dimension.Dappl (f, args) ->
- let vargs = List.map (value_of_dimension m) args
- in mk_val (Fun (f, vargs)) (type_of_value_appl f vargs)
- | Dimension.Dite (i, t, e) ->
- (match List.map (value_of_dimension m) [i; t; e] with
- | [vi; vt; ve] -> mk_val (Fun ("ite", [vi; vt; ve])) vt.value_type
- | _ -> assert false)
- | Dimension.Dlink dim' -> value_of_dimension m dim'
- | _ -> assert false
+ let vargs = List.map (value_of_dimension m) args in
+ mk_val (Fun (f, vargs)) (type_of_value_appl f vargs)
+ | Dimension.Dite (i, t, e) -> (
+ match List.map (value_of_dimension m) [ i; t; e ] with
+ | [ vi; vt; ve ] ->
+ mk_val (Fun ("ite", [ vi; vt; ve ])) vt.value_type
+ | _ ->
+ assert false)
+ | Dimension.Dlink dim' ->
+ value_of_dimension m dim'
+ | _ ->
+ assert false
let rec dimension_of_value value =
match value.value_desc with
- | Cst (Const_tag t) when t = tag_true -> Dimension.mkdim_bool Location.dummy_loc true
- | Cst (Const_tag t) when t = tag_false -> Dimension.mkdim_bool Location.dummy_loc false
- | Cst (Const_int i) -> Dimension.mkdim_int Location.dummy_loc i
- | Var v -> Dimension.mkdim_ident Location.dummy_loc v.var_id
- | Fun (f, args) -> Dimension.mkdim_appl Location.dummy_loc f (List.map dimension_of_value args)
- | _ -> assert false
-
+ | Cst (Const_tag t) when t = tag_true ->
+ Dimension.mkdim_bool Location.dummy_loc true
+ | Cst (Const_tag t) when t = tag_false ->
+ Dimension.mkdim_bool Location.dummy_loc false
+ | Cst (Const_int i) ->
+ Dimension.mkdim_int Location.dummy_loc i
+ | Var v ->
+ Dimension.mkdim_ident Location.dummy_loc v.var_id
+ | Fun (f, args) ->
+ Dimension.mkdim_appl Location.dummy_loc f (List.map dimension_of_value args)
+ | _ ->
+ assert false
let rec join_branches hl1 hl2 =
- match hl1, hl2 with
- | [] , _ -> hl2
- | _ , [] -> hl1
- | (t1, h1)::q1, (t2, h2)::q2 ->
- if t1 < t2 then (t1, h1) :: join_branches q1 hl2 else
- if t1 > t2 then (t2, h2) :: join_branches hl1 q2
- else (t1, List.fold_right join_guards h1 h2) :: join_branches q1 q2
+ match hl1, hl2 with
+ | [], _ ->
+ hl2
+ | _, [] ->
+ hl1
+ | (t1, h1) :: q1, (t2, h2) :: q2 ->
+ if t1 < t2 then (t1, h1) :: join_branches q1 hl2
+ else if t1 > t2 then (t2, h2) :: join_branches hl1 q2
+ else (t1, List.fold_right join_guards h1 h2) :: join_branches q1 q2
and join_guards inst1 insts2 =
- match get_instr_desc inst1, insts2 with
- | MBranch (x1, hl1),
- ({ instr_desc = MBranch (x2, hl2); _ } as inst2) :: insts2
- when x1 = x2 ->
- mkinstr
- ~instr_spec:(get_instr_spec inst1 @ get_instr_spec inst2)
- (* TODO on pourrait uniquement concatener les lustres de inst1 et hd(inst2) *)
- (MBranch (x1, join_branches (sort_handlers hl1) (sort_handlers hl2)))
- :: insts2
- | _ -> inst1 :: insts2
-
-let join_guards_list insts =
- List.fold_right join_guards insts []
+ match get_instr_desc inst1, insts2 with
+ | ( MBranch (x1, hl1),
+ ({ instr_desc = MBranch (x2, hl2); _ } as inst2) :: insts2 )
+ when x1 = x2 ->
+ mkinstr
+ ~instr_spec:(get_instr_spec inst1 @ get_instr_spec inst2)
+ (* TODO on pourrait uniquement concatener les lustres de inst1 et
+ hd(inst2) *)
+ (MBranch (x1, join_branches (sort_handlers hl1) (sort_handlers hl2)))
+ :: insts2
+ | _ ->
+ inst1 :: insts2
+
+let join_guards_list insts = List.fold_right join_guards insts []
diff --git a/src/machine_code_common.mli b/src/machine_code_common.mli
index 544666039befec17fe6c50826a8b34ba228c0edb..081fe19340d6b85f4008167a37b157f8787195f1 100644
--- a/src/machine_code_common.mli
+++ b/src/machine_code_common.mli
@@ -1,35 +1,114 @@
-val pp_val: Machine_code_types.machine_t -> Format.formatter -> Machine_code_types.value_t -> unit
-val is_memory: Machine_code_types.machine_t -> Lustre_types.var_decl -> bool
-val is_reset_flag: Lustre_types.var_decl -> bool
-val is_output: Machine_code_types.machine_t -> Lustre_types.var_decl -> bool
-val is_const_value: Machine_code_types.value_t -> bool
-val get_const_assign: Machine_code_types.machine_t -> Lustre_types.var_decl -> Machine_code_types.value_t
-val get_stateless_status: Machine_code_types.machine_t -> bool * bool
-val get_stateless_status_top_decl: Lustre_types.top_decl -> bool * bool
-val is_stateless: Machine_code_types.machine_t -> bool
-val mk_val: Machine_code_types.value_t_desc -> Types.type_expr -> Machine_code_types.value_t
-val vdecl_to_val: Lustre_types.var_decl -> Machine_code_types.value_t
-val vdecls_to_vals: Lustre_types.var_decl list -> Machine_code_types.value_t list
-val id_to_tag: Lustre_types.ident -> Machine_code_types.value_t
-val mk_conditional: ?lustre_eq:Lustre_types.eq -> Machine_code_types.value_t -> Machine_code_types.instr_t list -> Machine_code_types.instr_t list -> Machine_code_types.instr_t
-val mk_branch: ?lustre_eq:Lustre_types.eq -> Machine_code_types.value_t -> (Lustre_types.label * Machine_code_types.instr_t list) list -> Machine_code_types.instr_t
-val mk_branch': ?lustre_eq:Lustre_types.eq -> Lustre_types.var_decl -> (Lustre_types.label * Machine_code_types.instr_t list) list -> Machine_code_types.instr_t
-val mk_assign: ?lustre_eq:Lustre_types.eq -> Lustre_types.var_decl -> Machine_code_types.value_t -> Machine_code_types.instr_t
-val empty_machine: Machine_code_types.machine_t
-val arrow_machine: Machine_code_types.machine_t
-val new_instance: Lustre_types.top_decl -> Lustre_types.tag -> Lustre_types.ident
-val value_of_dimension: Machine_code_types.machine_t -> Dimension.dim_expr -> Machine_code_types.value_t
-val dimension_of_value:Machine_code_types.value_t -> Dimension.dim_expr
-val pp_instr: Machine_code_types.machine_t -> Format.formatter -> Machine_code_types.instr_t -> unit
-val pp_instrs: Machine_code_types.machine_t -> Format.formatter -> Machine_code_types.instr_t list -> unit
-val pp_machines: Format.formatter -> Machine_code_types.machine_t list -> unit
-val get_machine_opt: Machine_code_types.machine_t list -> string -> Machine_code_types.machine_t option
-
-(* Same function but fails if no such a machine exists *)
-val get_machine: Machine_code_types.machine_t list -> string -> Machine_code_types.machine_t
-
-val get_node_def: string -> Machine_code_types.machine_t -> Lustre_types.node_desc
-val join_guards_list: Machine_code_types.instr_t list -> Machine_code_types.instr_t list
-val machine_vars: Machine_code_types.machine_t -> Lustre_types.var_decl list
-
-module PrintSpec: sig val pp_spec: Machine_code_types.machine_t -> Format.formatter -> Machine_code_types.value_t Spec_types.formula_t -> unit end
+val pp_val :
+ Machine_code_types.machine_t ->
+ Format.formatter ->
+ Machine_code_types.value_t ->
+ unit
+
+val is_memory : Machine_code_types.machine_t -> Lustre_types.var_decl -> bool
+
+val is_reset_flag : Lustre_types.var_decl -> bool
+
+val is_output : Machine_code_types.machine_t -> Lustre_types.var_decl -> bool
+
+val is_const_value : Machine_code_types.value_t -> bool
+
+val get_const_assign :
+ Machine_code_types.machine_t ->
+ Lustre_types.var_decl ->
+ Machine_code_types.value_t
+
+val get_stateless_status : Machine_code_types.machine_t -> bool * bool
+
+val get_stateless_status_top_decl : Lustre_types.top_decl -> bool * bool
+
+val is_stateless : Machine_code_types.machine_t -> bool
+
+val mk_val :
+ Machine_code_types.value_t_desc ->
+ Types.type_expr ->
+ Machine_code_types.value_t
+
+val vdecl_to_val : Lustre_types.var_decl -> Machine_code_types.value_t
+
+val vdecls_to_vals :
+ Lustre_types.var_decl list -> Machine_code_types.value_t list
+
+val id_to_tag : Lustre_types.ident -> Machine_code_types.value_t
+
+val mk_conditional :
+ ?lustre_eq:Lustre_types.eq ->
+ Machine_code_types.value_t ->
+ Machine_code_types.instr_t list ->
+ Machine_code_types.instr_t list ->
+ Machine_code_types.instr_t
+
+val mk_branch :
+ ?lustre_eq:Lustre_types.eq ->
+ Machine_code_types.value_t ->
+ (Lustre_types.label * Machine_code_types.instr_t list) list ->
+ Machine_code_types.instr_t
+
+val mk_branch' :
+ ?lustre_eq:Lustre_types.eq ->
+ Lustre_types.var_decl ->
+ (Lustre_types.label * Machine_code_types.instr_t list) list ->
+ Machine_code_types.instr_t
+
+val mk_assign :
+ ?lustre_eq:Lustre_types.eq ->
+ Lustre_types.var_decl ->
+ Machine_code_types.value_t ->
+ Machine_code_types.instr_t
+
+val empty_machine : Machine_code_types.machine_t
+
+val arrow_machine : Machine_code_types.machine_t
+
+val new_instance :
+ Lustre_types.top_decl -> Lustre_types.tag -> Lustre_types.ident
+
+val value_of_dimension :
+ Machine_code_types.machine_t ->
+ Dimension.dim_expr ->
+ Machine_code_types.value_t
+
+val dimension_of_value : Machine_code_types.value_t -> Dimension.dim_expr
+
+val pp_instr :
+ Machine_code_types.machine_t ->
+ Format.formatter ->
+ Machine_code_types.instr_t ->
+ unit
+
+val pp_instrs :
+ Machine_code_types.machine_t ->
+ Format.formatter ->
+ Machine_code_types.instr_t list ->
+ unit
+
+val pp_machines : Format.formatter -> Machine_code_types.machine_t list -> unit
+
+val get_machine_opt :
+ Machine_code_types.machine_t list ->
+ string ->
+ Machine_code_types.machine_t option
+
+(* Same function but fails if no such a machine exists *)
+val get_machine :
+ Machine_code_types.machine_t list -> string -> Machine_code_types.machine_t
+
+val get_node_def :
+ string -> Machine_code_types.machine_t -> Lustre_types.node_desc
+
+val join_guards_list :
+ Machine_code_types.instr_t list -> Machine_code_types.instr_t list
+
+val machine_vars : Machine_code_types.machine_t -> Lustre_types.var_decl list
+
+module PrintSpec : sig
+ val pp_spec :
+ Machine_code_types.machine_t ->
+ Format.formatter ->
+ Machine_code_types.value_t Spec_types.formula_t ->
+ unit
+end
diff --git a/src/machine_code_types.ml b/src/machine_code_types.ml
index 297d25ee67fd14e7a5dfc963a08de0072f0e8b70..7bd08add3512cdd5f5ed5e88c1321192582bfc31 100644
--- a/src/machine_code_types.ml
+++ b/src/machine_code_types.ml
@@ -2,12 +2,12 @@
open Lustre_types
open Spec_types
-type value_t =
- {
- value_desc: value_t_desc;
- value_type: Types.type_expr;
- value_annot: expr_annot option
- }
+type value_t = {
+ value_desc : value_t_desc;
+ value_type : Types.type_expr;
+ value_annot : expr_annot option;
+}
+
and value_t_desc =
| Cst of constant
| Var of var_decl
@@ -19,13 +19,16 @@ and value_t_desc =
type mc_formula_t = value_t formula_t
-type instr_t =
- {
- instr_desc: instr_t_desc; (* main data: the content *)
- (* lustre_expr: expr option; (* possible representation as a lustre expression *) *)
- lustre_eq: eq option; (* possible representation as a lustre flow equation *)
- instr_spec: mc_formula_t list
- }
+type instr_t = {
+ instr_desc : instr_t_desc;
+ (* main data: the content *)
+ (* lustre_expr: expr option; (* possible representation as a lustre expression
+ *) *)
+ lustre_eq : eq option;
+ (* possible representation as a lustre flow equation *)
+ instr_spec : mc_formula_t list;
+}
+
and instr_t_desc =
| MLocalAssign of var_decl * value_t
| MStateAssign of var_decl * value_t
@@ -36,38 +39,43 @@ and instr_t_desc =
| MStep of var_decl list * ident * value_t list
| MBranch of value_t * (label * instr_t list) list
| MComment of string
- | MSpec of string
+ | MSpec of string
type step_t = {
- step_checks: (Location.t * value_t) list;
- step_inputs: var_decl list;
- step_outputs: var_decl list;
- step_locals: var_decl list;
- step_instrs: instr_t list;
- step_asserts: value_t list;
- }
+ step_checks : (Location.t * value_t) list;
+ step_inputs : var_decl list;
+ step_outputs : var_decl list;
+ step_locals : var_decl list;
+ step_instrs : instr_t list;
+ step_asserts : value_t list;
+}
-type static_call = top_decl * (Dimension.dim_expr list)
+type static_call = top_decl * Dimension.dim_expr list
type mc_transition_t = value_t transition_t
+
type mc_memory_pack_t = value_t memory_pack_t
type machine_spec = {
- mnode_spec: node_spec_t option;
- mtransitions: mc_transition_t list;
- mmemory_packs: mc_memory_pack_t list
+ mnode_spec : node_spec_t option;
+ mtransitions : mc_transition_t list;
+ mmemory_packs : mc_memory_pack_t list;
}
-
+
type machine_t = {
- mname: node_desc;
- mmemory: var_decl list;
- mcalls: (ident * static_call) list; (* map from stateful/stateless instance to node, no internals *)
- minstances: (ident * static_call) list; (* sub-map of mcalls, from stateful instance to node *)
- minit: instr_t list;
- mstatic: var_decl list; (* static inputs only *)
- mconst: instr_t list; (* assignments of node constant locals *)
- mstep: step_t;
- mspec: machine_spec;
- mannot: expr_annot list;
- msch: Scheduling_type.schedule_report option; (* Equations scheduling *)
+ mname : node_desc;
+ mmemory : var_decl list;
+ mcalls : (ident * static_call) list;
+ (* map from stateful/stateless instance to node, no internals *)
+ minstances : (ident * static_call) list;
+ (* sub-map of mcalls, from stateful instance to node *)
+ minit : instr_t list;
+ mstatic : var_decl list;
+ (* static inputs only *)
+ mconst : instr_t list;
+ (* assignments of node constant locals *)
+ mstep : step_t;
+ mspec : machine_spec;
+ mannot : expr_annot list;
+ msch : Scheduling_type.schedule_report option; (* Equations scheduling *)
}
diff --git a/src/main_lustre_compiler.ml b/src/main_lustre_compiler.ml
index 15cfb58e90ec3c295ee9d3ad8caff5b31ba7715a..46192fa69d7989e9997334c2483cb56b7aa056bd 100644
--- a/src/main_lustre_compiler.ml
+++ b/src/main_lustre_compiler.ml
@@ -11,13 +11,11 @@
open Format
open Compiler_common
-
open Utils
-
let usage = "Usage: lustrec [options] \x1b[4msource file\x1b[0m"
-let extensions = [".ec"; ".lus"; ".lusi"]
+let extensions = [ ".ec"; ".lus"; ".lusi" ]
(* print a .lusi header file from a source prog *)
let print_lusi prog dirname basename extension =
@@ -25,17 +23,10 @@ let print_lusi prog dirname basename extension =
let header_name = dirname ^ "/" ^ basename ^ extension in
let h_out = open_out header_name in
let h_fmt = formatter_of_out_channel h_out in
- begin
- Typing.uneval_prog_generics header;
- Clock_calculus.uneval_prog_generics header;
- Printers.pp_lusi_header h_fmt basename header;
- close_out h_out
- end
-
-
-
-
-
+ Typing.uneval_prog_generics header;
+ Clock_calculus.uneval_prog_generics header;
+ Printers.pp_lusi_header h_fmt basename header;
+ close_out h_out
(* compile a .lus source file *)
let compile dirname basename extension =
@@ -45,92 +36,81 @@ let compile dirname basename extension =
(* Parsing source *)
let prog = parse source_name extension in
-
+
let prog =
- if !Options.mpfr &&
- extension = ".lus" (* trying to avoid the injection of the module for lusi files *)
- then
- Lustrec_mpfr.mpfr_module::prog
- else
- prog
+ if
+ !Options.mpfr && extension = ".lus"
+ (* trying to avoid the injection of the module for lusi files *)
+ then Lustrec_mpfr.mpfr_module :: prog
+ else prog
in
let params = Backends.get_normalization_params () in
- let prog, dependencies =
- Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. Phase 1: Normalisation@,");
- try
- Compiler_stages.stage1 params prog dirname basename extension
- with Compiler_stages.StopPhase1 prog -> (
- if !Options.lusi then
- begin
- let lusi_ext = extension ^ "i" in
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating interface file %s@ " (basename ^ lusi_ext));
- print_lusi prog dirname basename lusi_ext;
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");
- exit 0
- end
+ let prog, dependencies =
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@[<v 2>.. Phase 1: Normalisation@,");
+ try Compiler_stages.stage1 params prog dirname basename extension
+ with Compiler_stages.StopPhase1 prog ->
+ if !Options.lusi then (
+ let lusi_ext = extension ^ "i" in
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt ".. generating interface file %s@ " (basename ^ lusi_ext));
+ print_lusi prog dirname basename lusi_ext;
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");
+ exit 0)
else if !Options.print_nodes then (
Format.printf "%a@.@?" Printers.pp_node_list prog;
- exit 0
- )
- else
- assert false
- )
+ exit 0)
+ else assert false
in
- Log.report ~level:3 (fun fmt -> fprintf fmt "@ @[<v 2>.. Normalized program:@ %a@]"
- Printers.pp_prog prog);
+ Log.report ~level:3 (fun fmt ->
+ fprintf fmt "@ @[<v 2>.. Normalized program:@ %a@]" Printers.pp_prog prog);
- Log.report ~level:1 (fun fmt -> fprintf fmt "@]@ @ @[<v 2>.. Phase 2 : Machines generation@,");
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@]@ @ @[<v 2>.. Phase 2 : Machines generation@,");
- let prog, machine_code =
- Compiler_stages.stage2 params prog
- in
+ let prog, machine_code = Compiler_stages.stage2 params prog in
- Log.report ~level:3 (fun fmt -> fprintf fmt "@ @[<v 2>.. Generated machines:@ %a@]"
- Machine_code_common.pp_machines machine_code);
-
- if Scopes.Plugin.show_scopes () then
- begin
- let all_scopes = 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@ @]@ @?" Scopes.print_scopes all_scopes;
- exit 0
-
- end;
+ Log.report ~level:3 (fun fmt ->
+ fprintf fmt "@ @[<v 2>.. Generated machines:@ %a@]"
+ Machine_code_common.pp_machines machine_code);
+
+ if Scopes.Plugin.show_scopes () then (
+ let all_scopes = 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@ @]@ @?" Scopes.print_scopes all_scopes;
+ exit 0);
let machine_code = Plugins.refine_machine_code prog machine_code in
Log.report ~level:1 (fun fmt -> fprintf fmt "@]@ @ ");
-
+
Compiler_stages.stage3 prog machine_code dependencies basename extension;
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. done !@]@.");
- (* We stop the process here *)
- exit 0
- end
+ Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. done !@]@.");
+ (* We stop the process here *)
+ exit 0
let compile dirname basename extension =
Plugins.init ();
match extension with
- | ".lusi"
- | ".lus" -> compile dirname basename extension
- | _ -> assert false
+ | ".lusi" | ".lus" ->
+ compile dirname basename extension
+ | _ ->
+ assert false
let anonymous filename =
- let ok_ext, ext = List.fold_left
- (fun (ok, ext) ext' ->
- if not ok && Filename.check_suffix filename ext' then
- true, ext'
- else
- ok, ext)
- (false, "") extensions in
- if ok_ext then begin
- Options_management.setup();
+ let ok_ext, ext =
+ List.fold_left
+ (fun (ok, ext) ext' ->
+ if (not ok) && Filename.check_suffix filename ext' then true, ext'
+ else ok, ext)
+ (false, "") extensions
+ in
+ if ok_ext then (
+ Options_management.setup ();
let dirname = Filename.dirname filename in
let basename = Filename.chop_suffix (Filename.basename filename) ext in
- compile dirname basename ext
- end else
- raise (Arg.Bad ("Can only compile *.lusi, *.lus or *.ec files"))
+ compile dirname basename ext)
+ else raise (Arg.Bad "Can only compile *.lusi, *.lus or *.ec files")
let _ =
Global.initialize ();
@@ -138,20 +118,22 @@ let _ =
try
Printexc.record_backtrace true;
- let options = Options_management.lustrec_options @ (Plugins.options ()) in
-
+ let options = Options_management.lustrec_options @ Plugins.options () in
+
Arg.parse options anonymous usage
with
- | Parse.Error | Types.Error (_,_) | Clocks.Error (_,_) ->
+ | Parse.Error | Types.Error (_, _) | Clocks.Error (_, _) ->
exit 1
- | Error.Error (loc , kind) (*| Task_set.Error _*) ->
+ | Error.Error (loc, kind) (*| Task_set.Error _*) ->
Error.pp_error loc (fun fmt -> Error.pp_error_msg fmt kind);
exit (Error.return_code kind)
- (* | Causality.Error _ -> exit (Error.return_code Error.AlgebraicLoop) *)
+ (* | Causality.Error _ -> exit (Error.return_code Error.AlgebraicLoop) *)
| Sys_error msg ->
- (eprintf "Failure: %s@." msg); exit 1
+ eprintf "Failure: %s@." msg;
+ exit 1
| exc ->
- (track_exception (); raise exc)
+ track_exception ();
+ raise exc
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/main_lustre_testgen.ml b/src/main_lustre_testgen.ml
index 5c8820d1d6f7465989042d1b9f294f4582b0e46d..36b6fdb8ae8a551f355f753d6a0e3728a96f5535 100644
--- a/src/main_lustre_testgen.ml
+++ b/src/main_lustre_testgen.ml
@@ -13,30 +13,24 @@
open Format
open Log
-
open Utils
open Compiler_common
let usage = "Usage: lustret [options] \x1b[4msource file\x1b[0m"
-let extensions = [".lus"]
+let extensions = [ ".lus" ]
-let pp_trace trace_filename mutation_list =
+let pp_trace trace_filename mutation_list =
let trace_file = open_out trace_filename in
let trace_fmt = formatter_of_out_channel trace_file in
Format.fprintf trace_fmt "@[<v 2>{@ %a@ }@]"
- (fprintf_list
- ~sep:",@ "
- (fun fmt (mutation, mutation_loc, mutant_name) ->
- Format.fprintf fmt "\"%s\": { @[<v 0>%a,@ %a@ }@]"
- mutant_name
- Mutation.print_directive_json mutation
- Mutation.print_loc_json mutation_loc
- ))
+ (fprintf_list ~sep:",@ " (fun fmt (mutation, mutation_loc, mutant_name) ->
+ Format.fprintf fmt "\"%s\": { @[<v 0>%a,@ %a@ }@]" mutant_name
+ Mutation.print_directive_json mutation Mutation.print_loc_json
+ mutation_loc))
mutation_list;
- Format.fprintf trace_fmt "@.@?"
-
-
+ Format.fprintf trace_fmt "@.@?"
+
let testgen_source dirname basename extension =
let source_name = dirname ^ "/" ^ basename ^ extension in
@@ -46,31 +40,26 @@ let testgen_source dirname basename extension =
let prog = parse source_name extension in
let params = Backends.get_normalization_params () in
let prog, _ =
- try
- Compiler_stages.stage1 params prog dirname basename extension
- with Compiler_stages.StopPhase1 prog -> (
- if !Options.print_nodes then (
- Format.printf "%a@.@?" Printers.pp_node_list prog;
- exit 0
- )
- else
- assert false
- )
+ try Compiler_stages.stage1 params prog dirname basename extension
+ with Compiler_stages.StopPhase1 prog ->
+ if !Options.print_nodes then (
+ Format.printf "%a@.@?" Printers.pp_node_list prog;
+ exit 0)
+ else assert false
in
-
- (* Two cases
- - generation of coverage conditions
- - generation of mutants: a number of mutated lustre files
- *)
-
+
+ (* Two cases - generation of coverage conditions - generation of mutants: a
+ number of mutated lustre files *)
if !Options.gen_mcdc then (
let prog_mcdc = PathConditions.mcdc prog in
(* We re-type the fresh equations *)
(*let _ = Modules.load ~is_header:false prog_mcdc in*)
let _ = type_decls !Global.type_env prog_mcdc in
-
+
let destname = !Options.dest_dir ^ "/" ^ basename in
- let source_file = destname ^ ".mcdc" in (* Could be changed *)
+ let source_file = destname ^ ".mcdc" in
+
+ (* Could be changed *)
(* Modified Lustre is produced in fresh .lus file *)
let source_lus = source_file ^ ".lus" in
@@ -79,113 +68,119 @@ let testgen_source dirname basename extension =
Printers.pp_prog fmt prog_mcdc;
Format.fprintf fmt "@.@?";
- (* Prog is
- (1) cleaned from initial equations TODO
- (2) produced as EMF
- *)
+ (* Prog is (1) cleaned from initial equations TODO (2) produced as EMF *)
Options.output := "emf";
let params = Backends.get_normalization_params () in
let prog_mcdc = Normalization.normalize_prog params prog_mcdc in
let prog_mcdc, machine_code = Compiler_stages.stage2 params prog_mcdc in
- let source_emf = source_file ^ ".emf" in
+ let source_emf = source_file ^ ".emf" in
let source_out = open_out source_emf in
let fmt = formatter_of_out_channel source_out in
EMF_backend.translate fmt basename prog_mcdc machine_code;
- exit 0
- ) ;
+ exit 0);
-
(* generate mutants *)
let mutants = Mutation.mutate !Options.nb_mutants prog in
-
+
(* Print generated mutants in target directory. *)
let cpt = ref 0 in
let mutation_list =
- List.map (fun (mutation, mutation_loc, mutant) ->
- (* Debugging code *)
- (* if List.mem !cpt [238;371;601;799;875;998] then *)
- (* Format.eprintf "Mutant %i: %a -> %a" !cpt Printers.pp_expr orig_e Printers.pp_expr new_e *)
- (* ; *)
- incr cpt;
- let mutant_basename = (Filename.basename basename)^ ".mutant.n" ^ (string_of_int !cpt) ^ extension in
- let mutant_filename =
- match !Options.dest_dir with
- | "" -> (* Mutants are generated in source directory *)
- basename^ ".mutant.n" ^ (string_of_int !cpt) ^ extension
- | dir -> (* Mutants are generated in target directory *)
- dir ^ "/" ^ mutant_basename
- in
- let mutant_out = (
- try
- open_out mutant_filename
- with
- Sys_error _ -> Format.eprintf "Unable to open file %s for writing.@." mutant_filename; exit 1
- )
- in
- let mutant_fmt = formatter_of_out_channel mutant_out in
- report ~level:1 (fun fmt -> fprintf fmt ".. generating mutant %s: %a@,@?"
- mutant_filename
- Mutation.print_directive mutation
- );
- Format.fprintf mutant_fmt "%a@." Printers.pp_prog mutant;
- mutation, mutation_loc, mutant_basename
- )
+ List.map
+ (fun (mutation, mutation_loc, mutant) ->
+ (* Debugging code *)
+ (* if List.mem !cpt [238;371;601;799;875;998] then *)
+ (* Format.eprintf "Mutant %i: %a -> %a" !cpt Printers.pp_expr orig_e
+ Printers.pp_expr new_e *)
+ (* ; *)
+ incr cpt;
+ let mutant_basename =
+ Filename.basename basename ^ ".mutant.n" ^ string_of_int !cpt
+ ^ extension
+ in
+ let mutant_filename =
+ match !Options.dest_dir with
+ | "" ->
+ (* Mutants are generated in source directory *)
+ basename ^ ".mutant.n" ^ string_of_int !cpt ^ extension
+ | dir ->
+ (* Mutants are generated in target directory *)
+ dir ^ "/" ^ mutant_basename
+ in
+ let mutant_out =
+ try open_out mutant_filename
+ with Sys_error _ ->
+ Format.eprintf "Unable to open file %s for writing.@."
+ mutant_filename;
+ exit 1
+ in
+ let mutant_fmt = formatter_of_out_channel mutant_out in
+ report ~level:1 (fun fmt ->
+ fprintf fmt ".. generating mutant %s: %a@,@?" mutant_filename
+ Mutation.print_directive mutation);
+ Format.fprintf mutant_fmt "%a@." Printers.pp_prog mutant;
+ mutation, mutation_loc, mutant_basename)
mutants
in
Log.report ~level:1 (fun fmt -> fprintf fmt ".. done @ @]@.");
-
+
(* Printing traceability *)
- let trace_filename =
+ let trace_filename =
match !Options.dest_dir with
- | "" -> (* Mutant report is generated in source directory *)
- basename^ ".mutation.json"
- | dir -> (* Mutants are generated in target directory *)
- dir ^ "/" ^ (Filename.basename basename)^ ".mutation.json"
+ | "" ->
+ (* Mutant report is generated in source directory *)
+ basename ^ ".mutation.json"
+ | dir ->
+ (* Mutants are generated in target directory *)
+ dir ^ "/" ^ Filename.basename basename ^ ".mutation.json"
in
pp_trace trace_filename mutation_list;
(* Printing the CMakeLists.txt file *)
- let cmakelists =
- (if !Options.dest_dir = "" then "" else !Options.dest_dir ^ "/") ^ "CMakeLists.txt"
+ let cmakelists =
+ (if !Options.dest_dir = "" then "" else !Options.dest_dir ^ "/")
+ ^ "CMakeLists.txt"
in
let cmake_file = open_out cmakelists in
let cmake_fmt = formatter_of_out_channel cmake_file in
Format.fprintf cmake_fmt "cmake_minimum_required(VERSION 3.5)@.";
- Format.fprintf cmake_fmt "include(\"%s/helpful_functions.cmake\")@." Version.testgen_path;
- Format.fprintf cmake_fmt "include(\"%s/FindLustre.cmake\")@." Version.testgen_path;
+ Format.fprintf cmake_fmt "include(\"%s/helpful_functions.cmake\")@."
+ Version.testgen_path;
+ Format.fprintf cmake_fmt "include(\"%s/FindLustre.cmake\")@."
+ Version.testgen_path;
Format.fprintf cmake_fmt "LUSTREFILES(LFILES ${CMAKE_CURRENT_SOURCE_DIR} )@.";
Format.fprintf cmake_fmt "@[<v 2>FOREACH(lus_file ${LFILES})@ ";
Format.fprintf cmake_fmt "get_lustre_name_ext(${lus_file} L E)@ ";
Format.fprintf cmake_fmt "Lustre_Compile(@[<v 0>@ ";
- if !Options.main_node <> "" then Format.fprintf cmake_fmt "NODE \"%s_mutant\"@ " !Options.main_node;
+ if !Options.main_node <> "" then
+ Format.fprintf cmake_fmt "NODE \"%s_mutant\"@ " !Options.main_node;
Format.fprintf cmake_fmt "LIBNAME \"${L}_%s_mutant\"@ " !Options.main_node;
Format.fprintf cmake_fmt "LUS_FILES \"${lus_file}\")@]@]@.";
Format.fprintf cmake_fmt "ENDFOREACH()@.@?";
-
-
+
(* We stop the process here *)
exit 0
-
+
let testgen dirname basename extension =
match extension with
- | ".lus" -> testgen_source dirname basename extension
- | _ -> assert false
+ | ".lus" ->
+ testgen_source dirname basename extension
+ | _ ->
+ assert false
let anonymous filename =
- let ok_ext, ext = List.fold_left
- (fun (ok, ext) ext' ->
- if not ok && Filename.check_suffix filename ext' then
- true, ext'
- else
- ok, ext)
- (false, "") extensions in
+ let ok_ext, ext =
+ List.fold_left
+ (fun (ok, ext) ext' ->
+ if (not ok) && Filename.check_suffix filename ext' then true, ext'
+ else ok, ext)
+ (false, "") extensions
+ in
if ok_ext then
let dirname = Filename.dirname filename in
let basename = Filename.chop_suffix (Filename.basename filename) ext in
testgen dirname basename ext
- else
- raise (Arg.Bad ("Can only compile *.lus files"))
+ else raise (Arg.Bad "Can only compile *.lus files")
let _ =
Global.initialize ();
@@ -193,18 +188,22 @@ let _ =
try
Printexc.record_backtrace true;
- let options = Options_management.lustret_options
+ let options = Options_management.lustret_options in
- in
-
Arg.parse options anonymous usage
with
| Parse.Error _
- | Types.Error (_,_) | Clocks.Error (_,_)
- | Error.Error _ (*| Task_set.Error _*)
- | Causality.Error _ -> exit 1
- | Sys_error msg -> (eprintf "Failure: %s@." msg)
- | exc -> (track_exception (); raise exc)
+ | Types.Error (_, _)
+ | Clocks.Error (_, _)
+ | Error.Error _
+ (*| Task_set.Error _*)
+ | Causality.Error _ ->
+ exit 1
+ | Sys_error msg ->
+ eprintf "Failure: %s@." msg
+ | exc ->
+ track_exception ();
+ raise exc
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/main_lustre_verifier.ml b/src/main_lustre_verifier.ml
index 7dc39fffbe8a919f907fc50d0fd1675de372aea0..c56081e0e00dbc51911cfee9fb44c1fb5c1d2473 100644
--- a/src/main_lustre_verifier.ml
+++ b/src/main_lustre_verifier.ml
@@ -11,37 +11,35 @@
open Format
open Compiler_common
-
open Utils
-
let usage = "Usage: lustrev [options] \x1b[4msource file\x1b[0m"
-let extensions = [".ec"; ".lus"; ".lusi"]
-
+let extensions = [ ".ec"; ".lus"; ".lusi" ]
-(* verify a .lus source file
+(* verify a .lus source file
-we have multiple "backends"
-- zustre: linked to z3/spacer. Shall preserve the structure and rely on contracts. Produces both a lustre model with new properties, maybe as a lusi with lustre contract, and a JSON summarizing the results and providing tests cases or counter examples if any
+ we have multiple "backends" - zustre: linked to z3/spacer. Shall preserve the
+ structure and rely on contracts. Produces both a lustre model with new
+ properties, maybe as a lusi with lustre contract, and a JSON summarizing the
+ results and providing tests cases or counter examples if any
-- seal: linked to seal. Require global inline and main node
- focuses only on the selected node (the main)
- map the machine code into SEAL datastructure and compute invariants
- - provides the node and its information (typical point of interest for taylor expansion, range for inputs, existing invariants, computation error for the node content)
- - simplification of program through taylor expansion
- - scaling when provided with typical ranges (not required to be sound for the moment)
- - computation of lyapunov invariants
- - returns an annotated node with invariants and a JSON to explain computation
- - could also returns plots
+ - seal: linked to seal. Require global inline and main node focuses only on
+ the selected node (the main) map the machine code into SEAL datastructure and
+ compute invariants - provides the node and its information (typical point of
+ interest for taylor expansion, range for inputs, existing invariants,
+ computation error for the node content) - simplification of program through
+ taylor expansion - scaling when provided with typical ranges (not required to
+ be sound for the moment) - computation of lyapunov invariants - returns an
+ annotated node with invariants and a JSON to explain computation - could also
+ returns plots
-- tiny: linked to tiny library to perform floating point analyses
- shall be provided with ranges for inputs or local variables (memories)
-
-*)
+ - tiny: linked to tiny library to perform floating point analyses shall be
+ provided with ranges for inputs or local variables (memories) *)
let verify dirname basename extension =
let source_name = dirname ^ "/" ^ basename ^ extension in
- Options.compile_header := false; (* to avoid producing .h / .lusic *)
+ Options.compile_header := false;
+ (* to avoid producing .h / .lusic *)
Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 0>");
decr Options.verbose_level;
@@ -52,78 +50,68 @@ let verify dirname basename extension =
incr Options.verbose_level;
let verifier = Verifiers.get_active () in
let module Verifier = (val verifier : VerifierType.S) in
-
decr Options.verbose_level;
let params = Verifier.get_normalization_params () in
(* Normalizing it *)
let prog, _ =
- Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. Phase 1 : Normalisation@,");
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@[<v 2>.. Phase 1 : Normalisation@,");
try
incr Options.verbose_level;
decr Options.verbose_level;
Compiler_stages.stage1 params prog dirname basename extension
- with Compiler_stages.StopPhase1 prog -> (
+ with Compiler_stages.StopPhase1 prog ->
if !Options.print_nodes then (
Format.printf "%a@.@?" Printers.pp_node_list prog;
- exit 0
- )
- else
- assert false
- )
+ exit 0)
+ else assert false
in
Log.report ~level:1 (fun fmt -> fprintf fmt "@]@,");
- Log.report ~level:3 (fun fmt -> fprintf fmt ".. Normalized program:@ %a@ "Printers.pp_prog prog);
+ Log.report ~level:3 (fun fmt ->
+ fprintf fmt ".. Normalized program:@ %a@ " Printers.pp_prog prog);
- Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. Phase 2 : Machines generation@,");
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt "@[<v 2>.. Phase 2 : Machines generation@,");
- let prog, machine_code =
- Compiler_stages.stage2 params prog
- in
+ let prog, machine_code = Compiler_stages.stage2 params prog in
Log.report ~level:1 (fun fmt -> fprintf fmt "@]@ ");
- Log.report ~level:3 (fun fmt -> fprintf fmt ".. Generated machines:@ %a@ "
- Machine_code_common.pp_machines machine_code);
-
- if Scopes.Plugin.show_scopes () then
- begin
- let all_scopes = 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@ @]@ @?" Scopes.print_scopes all_scopes;
- exit 0
-
- end;
+ Log.report ~level:3 (fun fmt ->
+ fprintf fmt ".. Generated machines:@ %a@ " Machine_code_common.pp_machines
+ machine_code);
+
+ if Scopes.Plugin.show_scopes () then (
+ let all_scopes = 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@ @]@ @?" Scopes.print_scopes all_scopes;
+ exit 0);
let machine_code = Plugins.refine_machine_code prog machine_code in
(*assert (dependencies = []); (* Do not handle deps yet *)*)
incr Options.verbose_level;
Verifier.run ~basename prog machine_code;
- begin
- decr Options.verbose_level;
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ ");
- incr Options.verbose_level;
- Log.report ~level:1 (fun fmt -> fprintf fmt "@]@.");
- (* We stop the process here *)
- exit 0
- end
-
+ decr Options.verbose_level;
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ ");
+ incr Options.verbose_level;
+ Log.report ~level:1 (fun fmt -> fprintf fmt "@]@.");
+ (* We stop the process here *)
+ exit 0
let anonymous filename =
- let ok_ext, ext = List.fold_left
- (fun (ok, ext) ext' ->
- if not ok && Filename.check_suffix filename ext' then
- true, ext'
- else
- ok, ext)
- (false, "") extensions in
+ let ok_ext, ext =
+ List.fold_left
+ (fun (ok, ext) ext' ->
+ if (not ok) && Filename.check_suffix filename ext' then true, ext'
+ else ok, ext)
+ (false, "") extensions
+ in
if ok_ext then
let dirname = Filename.dirname filename in
let basename = Filename.chop_suffix (Filename.basename filename) ext in
verify dirname basename ext
- else
- raise (Arg.Bad ("Can only compile *.lusi, *.lus or *.ec files"))
+ else raise (Arg.Bad "Can only compile *.lusi, *.lus or *.ec files")
let _ =
Global.initialize ();
@@ -131,21 +119,23 @@ let _ =
try
Printexc.record_backtrace true;
- let options = Options_management.lustrev_options @ (Verifiers.options ()) in
-
+ let options = Options_management.lustrev_options @ Verifiers.options () in
+
Arg.parse options anonymous usage
with
- | Parse.Error | Types.Error (_,_) | Clocks.Error (_,_) ->
+ | Parse.Error | Types.Error (_, _) | Clocks.Error (_, _) ->
exit 1
- | Error.Error (loc , kind) (*| Task_set.Error _*) ->
+ | Error.Error (loc, kind) (*| Task_set.Error _*) ->
Error.pp_error loc (fun fmt -> Error.pp_error_msg fmt kind);
exit (Error.return_code kind)
- (* | Causality.Error _ -> exit (Error.return_code Error.AlgebraicLoop) *)
+ (* | Causality.Error _ -> exit (Error.return_code Error.AlgebraicLoop) *)
| Sys_error msg ->
- (eprintf "Failure: %s@." msg); exit 1
+ eprintf "Failure: %s@." msg;
+ exit 1
| exc ->
- (track_exception (); raise exc)
+ track_exception ();
+ raise exc
- (* Local Variables: *)
- (* compile-command:"make -C .." *)
- (* End: *)
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
diff --git a/src/mmap.ml b/src/mmap.ml
index e744cd92c26c41bf05855c05d23117c29887400c..9abcb67d0456a4623a7b6300ea9bbc0eba6cf052 100644
--- a/src/mmap.ml
+++ b/src/mmap.ml
@@ -11,327 +11,375 @@
(* *)
(***********************************************************************)
-module type OrderedType =
- sig
- type t
- val compare: t -> t -> int
- end
-
-module type S =
- sig
- type key
- type +'a t
- val empty: 'a t
- val is_empty: 'a t -> bool
- val mem: key -> 'a t -> bool
- val add: key -> 'a -> 'a t -> 'a t
- val singleton: key -> 'a -> 'a t
- val remove: key -> 'a t -> 'a t
- val merge:
- (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
- val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
- val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
- val iter: (key -> 'a -> unit) -> 'a t -> unit
- val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
- val for_all: (key -> 'a -> bool) -> 'a t -> bool
- val exists: (key -> 'a -> bool) -> 'a t -> bool
- val filter: (key -> 'a -> bool) -> 'a t -> 'a t
- val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
- val cardinal: 'a t -> int
- val bindings: 'a t -> (key * 'a) list
- val min_binding: 'a t -> (key * 'a)
- val max_binding: 'a t -> (key * 'a)
- val choose: 'a t -> (key * 'a)
- val split: key -> 'a t -> 'a t * 'a option * 'a t
- val find: key -> 'a t -> 'a
- val map: ('a -> 'b) -> 'a t -> 'b t
- val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
- end
-
-module Make(Ord: OrderedType) = struct
-
- type key = Ord.t
-
- type 'a t =
- Empty
- | Node of 'a t * key * 'a * 'a t * int
-
- let height = function
- Empty -> 0
- | Node(_,_,_,_,h) -> h
-
- let create l x d r =
- let hl = height l and hr = height r in
- Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
- let singleton x d = Node(Empty, x, d, Empty, 1)
-
- let bal l x d r =
- let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
- let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
- if hl > hr + 2 then begin
- match l with
- Empty -> invalid_arg "Map.bal"
- | Node(ll, lv, ld, lr, _) ->
- if height ll >= height lr then
- create ll lv ld (create lr x d r)
- else begin
- match lr with
- Empty -> invalid_arg "Map.bal"
- | Node(lrl, lrv, lrd, lrr, _)->
- create (create ll lv ld lrl) lrv lrd (create lrr x d r)
- end
- end else if hr > hl + 2 then begin
- match r with
- Empty -> invalid_arg "Map.bal"
- | Node(rl, rv, rd, rr, _) ->
- if height rr >= height rl then
- create (create l x d rl) rv rd rr
- else begin
- match rl with
- Empty -> invalid_arg "Map.bal"
- | Node(rll, rlv, rld, rlr, _) ->
- create (create l x d rll) rlv rld (create rlr rv rd rr)
- end
- end else
- Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
- let empty = Empty
-
- let is_empty = function Empty -> true | _ -> false
-
- let rec add x data = function
- Empty ->
- Node(Empty, x, data, Empty, 1)
- | Node(l, v, d, r, h) ->
- let c = Ord.compare x v in
- if c = 0 then
- Node(l, x, data, r, h)
- else if c < 0 then
- bal (add x data l) v d r
- else
- bal l v d (add x data r)
-
- let rec find x = function
- Empty ->
- raise Not_found
- | Node(l, v, d, r, _) ->
- let c = Ord.compare x v in
- if c = 0 then d
- else find x (if c < 0 then l else r)
-
- let rec mem x = function
- Empty ->
- false
- | Node(l, v, _, r, _) ->
- let c = Ord.compare x v in
- c = 0 || mem x (if c < 0 then l else r)
-
- let rec min_binding = function
- Empty -> raise Not_found
- | Node(Empty, x, d, _, _) -> (x, d)
- | Node(l, _, _, _, _) -> min_binding l
-
- let rec max_binding = function
- Empty -> raise Not_found
- | Node(_, x, d, Empty, _) -> (x, d)
- | Node(_, _, _, r, _) -> max_binding r
-
- let rec remove_min_binding = function
- Empty -> invalid_arg "Map.remove_min_elt"
- | Node(Empty, _, _, r, _) -> r
- | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
-
- let merge t1 t2 =
- match (t1, t2) with
- (Empty, t) -> t
- | (t, Empty) -> t
- | (_, _) ->
- let (x, d) = min_binding t2 in
- bal t1 x d (remove_min_binding t2)
-
- let rec remove x = function
- Empty ->
- Empty
- | Node(l, v, d, r, _) ->
- let c = Ord.compare x v in
- if c = 0 then
- merge l r
- else if c < 0 then
- bal (remove x l) v d r
- else
- bal l v d (remove x r)
-
- let rec iter f = function
- Empty -> ()
- | Node(l, v, d, r, _) ->
- iter f l; f v d; iter f r
-
- let rec map f = function
- Empty ->
- Empty
- | Node(l, v, d, r, h) ->
- let l' = map f l in
- let d' = f d in
- let r' = map f r in
- Node(l', v, d', r', h)
-
- let rec mapi f = function
- Empty ->
- Empty
- | Node(l, v, d, r, h) ->
- let l' = mapi f l in
- let d' = f v d in
- let r' = mapi f r in
- Node(l', v, d', r', h)
-
- let rec fold f m accu =
- match m with
- Empty -> accu
- | Node(l, v, d, r, _) ->
- fold f r (f v d (fold f l accu))
-
- let rec for_all p = function
- Empty -> true
- | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r
-
- let rec exists p = function
- Empty -> false
- | Node(l, v, d, r, _) -> p v d || exists p l || exists p r
-
- (* Beware: those two functions assume that the added k is *strictly*
- smaller (or bigger) than all the present keys in the tree; it
- does not test for equality with the current min (or max) key.
-
- Indeed, they are only used during the "join" operation which
- respects this precondition.
- *)
-
- let rec add_min_binding k v = function
- | Empty -> singleton k v
- | Node (l, x, d, r, _) ->
- bal (add_min_binding k v l) x d r
-
- let rec add_max_binding k v = function
- | Empty -> singleton k v
- | Node (l, x, d, r, _) ->
- bal l x d (add_max_binding k v r)
-
- (* Same as create and bal, but no assumptions are made on the
- relative heights of l and r. *)
-
- let rec join l v d r =
- match (l, r) with
- (Empty, _) -> add_min_binding v d r
- | (_, Empty) -> add_max_binding v d l
- | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) ->
- if lh > rh + 2 then bal ll lv ld (join lr v d r) else
- if rh > lh + 2 then bal (join l v d rl) rv rd rr else
- create l v d r
-
- (* Merge two trees l and r into one.
- All elements of l must precede the elements of r.
- No assumption on the heights of l and r. *)
-
- let concat t1 t2 =
- match (t1, t2) with
- (Empty, t) -> t
- | (t, Empty) -> t
- | (_, _) ->
- let (x, d) = min_binding t2 in
- join t1 x d (remove_min_binding t2)
-
- let concat_or_join t1 v d t2 =
- match d with
- | Some d -> join t1 v d t2
- | None -> concat t1 t2
-
- let rec split x = function
- Empty ->
- (Empty, None, Empty)
- | Node(l, v, d, r, _) ->
- let c = Ord.compare x v in
- if c = 0 then (l, Some d, r)
- else if c < 0 then
- let (ll, pres, rl) = split x l in (ll, pres, join rl v d r)
- else
- let (lr, pres, rr) = split x r in (join l v d lr, pres, rr)
-
- let rec merge f s1 s2 =
- match (s1, s2) with
- (Empty, Empty) -> Empty
- | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
- let (l2, d2, r2) = split v1 s2 in
- concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2)
- | (_, Node (l2, v2, d2, r2, _)) ->
- let (l1, d1, r1) = split v2 s1 in
- concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2)
- | _ ->
- assert false
-
- let rec filter p = function
- Empty -> Empty
- | Node(l, v, d, r, _) ->
- (* call [p] in the expected left-to-right order *)
- let l' = filter p l in
- let pvd = p v d in
- let r' = filter p r in
- if pvd then join l' v d r' else concat l' r'
-
- let rec partition p = function
- Empty -> (Empty, Empty)
- | Node(l, v, d, r, _) ->
- (* call [p] in the expected left-to-right order *)
- let (lt, lf) = partition p l in
- let pvd = p v d in
- let (rt, rf) = partition p r in
- if pvd
- then (join lt v d rt, concat lf rf)
- else (concat lt rt, join lf v d rf)
-
- type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration
-
- let rec cons_enum m e =
- match m with
- Empty -> e
- | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))
-
- let compare cmp m1 m2 =
- let rec compare_aux e1 e2 =
- match (e1, e2) with
- (End, End) -> 0
- | (End, _) -> -1
- | (_, End) -> 1
- | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
- let c = Ord.compare v1 v2 in
- if c <> 0 then c else
- let c = cmp d1 d2 in
- if c <> 0 then c else
- compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
- in compare_aux (cons_enum m1 End) (cons_enum m2 End)
-
- let equal cmp m1 m2 =
- let rec equal_aux e1 e2 =
- match (e1, e2) with
- (End, End) -> true
- | (End, _) -> false
- | (_, End) -> false
- | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
- Ord.compare v1 v2 = 0 && cmp d1 d2 &&
- equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
- in equal_aux (cons_enum m1 End) (cons_enum m2 End)
-
- let rec cardinal = function
- Empty -> 0
- | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r
-
- let rec bindings_aux accu = function
- Empty -> accu
- | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l
-
- let bindings s =
- bindings_aux [] s
-
- let choose = min_binding
+module type OrderedType = sig
+ type t
+ val compare : t -> t -> int
+end
+
+module type S = sig
+ type key
+
+ type +'a t
+
+ val empty : 'a t
+
+ val is_empty : 'a t -> bool
+
+ val mem : key -> 'a t -> bool
+
+ val add : key -> 'a -> 'a t -> 'a t
+
+ val singleton : key -> 'a -> 'a t
+
+ val remove : key -> 'a t -> 'a t
+
+ val merge :
+ (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+
+ val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+
+ val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+
+ val iter : (key -> 'a -> unit) -> 'a t -> unit
+
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+
+ val for_all : (key -> 'a -> bool) -> 'a t -> bool
+
+ val exists : (key -> 'a -> bool) -> 'a t -> bool
+
+ val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+
+ val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+
+ val cardinal : 'a t -> int
+
+ val bindings : 'a t -> (key * 'a) list
+
+ val min_binding : 'a t -> key * 'a
+
+ val max_binding : 'a t -> key * 'a
+
+ val choose : 'a t -> key * 'a
+
+ val split : key -> 'a t -> 'a t * 'a option * 'a t
+
+ val find : key -> 'a t -> 'a
+
+ val map : ('a -> 'b) -> 'a t -> 'b t
+
+ val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+end
+
+module Make (Ord : OrderedType) = struct
+ type key = Ord.t
+
+ type 'a t = Empty | Node of 'a t * key * 'a * 'a t * int
+
+ let height = function Empty -> 0 | Node (_, _, _, _, h) -> h
+
+ let create l x d r =
+ let hl = height l and hr = height r in
+ Node (l, x, d, r, if hl >= hr then hl + 1 else hr + 1)
+
+ let singleton x d = Node (Empty, x, d, Empty, 1)
+
+ let bal l x d r =
+ let hl = match l with Empty -> 0 | Node (_, _, _, _, h) -> h in
+ let hr = match r with Empty -> 0 | Node (_, _, _, _, h) -> h in
+ if hl > hr + 2 then
+ match l with
+ | Empty ->
+ invalid_arg "Map.bal"
+ | Node (ll, lv, ld, lr, _) -> (
+ if height ll >= height lr then create ll lv ld (create lr x d r)
+ else
+ match lr with
+ | Empty ->
+ invalid_arg "Map.bal"
+ | Node (lrl, lrv, lrd, lrr, _) ->
+ create (create ll lv ld lrl) lrv lrd (create lrr x d r))
+ else if hr > hl + 2 then
+ match r with
+ | Empty ->
+ invalid_arg "Map.bal"
+ | Node (rl, rv, rd, rr, _) -> (
+ if height rr >= height rl then create (create l x d rl) rv rd rr
+ else
+ match rl with
+ | Empty ->
+ invalid_arg "Map.bal"
+ | Node (rll, rlv, rld, rlr, _) ->
+ create (create l x d rll) rlv rld (create rlr rv rd rr))
+ else Node (l, x, d, r, if hl >= hr then hl + 1 else hr + 1)
+
+ let empty = Empty
+
+ let is_empty = function Empty -> true | _ -> false
+
+ let rec add x data = function
+ | Empty ->
+ Node (Empty, x, data, Empty, 1)
+ | Node (l, v, d, r, h) ->
+ let c = Ord.compare x v in
+ if c = 0 then Node (l, x, data, r, h)
+ else if c < 0 then bal (add x data l) v d r
+ else bal l v d (add x data r)
+
+ let rec find x = function
+ | Empty ->
+ raise Not_found
+ | Node (l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then d else find x (if c < 0 then l else r)
+
+ let rec mem x = function
+ | Empty ->
+ false
+ | Node (l, v, _, r, _) ->
+ let c = Ord.compare x v in
+ c = 0 || mem x (if c < 0 then l else r)
+
+ let rec min_binding = function
+ | Empty ->
+ raise Not_found
+ | Node (Empty, x, d, _, _) ->
+ x, d
+ | Node (l, _, _, _, _) ->
+ min_binding l
+
+ let rec max_binding = function
+ | Empty ->
+ raise Not_found
+ | Node (_, x, d, Empty, _) ->
+ x, d
+ | Node (_, _, _, r, _) ->
+ max_binding r
+
+ let rec remove_min_binding = function
+ | Empty ->
+ invalid_arg "Map.remove_min_elt"
+ | Node (Empty, _, _, r, _) ->
+ r
+ | Node (l, x, d, r, _) ->
+ bal (remove_min_binding l) x d r
+
+ let merge t1 t2 =
+ match t1, t2 with
+ | Empty, t ->
+ t
+ | t, Empty ->
+ t
+ | _, _ ->
+ let x, d = min_binding t2 in
+ bal t1 x d (remove_min_binding t2)
+
+ let rec remove x = function
+ | Empty ->
+ Empty
+ | Node (l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then merge l r
+ else if c < 0 then bal (remove x l) v d r
+ else bal l v d (remove x r)
+
+ let rec iter f = function
+ | Empty ->
+ ()
+ | Node (l, v, d, r, _) ->
+ iter f l;
+ f v d;
+ iter f r
+
+ let rec map f = function
+ | Empty ->
+ Empty
+ | Node (l, v, d, r, h) ->
+ let l' = map f l in
+ let d' = f d in
+ let r' = map f r in
+ Node (l', v, d', r', h)
+
+ let rec mapi f = function
+ | Empty ->
+ Empty
+ | Node (l, v, d, r, h) ->
+ let l' = mapi f l in
+ let d' = f v d in
+ let r' = mapi f r in
+ Node (l', v, d', r', h)
+
+ let rec fold f m accu =
+ match m with
+ | Empty ->
+ accu
+ | Node (l, v, d, r, _) ->
+ fold f r (f v d (fold f l accu))
+
+ let rec for_all p = function
+ | Empty ->
+ true
+ | Node (l, v, d, r, _) ->
+ p v d && for_all p l && for_all p r
+
+ let rec exists p = function
+ | Empty ->
+ false
+ | Node (l, v, d, r, _) ->
+ p v d || exists p l || exists p r
+
+ (* Beware: those two functions assume that the added k is *strictly* smaller
+ (or bigger) than all the present keys in the tree; it does not test for
+ equality with the current min (or max) key.
+
+ Indeed, they are only used during the "join" operation which respects this
+ precondition. *)
+
+ let rec add_min_binding k v = function
+ | Empty ->
+ singleton k v
+ | Node (l, x, d, r, _) ->
+ bal (add_min_binding k v l) x d r
+
+ let rec add_max_binding k v = function
+ | Empty ->
+ singleton k v
+ | Node (l, x, d, r, _) ->
+ bal l x d (add_max_binding k v r)
+
+ (* Same as create and bal, but no assumptions are made on the relative heights
+ of l and r. *)
+
+ let rec join l v d r =
+ match l, r with
+ | Empty, _ ->
+ add_min_binding v d r
+ | _, Empty ->
+ add_max_binding v d l
+ | Node (ll, lv, ld, lr, lh), Node (rl, rv, rd, rr, rh) ->
+ if lh > rh + 2 then bal ll lv ld (join lr v d r)
+ else if rh > lh + 2 then bal (join l v d rl) rv rd rr
+ else create l v d r
+
+ (* Merge two trees l and r into one. All elements of l must precede the
+ elements of r. No assumption on the heights of l and r. *)
+
+ let concat t1 t2 =
+ match t1, t2 with
+ | Empty, t ->
+ t
+ | t, Empty ->
+ t
+ | _, _ ->
+ let x, d = min_binding t2 in
+ join t1 x d (remove_min_binding t2)
+
+ let concat_or_join t1 v d t2 =
+ match d with Some d -> join t1 v d t2 | None -> concat t1 t2
+
+ let rec split x = function
+ | Empty ->
+ Empty, None, Empty
+ | Node (l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then l, Some d, r
+ else if c < 0 then
+ let ll, pres, rl = split x l in
+ ll, pres, join rl v d r
+ else
+ let lr, pres, rr = split x r in
+ join l v d lr, pres, rr
+
+ let rec merge f s1 s2 =
+ match s1, s2 with
+ | Empty, Empty ->
+ Empty
+ | Node (l1, v1, d1, r1, h1), _ when h1 >= height s2 ->
+ let l2, d2, r2 = split v1 s2 in
+ concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2)
+ | _, Node (l2, v2, d2, r2, _) ->
+ let l1, d1, r1 = split v2 s1 in
+ concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2)
+ | _ ->
+ assert false
+
+ let rec filter p = function
+ | Empty ->
+ Empty
+ | Node (l, v, d, r, _) ->
+ (* call [p] in the expected left-to-right order *)
+ let l' = filter p l in
+ let pvd = p v d in
+ let r' = filter p r in
+ if pvd then join l' v d r' else concat l' r'
+
+ let rec partition p = function
+ | Empty ->
+ Empty, Empty
+ | Node (l, v, d, r, _) ->
+ (* call [p] in the expected left-to-right order *)
+ let lt, lf = partition p l in
+ let pvd = p v d in
+ let rt, rf = partition p r in
+ if pvd then join lt v d rt, concat lf rf else concat lt rt, join lf v d rf
+
+ type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration
+
+ let rec cons_enum m e =
+ match m with
+ | Empty ->
+ e
+ | Node (l, v, d, r, _) ->
+ cons_enum l (More (v, d, r, e))
+
+ let compare cmp m1 m2 =
+ let rec compare_aux e1 e2 =
+ match e1, e2 with
+ | End, End ->
+ 0
+ | End, _ ->
+ -1
+ | _, End ->
+ 1
+ | More (v1, d1, r1, e1), More (v2, d2, r2, e2) ->
+ let c = Ord.compare v1 v2 in
+ if c <> 0 then c
+ else
+ let c = cmp d1 d2 in
+ if c <> 0 then c else compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
+ in
+ compare_aux (cons_enum m1 End) (cons_enum m2 End)
+
+ let equal cmp m1 m2 =
+ let rec equal_aux e1 e2 =
+ match e1, e2 with
+ | End, End ->
+ true
+ | End, _ ->
+ false
+ | _, End ->
+ false
+ | More (v1, d1, r1, e1), More (v2, d2, r2, e2) ->
+ Ord.compare v1 v2 = 0
+ && cmp d1 d2
+ && equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
+ in
+ equal_aux (cons_enum m1 End) (cons_enum m2 End)
+
+ let rec cardinal = function
+ | Empty ->
+ 0
+ | Node (l, _, _, r, _) ->
+ cardinal l + 1 + cardinal r
+
+ let rec bindings_aux accu = function
+ | Empty ->
+ accu
+ | Node (l, v, d, r, _) ->
+ bindings_aux ((v, d) :: bindings_aux accu r) l
+
+ let bindings s = bindings_aux [] s
+
+ let choose = min_binding
end
diff --git a/src/modules.ml b/src/modules.ml
index 157847f0862e9dfb731fcd934e2d40581585c1ef..084cdf2a0e4b2f51e01bb4e7c1c8d0f43b4c4bec 100644
--- a/src/modules.ml
+++ b/src/modules.ml
@@ -14,13 +14,12 @@ open Lustre_types
open Corelang
let name_dependency loc (local, dep) ext =
- try
- Options_management.name_dependency (local, dep) ext
+ try Options_management.name_dependency (local, dep) ext
with Not_found ->
- (* Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unknown library %s" dep); *)
+ (* Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unknown library %s"
+ dep); *)
raise (Error.Error (loc, Error.Unknown_library dep))
-
(* let add_symbol loc msg hashtbl name value =
* if Hashtbl.mem hashtbl name
* then raise (Error.Error (loc, Error.Already_bound_symbol msg))
@@ -31,9 +30,9 @@ let name_dependency loc (local, dep) ext =
* then raise (Error.Error (loc, Error.Unbound_symbol msg))
* else () *)
-
let add_imported_node name value =
-(*Format.eprintf "add_imported_node %s %a (owner=%s)@." name Printers.pp_imported_node (imported_node_of_top value) value.top_decl_owner;*)
+ (*Format.eprintf "add_imported_node %s %a (owner=%s)@." name
+ Printers.pp_imported_node (imported_node_of_top value) value.top_decl_owner;*)
try
let value' = node_from_name name in
let owner' = value'.top_decl_owner in
@@ -41,14 +40,19 @@ let add_imported_node name value =
let owner = value.top_decl_owner in
let itf = value.top_decl_itf in
match value'.top_decl_desc, value.top_decl_desc with
- | Node _ , ImportedNode _ when owner = owner' && itf' && (not itf) -> update_node name value
- | ImportedNode _, ImportedNode _ -> raise (Error.Error (value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
- | _ -> assert false
- with
- Not_found -> update_node name value
+ | Node _, ImportedNode _ when owner = owner' && itf' && not itf ->
+ update_node name value
+ | ImportedNode _, ImportedNode _ ->
+ raise
+ (Error.Error
+ (value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
+ | _ ->
+ assert false
+ with Not_found -> update_node name value
let add_node name value =
-(*Format.eprintf "add_node %s %a (owner=%s)@." name Printers.pp_imported_node (get_node_interface (node_of_top value)) value.top_decl_owner;*)
+ (*Format.eprintf "add_node %s %a (owner=%s)@." name Printers.pp_imported_node
+ (get_node_interface (node_of_top value)) value.top_decl_owner;*)
try
let value' = node_from_name name in
let owner' = value'.top_decl_owner in
@@ -56,12 +60,15 @@ let add_node name value =
let owner = value.top_decl_owner in
let itf = value.top_decl_itf in
match value'.top_decl_desc, value.top_decl_desc with
- | ImportedNode _, Node _ when owner = owner' && itf' && (not itf) -> ()
- | Node _ , Node _ -> raise (Error.Error (value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
- | _ -> assert false
- with
- Not_found -> update_node name value
-
+ | ImportedNode _, Node _ when owner = owner' && itf' && not itf ->
+ ()
+ | Node _, Node _ ->
+ raise
+ (Error.Error
+ (value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
+ | _ ->
+ assert false
+ with Not_found -> update_node name value
let add_tag loc name typ =
if Hashtbl.mem tag_table name then
@@ -70,28 +77,38 @@ let add_tag loc name typ =
let add_field loc name typ =
if Hashtbl.mem field_table name then
- raise (Error.Error (loc, Error.Already_bound_symbol ("struct field " ^ name)))
+ raise
+ (Error.Error (loc, Error.Already_bound_symbol ("struct field " ^ name)))
else Hashtbl.add field_table name typ
let import_typedef tydef =
let loc = tydef.top_decl_loc in
let rec import ty =
match ty with
- | Tydec_enum tl ->
- List.iter (fun tag -> add_tag loc tag tydef) tl
- | Tydec_struct fl ->
- List.iter (fun (field, ty) -> add_field loc field tydef; import ty) fl
- | Tydec_clock ty -> import ty
- | Tydec_const c ->
- if not (Hashtbl.mem type_table (Tydec_const c))
- then raise (Error.Error (loc, Error.Unbound_symbol ("type " ^ c)))
- else ()
- | Tydec_array (_, ty) -> import ty
- | _ -> ()
- in import ((typedef_of_top tydef).tydef_desc)
+ | Tydec_enum tl ->
+ List.iter (fun tag -> add_tag loc tag tydef) tl
+ | Tydec_struct fl ->
+ List.iter
+ (fun (field, ty) ->
+ add_field loc field tydef;
+ import ty)
+ fl
+ | Tydec_clock ty ->
+ import ty
+ | Tydec_const c ->
+ if not (Hashtbl.mem type_table (Tydec_const c)) then
+ raise (Error.Error (loc, Error.Unbound_symbol ("type " ^ c)))
+ else ()
+ | Tydec_array (_, ty) ->
+ import ty
+ | _ ->
+ ()
+ in
+ import (typedef_of_top tydef).tydef_desc
let add_type _itf name value =
-(*Format.eprintf "Modules.add_type %B %s %a (owner=%s)@." itf name Printers.pp_typedef (typedef_of_top value) value.top_decl_owner;*)
+ (*Format.eprintf "Modules.add_type %B %s %a (owner=%s)@." itf name
+ Printers.pp_typedef (typedef_of_top value) value.top_decl_owner;*)
try
let value' = Hashtbl.find type_table (Tydec_const name) in
let owner' = value'.top_decl_owner in
@@ -99,10 +116,19 @@ let add_type _itf name value =
let owner = value.top_decl_owner in
let itf = value.top_decl_itf in
match value'.top_decl_desc, value.top_decl_desc with
- | TypeDef ty', TypeDef ty when coretype_equal ty'.tydef_desc ty.tydef_desc && owner' = owner && itf' && (not itf) -> ()
- | TypeDef _, TypeDef _ -> raise (Error.Error (value.top_decl_loc, Error.Already_bound_symbol ("type " ^ name)))
- | _ -> assert false
- with Not_found -> (import_typedef value; Hashtbl.add type_table (Tydec_const name) value)
+ | TypeDef ty', TypeDef ty
+ when coretype_equal ty'.tydef_desc ty.tydef_desc
+ && owner' = owner && itf' && not itf ->
+ ()
+ | TypeDef _, TypeDef _ ->
+ raise
+ (Error.Error
+ (value.top_decl_loc, Error.Already_bound_symbol ("type " ^ name)))
+ | _ ->
+ assert false
+ with Not_found ->
+ import_typedef value;
+ Hashtbl.add type_table (Tydec_const name) value
(* let check_type loc name =
* if not (Hashtbl.mem type_table (Tydec_const name))
@@ -117,9 +143,16 @@ let add_const name value =
let owner = value.top_decl_owner in
let itf = value.top_decl_itf in
match value'.top_decl_desc, value.top_decl_desc with
- | Const c', Const c when c.const_value = c'.const_value && owner' = owner && itf' && (not itf) -> ()
- | Const _, Const _ -> raise (Error.Error (value.top_decl_loc, Error.Already_bound_symbol ("const " ^ name)))
- | _ -> assert false
+ | Const c', Const c
+ when c.const_value = c'.const_value && owner' = owner && itf' && not itf
+ ->
+ ()
+ | Const _, Const _ ->
+ raise
+ (Error.Error
+ (value.top_decl_loc, Error.Already_bound_symbol ("const " ^ name)))
+ | _ ->
+ assert false
with Not_found -> Hashtbl.add consts_table name value
(* let import_dependency_aux loc (local, dep) =
@@ -148,145 +181,164 @@ let get_lusic decl =
match decl.top_decl_desc with
| Open (local, dep) -> (
let loc = decl.top_decl_loc in
- let extension = ".lusic" in
+ let extension = ".lusic" in
let basename = name_dependency loc (local, dep) extension in
try
let lusic = Lusic.read_lusic basename extension in
Lusic.check_obsolete lusic basename;
lusic
- with
- | Sys_error _ ->
- raise (Error.Error (loc, Error.Unknown_library basename))
- )
- | _ -> assert false (* should not happen *)
-
+ with Sys_error _ ->
+ raise (Error.Error (loc, Error.Unknown_library basename)))
+ | _ ->
+ assert false
+(* should not happen *)
let get_envs_from_const const_decl (ty_env, ck_env) =
- (Env.add_value ty_env const_decl.const_id const_decl.const_type,
- Env.add_value ck_env const_decl.const_id (Clocks.new_var true))
+ ( Env.add_value ty_env const_decl.const_id const_decl.const_type,
+ Env.add_value ck_env const_decl.const_id (Clocks.new_var true) )
(* let get_envs_from_consts const_decls (ty_env, ck_env) =
* List.fold_right get_envs_from_const const_decls (ty_env, ck_env) *)
let rec get_envs_from_top_decl (ty_env, ck_env) top_decl =
match top_decl.top_decl_desc with
- | Node nd -> (Env.add_value ty_env nd.node_id nd.node_type,
- Env.add_value ck_env nd.node_id nd.node_clock)
- | ImportedNode ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type,
- Env.add_value ck_env ind.nodei_id ind.nodei_clock)
- | Const c -> get_envs_from_const c (ty_env, ck_env)
- | TypeDef _ -> List.fold_left get_envs_from_top_decl (ty_env, ck_env) (consts_of_enum_type top_decl)
- | Include _ | Open _ -> (ty_env, ck_env)
+ | Node nd ->
+ ( Env.add_value ty_env nd.node_id nd.node_type,
+ Env.add_value ck_env nd.node_id nd.node_clock )
+ | ImportedNode ind ->
+ ( Env.add_value ty_env ind.nodei_id ind.nodei_type,
+ Env.add_value ck_env ind.nodei_id ind.nodei_clock )
+ | Const c ->
+ get_envs_from_const c (ty_env, ck_env)
+ | TypeDef _ ->
+ List.fold_left get_envs_from_top_decl (ty_env, ck_env)
+ (consts_of_enum_type top_decl)
+ | Include _ | Open _ ->
+ ty_env, ck_env
(* get type and clock environments from a header *)
let get_envs_from_top_decls header =
List.fold_left get_envs_from_top_decl (Env.initial, Env.initial) header
- let is_stateful topdecl =
+let is_stateful topdecl =
match topdecl.top_decl_desc with
- | Node nd -> (match nd.node_stateless with Some b -> not b | None -> not nd.node_dec_stateless)
- | ImportedNode nd -> not nd.nodei_stateless
- | _ -> false
+ | Node nd -> (
+ match nd.node_stateless with
+ | Some b ->
+ not b
+ | None ->
+ not nd.node_dec_stateless)
+ | ImportedNode nd ->
+ not nd.nodei_stateless
+ | _ ->
+ false
+
+let rec load_rec ~is_header accu program =
+ List.fold_left
+ (fun ((accu_prog, accu_dep, typ_env, clk_env) as accu) decl ->
+ (* Precompute the updated envs, will not be used in the Open case *)
+ let typ_env', clk_env' = get_envs_from_top_decl (typ_env, clk_env) decl in
+ match decl.top_decl_desc with
+ | Open (local, dep) -> (
+ (* loading the dep *)
+ try
+ let basename =
+ name_dependency decl.top_decl_loc (local, dep) ".lusic"
+ in
+ if
+ List.exists
+ (fun dep ->
+ basename
+ = name_dependency decl.top_decl_loc (dep.local, dep.name)
+ ".lusic")
+ accu_dep
+ then (* Library already imported. Just skip *)
+ accu
+ else (
+ Log.report ~level:1 (fun fmt ->
+ Format.fprintf fmt "@ .. Library %s@ " basename);
+ let lusic = get_lusic decl in
+ (* Recursive call with accumulator on lusic *)
+ let accu_prog, accu_dep, typ_env, clk_env =
+ load_rec ~is_header:true accu lusic.Lusic.contents
+ in
+ (* Building the dep *)
+ let is_stateful = List.exists is_stateful lusic.Lusic.contents in
+ let new_dep =
+ { local; name = dep; content = lusic.Lusic.contents; is_stateful }
+ in
- let rec load_rec ~is_header accu program =
- List.fold_left (fun ((accu_prog, accu_dep, typ_env, clk_env) as accu) decl ->
- (* Precompute the updated envs, will not be used in the Open case *)
- let typ_env', clk_env' = get_envs_from_top_decl (typ_env, clk_env) decl in
- match decl.top_decl_desc with
- | Open (local, dep) -> (
- (* loading the dep *)
- try
- let basename = name_dependency decl.top_decl_loc (local, dep) ".lusic" in
- if List.exists
- (fun dep -> basename = name_dependency decl.top_decl_loc (dep.local, dep.name) ".lusic")
- accu_dep
- then
- (* Library already imported. Just skip *)
- accu
- else (
- Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@ .. Library %s@ " basename);
- let lusic = get_lusic decl in
- (* Recursive call with accumulator on lusic *)
- let (accu_prog, accu_dep, typ_env, clk_env) =
- load_rec ~is_header:true accu lusic.Lusic.contents in
- (* Building the dep *)
- let is_stateful = List.exists is_stateful lusic.Lusic.contents in
- let new_dep = { local = local;
- name = dep;
- content = lusic.Lusic.contents;
- is_stateful = is_stateful } in
-
- (* Returning the prog while keeping the Open, the deps with the new
- elements and the updated envs *)
- decl::accu_prog, (new_dep::accu_dep), typ_env, clk_env
- )
- with
- | Not_found ->
- let loc = decl.top_decl_loc in
- Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unknown library %s" dep);
- raise (Error.Error (loc, Error.Unknown_library dep (*basename*)))
- )
- | Include name ->
- let basename = name_dependency decl.top_decl_loc (true, name) "" in
- if Filename.check_suffix basename ".lus" then
- let include_src = Compiler_common.parse basename ".lus" in
- let (accu_prog, accu_dep, typ_env, clk_env) =
- load_rec ~is_header:false accu include_src
- in
- decl::accu_prog, accu_dep, typ_env, clk_env
- else
- raise (Error.Error (decl.top_decl_loc, LoadError("include requires a lustre file")))
-
- | Node nd ->
- if is_header then
- raise (Error.Error(decl.top_decl_loc,
- LoadError ("node " ^ nd.node_id ^ " declared in a header file")))
- else (
- (* Registering node *)
- add_node nd.node_id decl;
- (* Updating the type/clock env *)
- decl::accu_prog, accu_dep, typ_env', clk_env'
- )
-
- | ImportedNode ind ->
- if is_header then (
- add_imported_node ind.nodei_id decl;
- decl::accu_prog, accu_dep, typ_env', clk_env'
- )
- else
- raise (Error.Error(decl.top_decl_loc,
- LoadError ("imported node " ^ ind.nodei_id ^
- " declared in a regular Lustre file")))
- | Const c -> (
- add_const c.const_id decl;
- decl::accu_prog, accu_dep, typ_env', clk_env'
- )
- | TypeDef tdef -> (
- add_type is_header tdef.tydef_id decl;
- decl::accu_prog, accu_dep, typ_env', clk_env'
- )
- ) accu program
+ (* Returning the prog while keeping the Open, the deps with the new
+ elements and the updated envs *)
+ decl :: accu_prog, new_dep :: accu_dep, typ_env, clk_env)
+ with Not_found ->
+ let loc = decl.top_decl_loc in
+ Error.pp_error loc (fun fmt ->
+ Format.fprintf fmt "Unknown library %s" dep);
+ raise (Error.Error (loc, Error.Unknown_library dep (*basename*))))
+ | Include name ->
+ let basename = name_dependency decl.top_decl_loc (true, name) "" in
+ if Filename.check_suffix basename ".lus" then
+ let include_src = Compiler_common.parse basename ".lus" in
+ let accu_prog, accu_dep, typ_env, clk_env =
+ load_rec ~is_header:false accu include_src
+ in
+ decl :: accu_prog, accu_dep, typ_env, clk_env
+ else
+ raise
+ (Error.Error
+ (decl.top_decl_loc, LoadError "include requires a lustre file"))
+ | Node nd ->
+ if is_header then
+ raise
+ (Error.Error
+ ( decl.top_decl_loc,
+ LoadError ("node " ^ nd.node_id ^ " declared in a header file")
+ ))
+ else (
+ (* Registering node *)
+ add_node nd.node_id decl;
+ (* Updating the type/clock env *)
+ decl :: accu_prog, accu_dep, typ_env', clk_env')
+ | ImportedNode ind ->
+ if is_header then (
+ add_imported_node ind.nodei_id decl;
+ decl :: accu_prog, accu_dep, typ_env', clk_env')
+ else
+ raise
+ (Error.Error
+ ( decl.top_decl_loc,
+ LoadError
+ ("imported node " ^ ind.nodei_id
+ ^ " declared in a regular Lustre file") ))
+ | Const c ->
+ add_const c.const_id decl;
+ decl :: accu_prog, accu_dep, typ_env', clk_env'
+ | TypeDef tdef ->
+ add_type is_header tdef.tydef_id decl;
+ decl :: accu_prog, accu_dep, typ_env', clk_env')
+ accu program
-(* Iterates through lusi definitions and records them in the hashtbl. Open instructions are evaluated and update these hashtbl as well. node_table/type/table/consts_table *)
+(* Iterates through lusi definitions and records them in the hashtbl. Open
+ instructions are evaluated and update these hashtbl as well.
+ node_table/type/table/consts_table *)
let load ~is_header program =
-
try
- let prog, deps, typ_env, clk_env =
+ let prog, deps, typ_env, clk_env =
load_rec ~is_header
- ([], (* accumulator for program elements *)
- [], (* accumulator for dependencies *)
- Env.initial, (* empty type env *)
- Env.initial (* empty clock env *)
- ) program
+ ( [],
+ (* accumulator for program elements *)
+ [],
+ (* accumulator for dependencies *)
+ Env.initial,
+ (* empty type env *)
+ Env.initial (* empty clock env *) )
+ program
in
List.rev prog, List.rev deps, (typ_env, clk_env)
- with
- Error.Error (_, err) as exc -> (
+ with Error.Error (_, err) as exc ->
(* Format.eprintf "Import error: %a%a@."
* Error.pp_error_msg err
* Location.pp_loc loc; *)
- Format.eprintf "Import error: %a@."
- Error.pp_error_msg err
- ;
+ Format.eprintf "Import error: %a@." Error.pp_error_msg err;
raise exc
- );;
diff --git a/src/modules.mli b/src/modules.mli
index 0d4cc2fafaf5f31da13160e4b5476c47bb92c6b5..4aa08751ebc93bd1f3bbfa1868dcc5566487ec41 100644
--- a/src/modules.mli
+++ b/src/modules.mli
@@ -1,20 +1,21 @@
open Lustre_types
-(* This module is used to load lusic files when open(ing) modules in
- lustre/lusi sources *)
+(* This module is used to load lusic files when open(ing) modules in lustre/lusi
+ sources *)
-(* Load the provided program, either an actual program or a header lusi files:
- - reject program that define imported node
- - reject header that define lustre node
- - inject #include lus file into the program
- - loads #open lusic files
- - record the node name and check that they are uniquely defined
- - build the type/clock env from the imported nodes
+(* Load the provided program, either an actual program or a header lusi files: -
+ reject program that define imported node - reject header that define lustre
+ node - inject #include lus file into the program - loads #open lusic files -
+ record the node name and check that they are uniquely defined - build the
+ type/clock env from the imported nodes
- Returns an extended prog along with dependencies of #open and a type/clock base env.
- *)
-val load: is_header:bool -> program_t -> program_t * dep_t list * ( Typing.type_expr Env.t * Clocks.clock_expr Env.t)
+ Returns an extended prog along with dependencies of #open and a type/clock
+ base env. *)
+val load :
+ is_header:bool ->
+ program_t ->
+ program_t * dep_t list * (Typing.type_expr Env.t * Clocks.clock_expr Env.t)
-(* Returns an updated env with the type/clock declaration of the program *)
-val get_envs_from_top_decls: program_t -> Typing.type_expr Env.t * Clocks.clock_expr Env.t
-
+(* Returns an updated env with the type/clock declaration of the program *)
+val get_envs_from_top_decls :
+ program_t -> Typing.type_expr Env.t * Clocks.clock_expr Env.t
diff --git a/src/mutation.ml b/src/mutation.ml
index a5bc43f661e9e9d56f8d5495c3e16ce84c8c2fb5..1cfd464bfcdab82ec93a41b581ae4a1580b0d2a2 100644
--- a/src/mutation.ml
+++ b/src/mutation.ml
@@ -1,14 +1,9 @@
-
(* Comments in function fold_mutate
- TODO: check if we can generate more cases. The following lines were
- cylcing and missing to detect that the enumaration was complete,
- leading to a non terminating process. The current setting is harder
- but may miss enumerating some cases. To be checked!
-
-
-*)
-
+ TODO: check if we can generate more cases. The following lines were cylcing
+ and missing to detect that the enumaration was complete, leading to a non
+ terminating process. The current setting is harder but may miss enumerating
+ some cases. To be checked! *)
open Lustre_types
open Corelang
@@ -16,129 +11,165 @@ open Log
open Format
let random_seed = ref 0
+
let threshold_delay = 95
+
let threshold_inc_int = 97
+
let threshold_dec_int = 97
+
let threshold_random_int = 96
-let threshold_switch_int = 100 (* not implemented yet *)
-let threshold_random_float = 100 (* not used yet *)
+
+let threshold_switch_int = 100
+(* not implemented yet *)
+
+let threshold_random_float = 100
+(* not used yet *)
+
let threshold_negate_bool_var = 95
+
let threshold_arith_op = 95
+
let threshold_rel_op = 95
+
let threshold_bool_op = 95
let int_consts = ref []
let rename_app id =
- if List.mem id Basic_library.internal_funs ||
- !Options.no_mutation_suffix then
+ if List.mem id Basic_library.internal_funs || !Options.no_mutation_suffix then
id
else
let node = Corelang.node_from_name id in
let is_imported =
- match node.top_decl_desc with
- | ImportedNode _ -> true
- | _ -> false
+ match node.top_decl_desc with ImportedNode _ -> true | _ -> false
in
- if is_imported then
- id
- else
- id ^ "_mutant"
+ if is_imported then id else id ^ "_mutant"
(************************************************************************************)
-(* Gathering constants in the code *)
+(* Gathering constants in the code *)
(************************************************************************************)
-module IntSet = Set.Make (struct type t = int let compare = compare end)
-module OpCount = Mmap.Make (struct type t = string let compare = compare end)
+module IntSet = Set.Make (struct
+ type t = int
+
+ let compare = compare
+end)
+
+module OpCount = Mmap.Make (struct
+ type t = string
+
+ let compare = compare
+end)
type records = {
- consts: IntSet.t;
- nb_consts: int;
- nb_boolexpr: int;
- nb_pre: int;
- nb_op: int OpCount.t;
+ consts : IntSet.t;
+ nb_consts : int;
+ nb_boolexpr : int;
+ nb_pre : int;
+ nb_op : int OpCount.t;
}
-let arith_op = ["+" ; "-" ; "*" ; "/"]
-let bool_op = ["&&"; "||"; "xor"; "impl"]
-let rel_op = ["<" ; "<=" ; ">" ; ">=" ; "!=" ; "=" ]
+let arith_op = [ "+"; "-"; "*"; "/" ]
+
+let bool_op = [ "&&"; "||"; "xor"; "impl" ]
+
+let rel_op = [ "<"; "<="; ">"; ">="; "!="; "=" ]
+
let ops = arith_op @ bool_op @ rel_op
+
let all_ops = "not" :: ops
-let empty_records =
- {consts=IntSet.empty; nb_consts=0; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty}
+let empty_records =
+ {
+ consts = IntSet.empty;
+ nb_consts = 0;
+ nb_boolexpr = 0;
+ nb_pre = 0;
+ nb_op = OpCount.empty;
+ }
let records = ref empty_records
-let merge_records records_list =
+let merge_records records_list =
let merge_record r1 r2 =
{
consts = IntSet.union r1.consts r2.consts;
-
nb_consts = r1.nb_consts + r2.nb_consts;
nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr;
nb_pre = r1.nb_pre + r2.nb_pre;
-
- nb_op = OpCount.merge (fun _ r1opt r2opt ->
- match r1opt, r2opt with
- | None, _ -> r2opt
- | _, None -> r1opt
- | Some x, Some y -> Some (x+y)
- ) r1.nb_op r2.nb_op
+ nb_op =
+ OpCount.merge
+ (fun _ r1opt r2opt ->
+ match r1opt, r2opt with
+ | None, _ ->
+ r2opt
+ | _, None ->
+ r1opt
+ | Some x, Some y ->
+ Some (x + y))
+ r1.nb_op r2.nb_op;
}
in
List.fold_left merge_record empty_records records_list
-
+
let compute_records_const_value c =
match c with
- | Const_int i -> {empty_records with consts = IntSet.singleton i; nb_consts = 1}
- | _ -> empty_records
+ | Const_int i ->
+ { empty_records with consts = IntSet.singleton i; nb_consts = 1 }
+ | _ ->
+ empty_records
let rec compute_records_expr expr =
- let boolexpr =
+ let boolexpr =
if Types.is_bool_type expr.expr_type then
- {empty_records with nb_boolexpr = 1}
- else
- empty_records
+ { empty_records with nb_boolexpr = 1 }
+ else empty_records
in
- let subrec =
+ let subrec =
match expr.expr_desc with
- | Expr_const c -> compute_records_const_value c
- | Expr_tuple l -> merge_records (List.map compute_records_expr l)
- | Expr_ite (i,t,e) ->
- merge_records (List.map compute_records_expr [i;t;e])
- | Expr_arrow (e1, e2) ->
- merge_records (List.map compute_records_expr [e1;e2])
- | Expr_pre e ->
- merge_records (
- ({empty_records with nb_pre = 1})
- ::[compute_records_expr e])
+ | Expr_const c ->
+ compute_records_const_value c
+ | Expr_tuple l ->
+ merge_records (List.map compute_records_expr l)
+ | Expr_ite (i, t, e) ->
+ merge_records (List.map compute_records_expr [ i; t; e ])
+ | Expr_arrow (e1, e2) ->
+ merge_records (List.map compute_records_expr [ e1; e2 ])
+ | Expr_pre e ->
+ merge_records
+ [ { empty_records with nb_pre = 1 }; compute_records_expr e ]
| Expr_appl (op_id, args, _) ->
if List.mem op_id ops then
- merge_records (
- ({empty_records with nb_op = OpCount.singleton op_id 1})
- ::[compute_records_expr args])
- else
- compute_records_expr args
- | _ -> empty_records
+ merge_records
+ [
+ { empty_records with nb_op = OpCount.singleton op_id 1 };
+ compute_records_expr args;
+ ]
+ else compute_records_expr args
+ | _ ->
+ empty_records
in
- merge_records [boolexpr;subrec]
+ merge_records [ boolexpr; subrec ]
let compute_records_eq eq = compute_records_expr eq.eq_rhs
let compute_records_node nd =
let eqs, auts = get_node_eqs nd in
- assert (auts=[]); (* Automaton should be expanded by now *)
+ assert (auts = []);
+ (* Automaton should be expanded by now *)
merge_records (List.map compute_records_eq eqs)
let compute_records_top_decl td =
match td.top_decl_desc with
- | Node nd -> compute_records_node nd
- | Const cst -> compute_records_const_value cst.const_value
- | _ -> empty_records
-
-let compute_records prog =
+ | Node nd ->
+ compute_records_node nd
+ | Const cst ->
+ compute_records_const_value cst.const_value
+ | _ ->
+ empty_records
+
+let compute_records prog =
merge_records (List.map compute_records_top_decl prog)
(*****************************************************************)
@@ -148,35 +179,36 @@ let compute_records prog =
let check_mut e1 e2 =
let rec eq e1 e2 =
match e1.expr_desc, e2.expr_desc with
- | Expr_const c1, Expr_const c2 -> c1 = c2
- | Expr_ident id1, Expr_ident id2 -> id1 = id2
- | Expr_tuple el1, Expr_tuple el2 -> List.length el1 = List.length el2 && List.for_all2 eq el1 el2
- | Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) -> eq i1 i2 && eq t1 t2 && eq e1 e2
- | Expr_arrow (x1, y1), Expr_arrow (x2, y2) -> eq x1 x2 && eq y1 y2
- | Expr_pre e1, Expr_pre e2 -> eq e1 e2
- | Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) -> id1 = id2 && eq e1 e2
- | _ -> false
+ | Expr_const c1, Expr_const c2 ->
+ c1 = c2
+ | Expr_ident id1, Expr_ident id2 ->
+ id1 = id2
+ | Expr_tuple el1, Expr_tuple el2 ->
+ List.length el1 = List.length el2 && List.for_all2 eq el1 el2
+ | Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) ->
+ eq i1 i2 && eq t1 t2 && eq e1 e2
+ | Expr_arrow (x1, y1), Expr_arrow (x2, y2) ->
+ eq x1 x2 && eq y1 y2
+ | Expr_pre e1, Expr_pre e2 ->
+ eq e1 e2
+ | Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) ->
+ id1 = id2 && eq e1 e2
+ | _ ->
+ false
in
- if not (eq e1 e2) then
- Some (e1, e2)
- else
- None
+ if not (eq e1 e2) then Some (e1, e2) else None
let mk_cst_expr c = mkexpr Location.dummy_loc (Expr_const c)
-let rdm_mutate_int i =
- if Random.int 100 > threshold_inc_int then
- i+1
- else if Random.int 100 > threshold_dec_int then
- i-1
- else if Random.int 100 > threshold_random_int then
- Random.int 10
+let rdm_mutate_int i =
+ if Random.int 100 > threshold_inc_int then i + 1
+ else if Random.int 100 > threshold_dec_int then i - 1
+ else if Random.int 100 > threshold_random_int then Random.int 10
else if Random.int 100 > threshold_switch_int then
let idx = Random.int (List.length !int_consts) in
List.nth !int_consts idx
- else
- i
-
+ else i
+
let rdm_mutate_real r =
if Random.int 100 > threshold_random_float then
(* interval [0, bound] for random values *)
@@ -185,97 +217,102 @@ let rdm_mutate_real r =
let digits = 5 in
(* number of digits after comma *)
let shift = Random.int (digits + 1) in
- let eshift = 10. ** (float_of_int shift) in
- let i = Random.int (1 + bound * (int_of_float eshift)) in
+ let eshift = 10. ** float_of_int shift in
+ let i = Random.int (1 + (bound * int_of_float eshift)) in
let f = float_of_int i /. eshift in
Real.create (string_of_int i) shift (string_of_float f)
- else
- r
-
-let rdm_mutate_op op =
-match op with
-| "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op ->
- let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in
- List.nth filtered (Random.int 3)
-| "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op ->
- let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in
- List.nth filtered (Random.int 3)
-| "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op ->
- let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in
- List.nth filtered (Random.int 5)
-| _ -> op
-
+ else r
+
+let rdm_mutate_op op =
+ match op with
+ | ("+" | "-" | "*" | "/") when Random.int 100 > threshold_arith_op ->
+ let filtered = List.filter (fun x -> x <> op) [ "+"; "-"; "*"; "/" ] in
+ List.nth filtered (Random.int 3)
+ | ("&&" | "||" | "xor" | "impl") when Random.int 100 > threshold_bool_op ->
+ let filtered =
+ List.filter (fun x -> x <> op) [ "&&"; "||"; "xor"; "impl" ]
+ in
+ List.nth filtered (Random.int 3)
+ | ("<" | "<=" | ">" | ">=" | "!=" | "=")
+ when Random.int 100 > threshold_rel_op ->
+ let filtered =
+ List.filter (fun x -> x <> op) [ "<"; "<="; ">"; ">="; "!="; "=" ]
+ in
+ List.nth filtered (Random.int 5)
+ | _ ->
+ op
let rdm_mutate_var expr =
if Types.is_bool_type expr.expr_type then
(* if Random.int 100 > threshold_negate_bool_var then *)
- let new_e = mkpredef_call expr.expr_loc "not" [expr] in
+ let new_e = mkpredef_call expr.expr_loc "not" [ expr ] in
Some (expr, new_e), new_e
(* else *)
- (* expr *)
- else
- None, expr
-
-let rdm_mutate_pre orig_expr =
- let new_e = Expr_pre orig_expr in
- Some (orig_expr, {orig_expr with expr_desc = new_e}), new_e
+ (* expr *)
+ else None, expr
+let rdm_mutate_pre orig_expr =
+ let new_e = Expr_pre orig_expr in
+ Some (orig_expr, { orig_expr with expr_desc = new_e }), new_e
let rdm_mutate_const_value c =
match c with
- | Const_int i -> Const_int (rdm_mutate_int i)
- | Const_real r -> Const_real (rdm_mutate_real r)
+ | Const_int i ->
+ Const_int (rdm_mutate_int i)
+ | Const_real r ->
+ Const_real (rdm_mutate_real r)
| Const_array _
| Const_string _
| Const_modeid _
| Const_struct _
- | Const_tag _ -> c
+ | Const_tag _ ->
+ c
let rdm_mutate_const c =
let new_const = rdm_mutate_const_value c.const_value in
let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in
mut, { c with const_value = new_const }
-
-let select_in_list list rdm_mutate_elem =
+let select_in_list list rdm_mutate_elem =
let selected = Random.int (List.length list) in
- let mutation_opt, new_list, _ =
+ let mutation_opt, new_list, _ =
List.fold_right
- (fun elem (mutation_opt, res, cpt) -> if cpt = selected then
- let mutation, new_elem = rdm_mutate_elem elem in
- Some mutation, new_elem::res, cpt+1 else mutation_opt, elem::res, cpt+1)
- list
- (None, [], 0)
+ (fun elem (mutation_opt, res, cpt) ->
+ if cpt = selected then
+ let mutation, new_elem = rdm_mutate_elem elem in
+ Some mutation, new_elem :: res, cpt + 1
+ else mutation_opt, elem :: res, cpt + 1)
+ list (None, [], 0)
in
- match mutation_opt with
- | Some mut -> mut, new_list
- | _ -> assert false
-
+ match mutation_opt with Some mut -> mut, new_list | _ -> assert false
let rec rdm_mutate_expr expr =
let mk_e d = { expr with expr_desc = d } in
match expr.expr_desc with
- | Expr_ident _ -> rdm_mutate_var expr
- | Expr_const c ->
- let new_const = rdm_mutate_const_value c in
+ | Expr_ident _ ->
+ rdm_mutate_var expr
+ | Expr_const c ->
+ let new_const = rdm_mutate_const_value c in
let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in
mut, mk_e (Expr_const new_const)
- | Expr_tuple l ->
+ | Expr_tuple l ->
let mut, l' = select_in_list l rdm_mutate_expr in
mut, mk_e (Expr_tuple l')
- | Expr_ite (i,t,e) -> (
- let mut, l = select_in_list [i; t; e] rdm_mutate_expr in
+ | Expr_ite (i, t, e) -> (
+ let mut, l = select_in_list [ i; t; e ] rdm_mutate_expr in
match l with
- | [i'; t'; e'] -> mut, mk_e (Expr_ite (i', t', e'))
- | _ -> assert false
- )
+ | [ i'; t'; e' ] ->
+ mut, mk_e (Expr_ite (i', t', e'))
+ | _ ->
+ assert false)
| Expr_arrow (e1, e2) -> (
- let mut, l = select_in_list [e1; e2] rdm_mutate_expr in
+ let mut, l = select_in_list [ e1; e2 ] rdm_mutate_expr in
match l with
- | [e1'; e2'] -> mut, mk_e (Expr_arrow (e1', e2'))
- | _ -> assert false
- )
- | Expr_pre e ->
+ | [ e1'; e2' ] ->
+ mut, mk_e (Expr_arrow (e1', e2'))
+ | _ ->
+ assert false)
+ | Expr_pre e ->
let select_pre = Random.bool () in
if select_pre then
let mut, new_expr = rdm_mutate_pre expr in
@@ -283,7 +320,7 @@ let rec rdm_mutate_expr expr =
else
let mut, e' = rdm_mutate_expr e in
mut, mk_e (Expr_pre e')
- | Expr_appl (op_id, args, r) ->
+ | Expr_appl (op_id, args, r) ->
let select_op = Random.bool () in
if select_op then
let new_op_id = rdm_mutate_op op_id in
@@ -293,18 +330,13 @@ let rec rdm_mutate_expr expr =
else
let mut, new_args = rdm_mutate_expr args in
mut, mk_e (Expr_appl (op_id, new_args, r))
- (* Other constructs are kept.
- | Expr_fby of expr * expr
- | Expr_array of expr list
- | Expr_access of expr * Dimension.dim_expr
- | Expr_power of expr * Dimension.dim_expr
- | Expr_when of expr * ident * label
- | Expr_merge of ident * (label * expr) list
- | Expr_uclock of expr * int
- | Expr_dclock of expr * int
- | Expr_phclock of expr * rat *)
- | _ -> None, expr
-
+ (* Other constructs are kept. | Expr_fby of expr * expr | Expr_array of expr
+ list | Expr_access of expr * Dimension.dim_expr | Expr_power of expr *
+ Dimension.dim_expr | Expr_when of expr * ident * label | Expr_merge of
+ ident * (label * expr) list | Expr_uclock of expr * int | Expr_dclock of
+ expr * int | Expr_phclock of expr * rat *)
+ | _ ->
+ None, expr
let rdm_mutate_eq eq =
let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
@@ -312,59 +344,51 @@ let rdm_mutate_eq eq =
let rnd_mutate_stmt stmt =
match stmt with
- | Eq eq -> let mut, new_eq = rdm_mutate_eq eq in
- report ~level:1
- (fun fmt -> fprintf fmt "mutation: %a becomes %a@ "
- Printers.pp_node_eq eq
- Printers.pp_node_eq new_eq);
- mut, Eq new_eq
- | Aut _ -> assert false
-
-let rdm_mutate_node nd =
- let mutation, new_node_stmts =
- select_in_list
- nd.node_stmts rnd_mutate_stmt
- in
+ | Eq eq ->
+ let mut, new_eq = rdm_mutate_eq eq in
+ report ~level:1 (fun fmt ->
+ fprintf fmt "mutation: %a becomes %a@ " Printers.pp_node_eq eq
+ Printers.pp_node_eq new_eq);
+ mut, Eq new_eq
+ | Aut _ ->
+ assert false
+
+let rdm_mutate_node nd =
+ let mutation, new_node_stmts = select_in_list nd.node_stmts rnd_mutate_stmt in
mutation, { nd with node_stmts = new_node_stmts }
let rdm_mutate_top_decl td =
match td.top_decl_desc with
- | Node nd ->
- let mutation, new_node = rdm_mutate_node nd in
- mutation, { td with top_decl_desc = Node new_node}
- | Const cst ->
+ | Node nd ->
+ let mutation, new_node = rdm_mutate_node nd in
+ mutation, { td with top_decl_desc = Node new_node }
+ | Const cst ->
let mut, new_cst = rdm_mutate_const cst in
mut, { td with top_decl_desc = Const new_cst }
- | _ -> None, td
-
+ | _ ->
+ None, td
+
(* Create a single mutant with the provided random seed *)
-let rdm_mutate_prog prog =
- select_in_list prog rdm_mutate_top_decl
+let rdm_mutate_prog prog = select_in_list prog rdm_mutate_top_decl
-let rdm_mutate nb prog =
+let rdm_mutate nb prog =
let rec iterate nb res =
incr random_seed;
- if nb <= 0 then
- res
+ if nb <= 0 then res
else (
Random.init !random_seed;
let mutation, new_mutant = rdm_mutate_prog prog in
match mutation with
- None -> iterate nb res
- | Some mutation -> (
- if List.mem_assoc mutation res then (
- iterate nb res
- )
- else (
- report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@ " nb);
- iterate (nb-1) ((mutation, new_mutant)::res)
- )
- )
- )
+ | None ->
+ iterate nb res
+ | Some mutation ->
+ if List.mem_assoc mutation res then iterate nb res
+ else (
+ report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@ " nb);
+ iterate (nb - 1) ((mutation, new_mutant) :: res)))
in
iterate nb []
-
(*****************************************************************)
(* Random mutation *)
(*****************************************************************)
@@ -375,316 +399,341 @@ type mutant_t =
| Op of string * int * string
| IncrIntCst of int
| DecrIntCst of int
- | SwitchIntCst of int * int
+ | SwitchIntCst of int * int
(* Denotes the parent node, the equation lhs and the location of the mutation *)
type mutation_loc = ident * ident list * Location.t
+
let target : mutant_t option ref = ref None
let mutation_info : mutation_loc option ref = ref None
-let current_node: ident option ref = ref None
+
+let current_node : ident option ref = ref None
+
let current_eq_lhs : ident list option ref = ref None
+
let current_loc : Location.t option ref = ref None
-
+
let set_mutation_loc () =
target := None;
match !current_node, !current_eq_lhs, !current_loc with
- | Some n, Some elhs, Some l -> mutation_info := Some (n, elhs, l)
- | _ -> assert false (* Those global vars should be defined during the
- visitor pattern execution *)
+ | Some n, Some elhs, Some l ->
+ mutation_info := Some (n, elhs, l)
+ | _ ->
+ assert false
+(* Those global vars should be defined during the visitor pattern execution *)
let print_directive fmt d =
match d with
- | Pre n -> Format.fprintf fmt "pre %i" n
- | Boolexpr n -> Format.fprintf fmt "boolexpr %i" n
- | Op (o, i, d) -> Format.fprintf fmt "%s %i -> %s" o i d
- | IncrIntCst n -> Format.fprintf fmt "incr int cst %i" n
- | DecrIntCst n -> Format.fprintf fmt "decr int cst %i" n
- | SwitchIntCst (n, m) -> Format.fprintf fmt "switch int cst %i -> %i" n m
+ | Pre n ->
+ Format.fprintf fmt "pre %i" n
+ | Boolexpr n ->
+ Format.fprintf fmt "boolexpr %i" n
+ | Op (o, i, d) ->
+ Format.fprintf fmt "%s %i -> %s" o i d
+ | IncrIntCst n ->
+ Format.fprintf fmt "incr int cst %i" n
+ | DecrIntCst n ->
+ Format.fprintf fmt "decr int cst %i" n
+ | SwitchIntCst (n, m) ->
+ Format.fprintf fmt "switch int cst %i -> %i" n m
let print_directive_json fmt d =
match d with
- | Pre _ -> Format.fprintf fmt "\"mutation\": \"pre\""
- | Boolexpr _ -> Format.fprintf fmt "\"mutation\": \"not\""
- | Op (o, _, d) -> Format.fprintf fmt "\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\"" o d
- | IncrIntCst _ -> Format.fprintf fmt "\"mutation\": \"cst_incr\""
- | DecrIntCst _ -> Format.fprintf fmt "\"mutation\": \"cst_decr\""
- | SwitchIntCst (_, m) -> Format.fprintf fmt "\"mutation\": \"cst_switch\", \"to_cst\": \"%i\"" m
-
-let print_loc_json fmt (n,eqlhs, l) =
- Format.fprintf fmt "\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\""
- n
- (Utils.fprintf_list ~sep:", " (fun fmt s -> Format.fprintf fmt "\"%s\"" s)) eqlhs
- (Location.loc_line l)
-
-let fold_mutate_int i =
- if Random.int 100 > threshold_inc_int then
- i+1
- else if Random.int 100 > threshold_dec_int then
- i-1
- else if Random.int 100 > threshold_random_int then
- Random.int 10
+ | Pre _ ->
+ Format.fprintf fmt "\"mutation\": \"pre\""
+ | Boolexpr _ ->
+ Format.fprintf fmt "\"mutation\": \"not\""
+ | Op (o, _, d) ->
+ Format.fprintf fmt
+ "\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\"" o d
+ | IncrIntCst _ ->
+ Format.fprintf fmt "\"mutation\": \"cst_incr\""
+ | DecrIntCst _ ->
+ Format.fprintf fmt "\"mutation\": \"cst_decr\""
+ | SwitchIntCst (_, m) ->
+ Format.fprintf fmt "\"mutation\": \"cst_switch\", \"to_cst\": \"%i\"" m
+
+let print_loc_json fmt (n, eqlhs, l) =
+ Format.fprintf fmt
+ "\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\"" n
+ (Utils.fprintf_list ~sep:", " (fun fmt s -> Format.fprintf fmt "\"%s\"" s))
+ eqlhs (Location.loc_line l)
+
+let fold_mutate_int i =
+ if Random.int 100 > threshold_inc_int then i + 1
+ else if Random.int 100 > threshold_dec_int then i - 1
+ else if Random.int 100 > threshold_random_int then Random.int 10
else if Random.int 100 > threshold_switch_int then
try
- let idx = Random.int (List.length !int_consts) in
- List.nth !int_consts idx
+ let idx = Random.int (List.length !int_consts) in
+ List.nth !int_consts idx
with _ -> i
- else
- i
-
+ else i
+
let fold_mutate_float f =
- if Random.int 100 > threshold_random_float then
- Random.float 10.
- else
- f
-
-let fold_mutate_op op =
-(* match op with *)
-(* | "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op -> *)
-(* let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in *)
-(* List.nth filtered (Random.int 3) *)
-(* | "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op -> *)
-(* let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in *)
-(* List.nth filtered (Random.int 3) *)
-(* | "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op -> *)
-(* let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in *)
-(* List.nth filtered (Random.int 5) *)
-(* | _ -> op *)
+ if Random.int 100 > threshold_random_float then Random.float 10. else f
+
+let fold_mutate_op op =
+ (* match op with *)
+ (* | "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op -> *)
+ (* let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in *)
+ (* List.nth filtered (Random.int 3) *)
+ (* | "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op -> *)
+ (* let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"]
+ in *)
+ (* List.nth filtered (Random.int 3) *)
+ (* | "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 >
+ threshold_rel_op -> *)
+ (* let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!=";
+ "="] in *)
+ (* List.nth filtered (Random.int 5) *)
+ (* | _ -> op *)
match !target with
- | Some (Op(op_orig, 0, op_new)) when op_orig = op -> (
+ | Some (Op (op_orig, 0, op_new)) when op_orig = op ->
set_mutation_loc ();
op_new
- )
- | Some (Op(op_orig, n, op_new)) when op_orig = op -> (
- target := Some (Op(op_orig, n-1, op_new));
+ | Some (Op (op_orig, n, op_new)) when op_orig = op ->
+ target := Some (Op (op_orig, n - 1, op_new));
+ op
+ | _ ->
op
- )
- | _ -> op
-
-let fold_mutate_var expr =
+let fold_mutate_var expr =
(* match (Types.repr expr.expr_type).Types.tdesc with *)
(* | Types.Tbool -> *)
(* (\* if Random.int 100 > threshold_negate_bool_var then *\) *)
(* mkpredef_unary_call Location.dummy_loc "not" expr *)
(* (\* else *\) *)
(* (\* expr *\) *)
- (* | _ ->
- *)expr
+ (* | _ -> *)
+ expr
let fold_mutate_boolexpr expr =
match !target with
- | Some (Boolexpr 0) -> (
- set_mutation_loc ();
+ | Some (Boolexpr 0) ->
+ set_mutation_loc ();
- mkpredef_call expr.expr_loc "not" [expr]
- )
+ mkpredef_call expr.expr_loc "not" [ expr ]
| Some (Boolexpr n) ->
- (target := Some (Boolexpr (n-1)); expr)
- | _ -> expr
-
-let fold_mutate_pre orig_expr e =
+ target := Some (Boolexpr (n - 1));
+ expr
+ | _ ->
+ expr
+
+let fold_mutate_pre orig_expr e =
match !target with
- Some (Pre 0) -> (
- set_mutation_loc ();
- Expr_pre ({orig_expr with expr_desc = Expr_pre e})
- )
- | Some (Pre n) -> (
- target := Some (Pre (n-1));
+ | Some (Pre 0) ->
+ set_mutation_loc ();
+ Expr_pre { orig_expr with expr_desc = Expr_pre e }
+ | Some (Pre n) ->
+ target := Some (Pre (n - 1));
+ Expr_pre e
+ | _ ->
Expr_pre e
- )
- | _ -> Expr_pre e
-
+
let fold_mutate_const_value c =
match c with
| Const_int i -> (
match !target with
- | Some (IncrIntCst 0) -> (set_mutation_loc (); Const_int (i+1))
- | Some (DecrIntCst 0) -> (set_mutation_loc (); Const_int (i-1))
+ | Some (IncrIntCst 0) ->
+ set_mutation_loc ();
+ Const_int (i + 1)
+ | Some (DecrIntCst 0) ->
+ set_mutation_loc ();
+ Const_int (i - 1)
| Some (SwitchIntCst (0, id)) ->
- (set_mutation_loc (); Const_int id)
- | Some (IncrIntCst n) -> (target := Some (IncrIntCst (n-1)); c)
- | Some (DecrIntCst n) -> (target := Some (DecrIntCst (n-1)); c)
- | Some (SwitchIntCst (n, id)) -> (target := Some (SwitchIntCst (n-1, id)); c)
- | _ -> c)
- | _ -> c
-
-(*
- match c with
- | Const_int i -> Const_int (fold_mutate_int i)
- | Const_real s -> Const_real s (* those are string, let's leave them *)
- | Const_float f -> Const_float (fold_mutate_float f)
- | Const_array _
- | Const_tag _ -> c
-TODO
-
- *)
+ set_mutation_loc ();
+ Const_int id
+ | Some (IncrIntCst n) ->
+ target := Some (IncrIntCst (n - 1));
+ c
+ | Some (DecrIntCst n) ->
+ target := Some (DecrIntCst (n - 1));
+ c
+ | Some (SwitchIntCst (n, id)) ->
+ target := Some (SwitchIntCst (n - 1, id));
+ c
+ | _ ->
+ c)
+ | _ ->
+ c
+
+(* match c with | Const_int i -> Const_int (fold_mutate_int i) | Const_real s ->
+ Const_real s (* those are string, let's leave them *) | Const_float f ->
+ Const_float (fold_mutate_float f) | Const_array _ | Const_tag _ -> c TODO *)
let fold_mutate_const c =
{ c with const_value = fold_mutate_const_value c.const_value }
let rec fold_mutate_expr expr =
current_loc := Some expr.expr_loc;
- let new_expr =
+ let new_expr =
match expr.expr_desc with
- | Expr_ident _ -> fold_mutate_var expr
- | _ -> (
- let new_desc = match expr.expr_desc with
- | Expr_const c -> Expr_const (fold_mutate_const_value c)
- | Expr_tuple l -> Expr_tuple (List.fold_right (fun e res -> (fold_mutate_expr e)::res) l [])
- | Expr_ite (i,t,e) -> Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e)
- | Expr_arrow (e1, e2) -> Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2)
- | Expr_pre e -> fold_mutate_pre expr (fold_mutate_expr e)
- | Expr_appl (op_id, args, r) -> Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r)
- (* Other constructs are kept.
- | Expr_fby of expr * expr
- | Expr_array of expr list
- | Expr_access of expr * Dimension.dim_expr
- | Expr_power of expr * Dimension.dim_expr
- | Expr_when of expr * ident * label
- | Expr_merge of ident * (label * expr) list
- | Expr_uclock of expr * int
- | Expr_dclock of expr * int
- | Expr_phclock of expr * rat *)
- | _ -> expr.expr_desc
-
+ | Expr_ident _ ->
+ fold_mutate_var expr
+ | _ ->
+ let new_desc =
+ match expr.expr_desc with
+ | Expr_const c ->
+ Expr_const (fold_mutate_const_value c)
+ | Expr_tuple l ->
+ Expr_tuple
+ (List.fold_right (fun e res -> fold_mutate_expr e :: res) l [])
+ | Expr_ite (i, t, e) ->
+ Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e)
+ | Expr_arrow (e1, e2) ->
+ Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2)
+ | Expr_pre e ->
+ fold_mutate_pre expr (fold_mutate_expr e)
+ | Expr_appl (op_id, args, r) ->
+ Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r)
+ (* Other constructs are kept. | Expr_fby of expr * expr | Expr_array of
+ expr list | Expr_access of expr * Dimension.dim_expr | Expr_power of
+ expr * Dimension.dim_expr | Expr_when of expr * ident * label |
+ Expr_merge of ident * (label * expr) list | Expr_uclock of expr * int
+ | Expr_dclock of expr * int | Expr_phclock of expr * rat *)
+ | _ ->
+ expr.expr_desc
in
+
{ expr with expr_desc = new_desc }
- )
in
- if Types.is_bool_type expr.expr_type then
- fold_mutate_boolexpr new_expr
- else
- new_expr
+ if Types.is_bool_type expr.expr_type then fold_mutate_boolexpr new_expr
+ else new_expr
let fold_mutate_eq eq =
current_eq_lhs := Some eq.eq_lhs;
{ eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
let fold_mutate_stmt stmt =
- match stmt with
- | Eq eq -> Eq (fold_mutate_eq eq)
- | Aut _ -> assert false
-
+ match stmt with Eq eq -> Eq (fold_mutate_eq eq) | Aut _ -> assert false
let fold_mutate_node nd =
current_node := Some nd.node_id;
let nd =
- { nd with
- node_stmts =
- List.fold_right (fun stmt res -> (fold_mutate_stmt stmt)::res) nd.node_stmts [];
+ {
+ nd with
+ node_stmts =
+ List.fold_right
+ (fun stmt res -> fold_mutate_stmt stmt :: res)
+ nd.node_stmts [];
}
in
- rename_node rename_app (fun x -> x) nd
+ rename_node rename_app (fun x -> x) nd
let fold_mutate_top_decl td =
match td.top_decl_desc with
- | Node nd -> { td with top_decl_desc = Node (fold_mutate_node nd)}
- | Const cst -> { td with top_decl_desc = Const (fold_mutate_const cst)}
- | _ -> td
-
+ | Node nd ->
+ { td with top_decl_desc = Node (fold_mutate_node nd) }
+ | Const cst ->
+ { td with top_decl_desc = Const (fold_mutate_const cst) }
+ | _ ->
+ td
+
(* Create a single mutant with the provided random seed *)
-let fold_mutate_prog prog =
- List.fold_right (fun e res -> (fold_mutate_top_decl e)::res) prog []
+let fold_mutate_prog prog =
+ List.fold_right (fun e res -> fold_mutate_top_decl e :: res) prog []
-let create_mutant prog directive =
- target := Some directive;
+let create_mutant prog directive =
+ target := Some directive;
let prog' = fold_mutate_prog prog in
- let mutation_info = match !target , !mutation_info with
- | None, Some mi -> mi
- | _ -> (
- Format.eprintf "Failed when creating mutant for directive %a@.@?" print_directive directive;
- let _ = match !target with Some dir' -> Format.eprintf "New directive %a@.@?" print_directive dir' | _ -> () in
- assert false (* The mutation has not been performed. *)
- )
-
+ let mutation_info =
+ match !target, !mutation_info with
+ | None, Some mi ->
+ mi
+ | _ ->
+ Format.eprintf "Failed when creating mutant for directive %a@.@?"
+ print_directive directive;
+ let _ =
+ match !target with
+ | Some dir' ->
+ Format.eprintf "New directive %a@.@?" print_directive dir'
+ | _ ->
+ ()
+ in
+ assert false
+ (* The mutation has not been performed. *)
in
-(* target := None; (* should happen only if no mutation occured during the
- visit *)*)
+
+ (* target := None; (* should happen only if no mutation occured during the
+ visit *)*)
prog', mutation_info
-
-let op_mutation op =
+let op_mutation op =
let res =
let rem_op l = List.filter (fun e -> e <> op) l in
- if List.mem op arith_op then rem_op arith_op else
- if List.mem op bool_op then rem_op bool_op else
- if List.mem op rel_op then rem_op rel_op else
- (Format.eprintf "Failing with op %s@." op;
- assert false
- )
+ if List.mem op arith_op then rem_op arith_op
+ else if List.mem op bool_op then rem_op bool_op
+ else if List.mem op rel_op then rem_op rel_op
+ else (
+ Format.eprintf "Failing with op %s@." op;
+ assert false)
in
- (* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:"," Format.pp_print_string) res; *)
+ (* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:","
+ Format.pp_print_string) res; *)
res
let rec remains select list =
- match list with
- [] -> []
- | hd::tl -> if select hd then tl else remains select tl
-
+ match list with
+ | [] ->
+ []
+ | hd :: tl ->
+ if select hd then tl else remains select tl
+
let next_change m =
- let res =
- let rec first_op () =
- try
- let min_binding = OpCount.min_binding !records.nb_op in
- Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding)))
- with Not_found -> first_boolexpr ()
- and first_boolexpr () =
- if !records.nb_boolexpr > 0 then
- Boolexpr 0
- else first_pre ()
- and first_pre () =
- if !records.nb_pre > 0 then
- Pre 0
- else
- first_op ()
- and first_intcst () =
- if IntSet.cardinal !records.consts > 0 then
- IncrIntCst 0
- else
- first_boolexpr ()
+ let res =
+ let rec first_op () =
+ try
+ let min_binding = OpCount.min_binding !records.nb_op in
+ Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding)))
+ with Not_found -> first_boolexpr ()
+ and first_boolexpr () =
+ if !records.nb_boolexpr > 0 then Boolexpr 0 else first_pre ()
+ and first_pre () = if !records.nb_pre > 0 then Pre 0 else first_op ()
+ and first_intcst () =
+ if IntSet.cardinal !records.consts > 0 then IncrIntCst 0
+ else first_boolexpr ()
+ in
+ match m with
+ | Boolexpr n ->
+ if n + 1 >= !records.nb_boolexpr then first_pre () else Boolexpr (n + 1)
+ | Pre n ->
+ if n + 1 >= !records.nb_pre then first_op () else Pre (n + 1)
+ | Op (orig, id, mut_op) -> (
+ match remains (fun x -> x = mut_op) (op_mutation orig) with
+ | next_op :: _ ->
+ Op (orig, id, next_op)
+ | [] ->
+ if id + 1 >= OpCount.find orig !records.nb_op then
+ match
+ remains (fun (k1, _) -> k1 = orig) (OpCount.bindings !records.nb_op)
+ with
+ | [] ->
+ first_intcst ()
+ | hd :: _ ->
+ Op (fst hd, 0, List.hd (op_mutation (fst hd)))
+ else Op (orig, id + 1, List.hd (op_mutation orig)))
+ | IncrIntCst n ->
+ if n + 1 >= IntSet.cardinal !records.consts then DecrIntCst 0
+ else IncrIntCst (n + 1)
+ | DecrIntCst n ->
+ if n + 1 >= IntSet.cardinal !records.consts then SwitchIntCst (0, 0)
+ else DecrIntCst (n + 1)
+ | SwitchIntCst (n, m) ->
+ if m + 1 > -1 + IntSet.cardinal !records.consts then
+ SwitchIntCst (n, m + 1)
+ else if n + 1 >= IntSet.cardinal !records.consts then
+ SwitchIntCst (n + 1, 0)
+ else first_boolexpr ()
in
- match m with
- | Boolexpr n ->
- if n+1 >= !records.nb_boolexpr then
- first_pre ()
- else
- Boolexpr (n+1)
- | Pre n ->
- if n+1 >= !records.nb_pre then
- first_op ()
- else Pre (n+1)
- | Op (orig, id, mut_op) -> (
- match remains (fun x -> x = mut_op) (op_mutation orig) with
- | next_op::_ -> Op (orig, id, next_op)
- | [] -> if id+1 >= OpCount.find orig !records.nb_op then (
- match remains (fun (k1, _) -> k1 = orig) (OpCount.bindings !records.nb_op) with
- | [] -> first_intcst ()
- | hd::_ -> Op (fst hd, 0, List.hd (op_mutation (fst hd)))
- ) else
- Op(orig, id+1, List.hd (op_mutation orig))
- )
- | IncrIntCst n ->
- if n+1 >= IntSet.cardinal !records.consts then
- DecrIntCst 0
- else IncrIntCst (n+1)
- | DecrIntCst n ->
- if n+1 >= IntSet.cardinal !records.consts then
- SwitchIntCst (0, 0)
- else DecrIntCst (n+1)
- | SwitchIntCst (n, m) ->
- if m+1 > -1 + IntSet.cardinal !records.consts then
- SwitchIntCst (n, m+1)
- else if n+1 >= IntSet.cardinal !records.consts then
- SwitchIntCst (n+1, 0)
- else first_boolexpr ()
- in
- (* Format.eprintf "from: %a to: %a@." print_directive m print_directive res; *)
+ (* Format.eprintf "from: %a to: %a@." print_directive m print_directive res; *)
res
-let fold_mutate nb prog =
+let fold_mutate nb prog =
incr random_seed;
Random.init !random_seed;
+
(* Local references to keep track of generated directives *)
(* build a set of integer 0, 1, ... n-1 for input n *)
@@ -692,158 +741,168 @@ let fold_mutate nb prog =
let arr = Array.init cpt (fun x -> x) in
Array.fold_right IntSet.add arr IntSet.empty
in
-
+
let possible_const_id = cpt_to_intset !records.nb_consts in
+
(* let possible_boolexpr_id = cpt_to_intset !records.nb_boolexpr in *)
(* let possible_pre_id = cpt_to_intset !records.nb_pre in *)
-
let incremented_const_id = ref IntSet.empty in
let decremented_const_id = ref IntSet.empty in
-
+
let create_new_incr_decr registered build =
- let possible = IntSet.diff possible_const_id !registered |> IntSet.elements in
+ let possible =
+ IntSet.diff possible_const_id !registered |> IntSet.elements
+ in
let len = List.length possible in
- if len <= 0 then
- false, build (-1) (* Should not be stored *)
+ if len <= 0 then false, build (-1) (* Should not be stored *)
else
let picked = List.nth possible (Random.int (List.length possible)) in
registered := IntSet.add picked !registered;
true, build picked
in
+ let module DblIntSet = Set.Make (struct
+ type t = int * int
- let module DblIntSet = Set.Make (struct type t = int * int let compare = compare end) in
+ let compare = compare
+ end) in
let switch_const_id = ref DblIntSet.empty in
let switch_set =
- if IntSet.cardinal !records.consts <= 1 then
- DblIntSet.empty
+ if IntSet.cardinal !records.consts <= 1 then DblIntSet.empty
else
- (* First element is cst id (the ith cst) while second is the
- ith element of the set of gathered constants
- !record.consts *)
- IntSet.fold (fun cst_id set ->
- IntSet.fold (fun ith_cst set ->
- DblIntSet.add (cst_id, ith_cst) set
- ) !records.consts set
- ) possible_const_id DblIntSet.empty
+ (* First element is cst id (the ith cst) while second is the ith element
+ of the set of gathered constants !record.consts *)
+ IntSet.fold
+ (fun cst_id set ->
+ IntSet.fold
+ (fun ith_cst set -> DblIntSet.add (cst_id, ith_cst) set)
+ !records.consts set)
+ possible_const_id DblIntSet.empty
in
let create_new_switch registered build =
- let possible = DblIntSet.diff switch_set !registered |> DblIntSet.elements in
+ let possible =
+ DblIntSet.diff switch_set !registered |> DblIntSet.elements
+ in
let len = List.length possible in
- if len <= 0 then
- false, build (-1,-1) (* Should not be stored *)
+ if len <= 0 then false, build (-1, -1) (* Should not be stored *)
else
let picked = List.nth possible (Random.int (List.length possible)) in
registered := DblIntSet.add picked !registered;
true, build picked
in
-
+
let find_next_new mutants mutant =
let find_next_new init current =
- if init = current || List.mem current mutants then raise Not_found else
-
- (* TODO: check if we can generate more cases. The following lines were
- cylcing and missing to detect that the enumaration was complete,
- leading to a non terminating process. The current setting is harder
- but may miss enumerating some cases. To be checked! *)
-
- (* if List.mem current mutants then *)
- (* find_next_new init (next_change current) *)
- (* else *)
- current
+ if init = current || List.mem current mutants then raise Not_found
+ else
+ (* TODO: check if we can generate more cases. The following lines were
+ cylcing and missing to detect that the enumaration was complete,
+ leading to a non terminating process. The current setting is harder
+ but may miss enumerating some cases. To be checked! *)
+
+ (* if List.mem current mutants then *)
+ (* find_next_new init (next_change current) *)
+ (* else *)
+ current
in
- find_next_new mutant (next_change mutant)
+ find_next_new mutant (next_change mutant)
in
(* Creating list of nb elements of mutants *)
- let rec create_mutants_directives rnb mutants =
- if rnb <= 0 then mutants
+ let rec create_mutants_directives rnb mutants =
+ if rnb <= 0 then mutants
else
(* Initial list of transformation *)
- let rec init_list x = if x <= 0 then [0] else x::(init_list (x-1)) in
+ let rec init_list x = if x <= 0 then [ 0 ] else x :: init_list (x - 1) in
let init_list = init_list 5 in
(* We generate a random permutation of the list: the first item is the
- transformation, the rest of the list act as fallback choices to make
- sure we produce something *)
+ transformation, the rest of the list act as fallback choices to make
+ sure we produce something *)
let shuffle l =
- let nd = List.map (fun c -> Random.bits (), c) l in
- let sond = List.sort compare nd in
- List.map snd sond
+ let nd = List.map (fun c -> Random.bits (), c) l in
+ let sond = List.sort compare nd in
+ List.map snd sond
in
let transforms = shuffle init_list in
let rec apply_transform transforms =
- let f id =
- match id with
- | 5 -> create_new_incr_decr incremented_const_id (fun x -> IncrIntCst x)
- | 4 -> create_new_incr_decr decremented_const_id (fun x -> DecrIntCst x)
- | 3 -> create_new_switch switch_const_id (fun (x,y) -> SwitchIntCst(x, y))
- | 2 -> !records.nb_pre >0, Pre (try Random.int !records.nb_pre with _ -> 0)
- | 1 -> !records.nb_boolexpr > 0, Boolexpr (try Random.int !records.nb_boolexpr with _ -> 0)
- | 0 -> let bindings = OpCount.bindings !records.nb_op in
- let bindings_len = List.length bindings in
- if bindings_len > 0 then
- let op, nb_op = List.nth bindings (try Random.int bindings_len with _ -> 0) in
- let op_mut = op_mutation op in
- let new_op = List.nth op_mut (try Random.int (List.length op_mut) with _ -> 0) in
- true, Op (op, (try Random.int nb_op with _ -> 0), new_op)
- else
- false, Boolexpr 0 (* Providing a dummy construct,
- it will be filtered out thanks
- to the negative status (fst =
- false) *)
- | _ -> assert false
- in
- match transforms with
- | [] -> assert false
- | [hd] -> f hd
- | hd::tl -> let ok, random_mutation = f hd in
- if ok then
- ok, random_mutation
- else
- apply_transform tl
+ let f id =
+ match id with
+ | 5 ->
+ create_new_incr_decr incremented_const_id (fun x -> IncrIntCst x)
+ | 4 ->
+ create_new_incr_decr decremented_const_id (fun x -> DecrIntCst x)
+ | 3 ->
+ create_new_switch switch_const_id (fun (x, y) ->
+ SwitchIntCst (x, y))
+ | 2 ->
+ ( !records.nb_pre > 0,
+ Pre (try Random.int !records.nb_pre with _ -> 0) )
+ | 1 ->
+ ( !records.nb_boolexpr > 0,
+ Boolexpr (try Random.int !records.nb_boolexpr with _ -> 0) )
+ | 0 ->
+ let bindings = OpCount.bindings !records.nb_op in
+ let bindings_len = List.length bindings in
+ if bindings_len > 0 then
+ let op, nb_op =
+ List.nth bindings (try Random.int bindings_len with _ -> 0)
+ in
+ let op_mut = op_mutation op in
+ let new_op =
+ List.nth op_mut
+ (try Random.int (List.length op_mut) with _ -> 0)
+ in
+ true, Op (op, (try Random.int nb_op with _ -> 0), new_op)
+ else false, Boolexpr 0
+ (* Providing a dummy construct, it will be filtered out thanks to the
+ negative status (fst = false) *)
+ | _ ->
+ assert false
+ in
+ match transforms with
+ | [] ->
+ assert false
+ | [ hd ] ->
+ f hd
+ | hd :: tl ->
+ let ok, random_mutation = f hd in
+ if ok then ok, random_mutation else apply_transform tl
in
let ok, random_mutation = apply_transform transforms in
let stop_process () =
- report ~level:1 (fun fmt -> fprintf fmt
- "Only %i mutants directives generated out of %i expected@ "
- (nb-rnb)
- nb);
- mutants
+ report ~level:1 (fun fmt ->
+ fprintf fmt
+ "Only %i mutants directives generated out of %i expected@ "
+ (nb - rnb) nb);
+ mutants
in
- if not ok then
- stop_process ()
+ if not ok then stop_process ()
else if List.mem random_mutation mutants then
- try
- let new_mutant = (find_next_new mutants random_mutation) in
- report ~level:2 (fun fmt -> fprintf fmt " %i mutants directive generated out of %i expected@ " (nb-rnb) nb);
- create_mutants_directives (rnb-1) (new_mutant::mutants)
- with Not_found -> (
- stop_process ()
- )
- else (
- create_mutants_directives (rnb-1) (random_mutation::mutants)
- )
+ try
+ let new_mutant = find_next_new mutants random_mutation in
+ report ~level:2 (fun fmt ->
+ fprintf fmt " %i mutants directive generated out of %i expected@ "
+ (nb - rnb) nb);
+ create_mutants_directives (rnb - 1) (new_mutant :: mutants)
+ with Not_found -> stop_process ()
+ else create_mutants_directives (rnb - 1) (random_mutation :: mutants)
in
let mutants_directives = create_mutants_directives nb [] in
- List.map (fun d ->
+ List.map
+ (fun d ->
let mutant, loc = create_mutant prog d in
- d, loc, mutant ) mutants_directives
-
+ d, loc, mutant)
+ mutants_directives
let mutate nb prog =
records := compute_records prog;
(* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *)
(* !records.nb_pre *)
-(* !records.nb_boolexpr *)
-(* (\* !records.op *\) *)
-(* ; *)
- fold_mutate nb prog
-
-
-
+ (* !records.nb_boolexpr *)
+ (* (\* !records.op *\) *)
+ (* ; *)
+ fold_mutate nb prog
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
-
-
diff --git a/src/normalization.ml b/src/normalization.ml
index f23a66fb21fc242f02f4d7ad518562e1cab5d41b..c9fe1d4740a7ce0b8de693f1424a775e2b80d9a7 100644
--- a/src/normalization.ml
+++ b/src/normalization.ml
@@ -16,7 +16,7 @@ open Format
(* To update thank to some command line options *)
let debug = ref false
-
+
(** Normalisation iters through the AST of expressions and bind fresh definition
when some criteria are met. This creation of fresh definition is performed by
the function mk_expr_alias_opt when the alias argument is on.
@@ -32,87 +32,95 @@ let debug = ref false
definitions.
*)
-type param_t =
- {
- unfold_arrow_active: bool;
- force_alias_ite: bool;
- force_alias_internal_fun: bool;
- }
+type param_t = {
+ unfold_arrow_active : bool;
+ force_alias_ite : bool;
+ force_alias_internal_fun : bool;
+}
+
+let params =
+ ref
+ {
+ unfold_arrow_active = false;
+ force_alias_ite = false;
+ force_alias_internal_fun = false;
+ }
-let params = ref
- {
- unfold_arrow_active = false;
- force_alias_ite = false;
- force_alias_internal_fun =false;
- }
+type norm_ctx_t = {
+ parentid : ident;
+ vars : var_decl list;
+ is_output : ident -> bool;
+}
-type norm_ctx_t =
+let expr_true loc ck =
{
- parentid: ident;
- vars: var_decl list;
- is_output: ident -> bool;
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_const (Const_tag tag_true);
+ expr_type = Type_predef.type_bool;
+ expr_clock = ck;
+ expr_delay = Delay.new_var ();
+ expr_annot = None;
+ expr_loc = loc;
}
-
-let expr_true loc ck =
-{ expr_tag = Utils.new_tag ();
- expr_desc = Expr_const (Const_tag tag_true);
- expr_type = Type_predef.type_bool;
- expr_clock = ck;
- expr_delay = Delay.new_var ();
- expr_annot = None;
- expr_loc = loc }
-
let expr_false loc ck =
-{ expr_tag = Utils.new_tag ();
- expr_desc = Expr_const (Const_tag tag_false);
- expr_type = Type_predef.type_bool;
- expr_clock = ck;
- expr_delay = Delay.new_var ();
- expr_annot = None;
- expr_loc = loc }
+ {
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_const (Const_tag tag_false);
+ expr_type = Type_predef.type_bool;
+ expr_clock = ck;
+ expr_delay = Delay.new_var ();
+ expr_annot = None;
+ expr_loc = loc;
+ }
let expr_once loc ck =
- { expr_tag = Utils.new_tag ();
- expr_desc = Expr_arrow (expr_true loc ck, expr_false loc ck);
- expr_type = Type_predef.type_bool;
- expr_clock = ck;
- expr_delay = Delay.new_var ();
- expr_annot = None;
- expr_loc = loc }
+ {
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_arrow (expr_true loc ck, expr_false loc ck);
+ expr_type = Type_predef.type_bool;
+ expr_clock = ck;
+ expr_delay = Delay.new_var ();
+ expr_annot = None;
+ expr_loc = loc;
+ }
let is_expr_once =
let dummy_expr_once = expr_once Location.dummy_loc (Clocks.new_var true) in
fun expr -> Corelang.is_eq_expr expr dummy_expr_once
let unfold_arrow expr =
- match expr.expr_desc with
- | Expr_arrow (e1, e2) ->
- let loc = expr.expr_loc in
- let ck = List.hd (Clocks.clock_list_of_clock expr.expr_clock) in
- { expr with expr_desc = Expr_ite (expr_once loc ck, e1, e2) }
- | _ -> assert false
-
-
+ match expr.expr_desc with
+ | Expr_arrow (e1, e2) ->
+ let loc = expr.expr_loc in
+ let ck = List.hd (Clocks.clock_list_of_clock expr.expr_clock) in
+ { expr with expr_desc = Expr_ite (expr_once loc ck, e1, e2) }
+ | _ -> assert false
(* Get the equation in [defs] with [expr] as rhs, if any *)
let get_expr_alias defs expr =
- try Some (List.find (fun eq -> Clocks.eq_clock expr.expr_clock eq.eq_rhs.expr_clock && is_eq_expr eq.eq_rhs expr) defs)
- with
- | Not_found -> None
-
+ try
+ Some
+ (List.find
+ (fun eq ->
+ Clocks.eq_clock expr.expr_clock eq.eq_rhs.expr_clock
+ && is_eq_expr eq.eq_rhs expr)
+ defs)
+ with Not_found -> None
+
(* Replace [expr] with (tuple of) [locals] *)
let replace_expr locals expr =
- match locals with
- | [] -> assert false
- | [v] -> { expr with
- expr_tag = Utils.new_tag ();
- expr_desc = Expr_ident v.var_id }
- | _ -> { expr with
- expr_tag = Utils.new_tag ();
- expr_desc = Expr_tuple (List.map expr_of_vdecl locals) }
+ match locals with
+ | [] -> assert false
+ | [ v ] ->
+ { expr with expr_tag = Utils.new_tag (); expr_desc = Expr_ident v.var_id }
+ | _ ->
+ {
+ expr with
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_tuple (List.map expr_of_vdecl locals);
+ }
-
(* IS IT USED ? TODO
(* Create an alias for [expr], if none exists yet *)
let mk_expr_alias (parentid, vars) (defs, vars) expr =
@@ -133,7 +141,7 @@ let mk_expr_alias (parentid, vars) (defs, vars) expr =
(* Format.eprintf "Checking def of alias: %a -> %a@." (fprintf_list ~sep:", " (fun fmt v -> Format.pp_print_string fmt v.var_id)) new_aliases Printers.pp_expr expr; *)
(new_def::defs, new_aliases@vars), replace_expr new_aliases expr
*)
-
+
(* Create an alias for [expr], if [expr] is not already an alias (i.e. an ident)
and [opt] is true
@@ -141,183 +149,211 @@ let mk_expr_alias (parentid, vars) (defs, vars) expr =
*)
let mk_expr_alias_opt opt norm_ctx (defs, vars) expr =
if !debug then
- Log.report ~plugin:"normalization" ~level:2
- (fun fmt -> Format.fprintf fmt "mk_expr_alias_opt %B %a %a %a@." opt Printers.pp_expr expr Types.print_ty expr.expr_type Clocks.print_ck expr.expr_clock);
+ Log.report ~plugin:"normalization" ~level:2 (fun fmt ->
+ Format.fprintf fmt "mk_expr_alias_opt %B %a %a %a@." opt
+ Printers.pp_expr expr Types.print_ty expr.expr_type Clocks.print_ck
+ expr.expr_clock);
match expr.expr_desc with
- | Expr_ident _ ->
- (defs, vars), expr
- | _ ->
- match get_expr_alias defs expr with
- | Some eq ->
- (* Format.eprintf "Found a preexisting definition@."; *)
- let aliases = List.map (fun id -> List.find (fun v -> v.var_id = id) vars) eq.eq_lhs in
- (defs, vars), replace_expr aliases expr
- | None ->
- (* Format.eprintf "Didnt found a preexisting definition (opt=%b)@." opt;
- * Format.eprintf "existing defs are: @[[%a@]]@."
- * (fprintf_list ~sep:"@ "(fun fmt eq ->
- * Format.fprintf fmt "ck:%a isckeq=%b, , iseq=%b, eq=%a"
- * Clocks.print_ck eq.eq_rhs.expr_clock
- * (Clocks.eq_clock expr.expr_clock eq.eq_rhs.expr_clock)
- * (is_eq_expr eq.eq_rhs expr)
- * Printers.pp_node_eq eq))
- * defs; *)
- if opt
- then
- let new_aliases =
- List.map2
- (mk_fresh_var (norm_ctx.parentid, (norm_ctx.vars@vars)) expr.expr_loc)
- (Types.type_list_of_type expr.expr_type)
- (Clocks.clock_list_of_clock expr.expr_clock) in
- let new_def =
- mkeq expr.expr_loc (List.map (fun v -> v.var_id) new_aliases, expr)
- in
- (* Typing and Registering machine type *)
- let _ = if Machine_types.is_active then
- Machine_types.type_def (norm_ctx.parentid, norm_ctx.vars) new_aliases expr
- in
- (new_def::defs, new_aliases@vars), replace_expr new_aliases expr
- else
- (defs, vars), expr
-
-(* Similar fonctions for dimensions *)
+ | Expr_ident _ -> (defs, vars), expr
+ | _ -> (
+ match get_expr_alias defs expr with
+ | Some eq ->
+ (* Format.eprintf "Found a preexisting definition@."; *)
+ let aliases =
+ List.map
+ (fun id -> List.find (fun v -> v.var_id = id) vars)
+ eq.eq_lhs
+ in
+ (defs, vars), replace_expr aliases expr
+ | None ->
+ (*
+ Format.eprintf "Didnt found a preexisting definition (opt=%b)@." opt;
+ * Format.eprintf "existing defs are: @[[%a@]]@."
+ * (fprintf_list ~sep:"@ "(fun fmt eq ->
+ * Format.fprintf fmt "ck:%a isckeq=%b, , iseq=%b, eq=%a"
+ * Clocks.print_ck eq.eq_rhs.expr_clock
+ * (Clocks.eq_clock expr.expr_clock eq.eq_rhs.expr_clock)
+ * (is_eq_expr eq.eq_rhs expr)
+ * Printers.pp_node_eq eq))
+ * defs; *)
+ if opt then
+ let new_aliases =
+ List.map2
+ (mk_fresh_var
+ (norm_ctx.parentid, norm_ctx.vars @ vars)
+ expr.expr_loc)
+ (Types.type_list_of_type expr.expr_type)
+ (Clocks.clock_list_of_clock expr.expr_clock)
+ in
+ let new_def =
+ mkeq expr.expr_loc (List.map (fun v -> v.var_id) new_aliases, expr)
+ in
+ (* Typing and Registering machine type *)
+ let _ =
+ if Machine_types.is_active then
+ Machine_types.type_def
+ (norm_ctx.parentid, norm_ctx.vars)
+ new_aliases expr
+ in
+ (new_def :: defs, new_aliases @ vars), replace_expr new_aliases expr
+ else (defs, vars), expr)
+
+(* Similar fonctions for dimensions *)
let mk_dim_alias opt norm_ctx (defs, vars) dim =
match dim.Dimension.dim_desc with
- | Dimension.Dbool _ | Dint _
- | Dident _ -> (defs, vars), dim (* Keep the same *)
- | _ when opt -> (* Cast to expression, normalizing *)
- let e = expr_of_dimension dim in
- let defvars, e = mk_expr_alias_opt true norm_ctx (defs, vars) e in
- defvars, dimension_of_expr e
-
- | _ -> (defs, vars), dim (* Keep the same *)
-
+ | Dimension.Dbool _ | Dint _ | Dident _ ->
+ (defs, vars), dim (* Keep the same *)
+ | _ when opt ->
+ (* Cast to expression, normalizing *)
+ let e = expr_of_dimension dim in
+ let defvars, e = mk_expr_alias_opt true norm_ctx (defs, vars) e in
+ defvars, dimension_of_expr e
+ | _ -> (defs, vars), dim
+(* Keep the same *)
let unfold_offsets norm_ctx defvars e offsets =
let add_offset (defvars, e) d =
(*Format.eprintf "add_offset %a(%a) %a @." Printers.pp_expr e Types.print_ty e.expr_type Dimension.pp_dimension d; *)
- let defvars, d = mk_dim_alias !params.force_alias_internal_fun norm_ctx defvars d in
- let new_e =
- { e with
+ let defvars, d =
+ mk_dim_alias !params.force_alias_internal_fun norm_ctx defvars d
+ in
+ let new_e =
+ {
+ e with
expr_tag = Utils.new_tag ();
expr_loc = d.Dimension.dim_loc;
expr_type = Types.array_element_type e.expr_type;
- expr_desc = Expr_access (e, d) }
+ expr_desc = Expr_access (e, d);
+ }
in
defvars, new_e
-(*in (Format.eprintf "= %a @." Printers.pp_expr res; res) *)
+ (*in (Format.eprintf "= %a @." Printers.pp_expr res; res) *)
in
- List.fold_left add_offset (defvars, e) offsets
+ List.fold_left add_offset (defvars, e) offsets
-
(* Create a (normalized) expression from [ref_e],
replacing description with [norm_d],
taking propagated [offsets] into account
in order to change expression type *)
let mk_norm_expr offsets ref_e norm_d =
(*Format.eprintf "mk_norm_expr %a %a @." Printers.pp_expr ref_e Printers.pp_expr { ref_e with expr_desc = norm_d};*)
- let drop_array_type ty =
- Types.map_tuple_type Types.array_element_type ty in
- { ref_e with
+ let drop_array_type ty = Types.map_tuple_type Types.array_element_type ty in
+ {
+ ref_e with
expr_desc = norm_d;
- expr_type = Utils.repeat (List.length offsets) drop_array_type ref_e.expr_type }
-
+ expr_type =
+ Utils.repeat (List.length offsets) drop_array_type ref_e.expr_type;
+ }
+
(* normalize_<foo> : defs * used vars -> <foo> -> (updated defs * updated vars) * normalized <foo> *)
let normalize_list alias norm_ctx offsets norm_element defvars elist =
List.fold_right
(fun t (defvars, qlist) ->
let defvars, norm_t = norm_element alias norm_ctx offsets defvars t in
- (defvars, norm_t :: qlist)
- ) elist (defvars, [])
+ defvars, norm_t :: qlist)
+ elist (defvars, [])
-let rec normalize_expr ?(alias=true) ?(alias_basic=false) norm_ctx offsets defvars expr =
+let rec normalize_expr ?(alias = true) ?(alias_basic = false) norm_ctx offsets
+ defvars expr =
(* Format.eprintf "normalize %B %a:%a [%a]@." alias Printers.pp_expr expr Types.print_ty expr.expr_type (Utils.fprintf_list ~sep:"," Dimension.pp_dimension) offsets; *)
match expr.expr_desc with
- | Expr_const _
- | Expr_ident _ ->
- unfold_offsets norm_ctx defvars expr offsets
+ | Expr_const _ | Expr_ident _ -> unfold_offsets norm_ctx defvars expr offsets
| Expr_array elist ->
- let defvars, norm_elist = normalize_list alias norm_ctx offsets (fun _ -> normalize_array_expr ~alias:true) defvars elist in
- let norm_expr = mk_norm_expr offsets expr (Expr_array norm_elist) in
- mk_expr_alias_opt alias norm_ctx defvars norm_expr
+ let defvars, norm_elist =
+ normalize_list alias norm_ctx offsets
+ (fun _ -> normalize_array_expr ~alias:true)
+ defvars elist
+ in
+ let norm_expr = mk_norm_expr offsets expr (Expr_array norm_elist) in
+ mk_expr_alias_opt alias norm_ctx defvars norm_expr
| Expr_power (e1, d) when offsets = [] ->
- let defvars, norm_e1 = normalize_expr norm_ctx offsets defvars e1 in
- let norm_expr = mk_norm_expr offsets expr (Expr_power (norm_e1, d)) in
- mk_expr_alias_opt alias norm_ctx defvars norm_expr
+ let defvars, norm_e1 = normalize_expr norm_ctx offsets defvars e1 in
+ let norm_expr = mk_norm_expr offsets expr (Expr_power (norm_e1, d)) in
+ mk_expr_alias_opt alias norm_ctx defvars norm_expr
| Expr_power (e1, _) ->
- normalize_expr ~alias:alias norm_ctx (List.tl offsets) defvars e1
+ normalize_expr ~alias norm_ctx (List.tl offsets) defvars e1
| Expr_access (e1, d) ->
- normalize_expr ~alias:alias norm_ctx (d::offsets) defvars e1
-
+ normalize_expr ~alias norm_ctx (d :: offsets) defvars e1
| Expr_tuple elist ->
- let defvars, norm_elist =
- normalize_list alias norm_ctx offsets (fun alias -> normalize_expr ~alias:alias ~alias_basic:false) defvars elist in
- defvars, mk_norm_expr offsets expr (Expr_tuple norm_elist)
+ let defvars, norm_elist =
+ normalize_list alias norm_ctx offsets
+ (fun alias -> normalize_expr ~alias ~alias_basic:false)
+ defvars elist
+ in
+ defvars, mk_norm_expr offsets expr (Expr_tuple norm_elist)
| Expr_appl (id, args, None)
- when Basic_library.is_homomorphic_fun id
- && Types.is_array_type expr.expr_type ->
- let defvars, norm_args =
- normalize_list
- alias
- norm_ctx
- offsets
- (fun _ -> normalize_array_expr ~alias:true)
- defvars
- (expr_list_of_expr args)
- in
- defvars, mk_norm_expr offsets expr (Expr_appl (id, expr_of_expr_list args.expr_loc norm_args, None))
- | Expr_appl (id, args, None) when Basic_library.is_expr_internal_fun expr
- && not (!params.force_alias_internal_fun || alias_basic) ->
- let defvars, norm_args = normalize_expr ~alias:true norm_ctx offsets defvars args in
- defvars, mk_norm_expr offsets expr (Expr_appl (id, norm_args, None))
+ when Basic_library.is_homomorphic_fun id
+ && Types.is_array_type expr.expr_type ->
+ let defvars, norm_args =
+ normalize_list alias norm_ctx offsets
+ (fun _ -> normalize_array_expr ~alias:true)
+ defvars (expr_list_of_expr args)
+ in
+ ( defvars,
+ mk_norm_expr offsets expr
+ (Expr_appl (id, expr_of_expr_list args.expr_loc norm_args, None)) )
+ | Expr_appl (id, args, None)
+ when Basic_library.is_expr_internal_fun expr
+ && not (!params.force_alias_internal_fun || alias_basic) ->
+ let defvars, norm_args =
+ normalize_expr ~alias:true norm_ctx offsets defvars args
+ in
+ defvars, mk_norm_expr offsets expr (Expr_appl (id, norm_args, None))
| Expr_appl (id, args, r) ->
- let defvars, r =
- match r with
- | None -> defvars, None
- | Some r ->
- let defvars, norm_r = normalize_expr ~alias_basic:true norm_ctx [] defvars r in
- defvars, Some norm_r
- in
- let defvars, norm_args = normalize_expr norm_ctx [] defvars args in
- let norm_expr = mk_norm_expr [] expr (Expr_appl (id, norm_args, r)) in
- if offsets <> []
- then
- let defvars, norm_expr = normalize_expr norm_ctx [] defvars norm_expr in
- normalize_expr ~alias:alias norm_ctx offsets defvars norm_expr
- else
- mk_expr_alias_opt (alias && (!params.force_alias_internal_fun || alias_basic
- || not (Basic_library.is_expr_internal_fun expr)))
- norm_ctx defvars norm_expr
+ let defvars, r =
+ match r with
+ | None -> defvars, None
+ | Some r ->
+ let defvars, norm_r =
+ normalize_expr ~alias_basic:true norm_ctx [] defvars r
+ in
+ defvars, Some norm_r
+ in
+ let defvars, norm_args = normalize_expr norm_ctx [] defvars args in
+ let norm_expr = mk_norm_expr [] expr (Expr_appl (id, norm_args, r)) in
+ if offsets <> [] then
+ let defvars, norm_expr = normalize_expr norm_ctx [] defvars norm_expr in
+ normalize_expr ~alias norm_ctx offsets defvars norm_expr
+ else
+ mk_expr_alias_opt
+ (alias
+ && (!params.force_alias_internal_fun || alias_basic
+ || not (Basic_library.is_expr_internal_fun expr)))
+ norm_ctx defvars norm_expr
| Expr_arrow _ when !params.unfold_arrow_active && not (is_expr_once expr) ->
- (* Here we differ from Colaco paper: arrows are pushed to the top *)
- normalize_expr ~alias:alias norm_ctx offsets defvars (unfold_arrow expr)
- | Expr_arrow (e1,e2) ->
- let defvars, norm_e1 = normalize_expr norm_ctx offsets defvars e1 in
- let defvars, norm_e2 = normalize_expr norm_ctx offsets defvars e2 in
- let norm_expr = mk_norm_expr offsets expr (Expr_arrow (norm_e1, norm_e2)) in
- mk_expr_alias_opt alias norm_ctx defvars norm_expr
+ (* Here we differ from Colaco paper: arrows are pushed to the top *)
+ normalize_expr ~alias norm_ctx offsets defvars (unfold_arrow expr)
+ | Expr_arrow (e1, e2) ->
+ let defvars, norm_e1 = normalize_expr norm_ctx offsets defvars e1 in
+ let defvars, norm_e2 = normalize_expr norm_ctx offsets defvars e2 in
+ let norm_expr =
+ mk_norm_expr offsets expr (Expr_arrow (norm_e1, norm_e2))
+ in
+ mk_expr_alias_opt alias norm_ctx defvars norm_expr
| Expr_pre e ->
- let defvars, norm_e = normalize_expr norm_ctx offsets defvars e in
- let norm_expr = mk_norm_expr offsets expr (Expr_pre norm_e) in
- mk_expr_alias_opt alias norm_ctx defvars norm_expr
+ let defvars, norm_e = normalize_expr norm_ctx offsets defvars e in
+ let norm_expr = mk_norm_expr offsets expr (Expr_pre norm_e) in
+ mk_expr_alias_opt alias norm_ctx defvars norm_expr
| Expr_fby (e1, e2) ->
- let defvars, norm_e1 = normalize_expr norm_ctx offsets defvars e1 in
- let defvars, norm_e2 = normalize_expr norm_ctx offsets defvars e2 in
- let norm_expr = mk_norm_expr offsets expr (Expr_fby (norm_e1, norm_e2)) in
- mk_expr_alias_opt alias norm_ctx defvars norm_expr
+ let defvars, norm_e1 = normalize_expr norm_ctx offsets defvars e1 in
+ let defvars, norm_e2 = normalize_expr norm_ctx offsets defvars e2 in
+ let norm_expr = mk_norm_expr offsets expr (Expr_fby (norm_e1, norm_e2)) in
+ mk_expr_alias_opt alias norm_ctx defvars norm_expr
| Expr_when (e, c, l) ->
- let defvars, norm_e = normalize_expr norm_ctx offsets defvars e in
- defvars, mk_norm_expr offsets expr (Expr_when (norm_e, c, l))
+ let defvars, norm_e = normalize_expr norm_ctx offsets defvars e in
+ defvars, mk_norm_expr offsets expr (Expr_when (norm_e, c, l))
| Expr_ite (c, t, e) ->
- let defvars, norm_c = normalize_guard norm_ctx defvars c in
- let defvars, norm_t = normalize_cond_expr norm_ctx offsets defvars t in
- let defvars, norm_e = normalize_cond_expr norm_ctx offsets defvars e in
- let norm_expr = mk_norm_expr offsets expr (Expr_ite (norm_c, norm_t, norm_e)) in
- mk_expr_alias_opt alias norm_ctx defvars norm_expr
+ let defvars, norm_c = normalize_guard norm_ctx defvars c in
+ let defvars, norm_t = normalize_cond_expr norm_ctx offsets defvars t in
+ let defvars, norm_e = normalize_cond_expr norm_ctx offsets defvars e in
+ let norm_expr =
+ mk_norm_expr offsets expr (Expr_ite (norm_c, norm_t, norm_e))
+ in
+ mk_expr_alias_opt alias norm_ctx defvars norm_expr
| Expr_merge (c, hl) ->
- let defvars, norm_hl = normalize_branches norm_ctx offsets defvars hl in
- let norm_expr = mk_norm_expr offsets expr (Expr_merge (c, norm_hl)) in
- mk_expr_alias_opt alias norm_ctx defvars norm_expr
+ let defvars, norm_hl = normalize_branches norm_ctx offsets defvars hl in
+ let norm_expr = mk_norm_expr offsets expr (Expr_merge (c, norm_hl)) in
+ mk_expr_alias_opt alias norm_ctx defvars norm_expr
(* Creates a conditional with a merge construct, which is more lazy *)
(*
@@ -330,52 +366,65 @@ let rec normalize_expr ?(alias=true) ?(alias_basic=false) norm_ctx offsets defva
and normalize_branches norm_ctx offsets defvars hl =
List.fold_right
(fun (t, h) (defvars, norm_q) ->
- let (defvars, norm_h) = normalize_cond_expr norm_ctx offsets defvars h in
- defvars, (t, norm_h) :: norm_q
- )
+ let defvars, norm_h = normalize_cond_expr norm_ctx offsets defvars h in
+ defvars, (t, norm_h) :: norm_q)
hl (defvars, [])
-and normalize_array_expr ?(alias=true) norm_ctx offsets defvars expr =
+and normalize_array_expr ?(alias = true) norm_ctx offsets defvars expr =
(*Format.eprintf "normalize_array %B %a [%a]@." alias Printers.pp_expr expr (Utils.fprintf_list ~sep:"," Dimension.pp_dimension) offsets;*)
match expr.expr_desc with
| Expr_power (e1, d) when offsets = [] ->
- let defvars, norm_e1 = normalize_expr norm_ctx offsets defvars e1 in
- defvars, mk_norm_expr offsets expr (Expr_power (norm_e1, d))
+ let defvars, norm_e1 = normalize_expr norm_ctx offsets defvars e1 in
+ defvars, mk_norm_expr offsets expr (Expr_power (norm_e1, d))
| Expr_power (e1, _) ->
- normalize_array_expr ~alias:alias norm_ctx (List.tl offsets) defvars e1
- | Expr_access (e1, d) -> normalize_array_expr ~alias:alias norm_ctx (d::offsets) defvars e1
+ normalize_array_expr ~alias norm_ctx (List.tl offsets) defvars e1
+ | Expr_access (e1, d) ->
+ normalize_array_expr ~alias norm_ctx (d :: offsets) defvars e1
| Expr_array elist when offsets = [] ->
- let defvars, norm_elist = normalize_list alias norm_ctx offsets (fun _ -> normalize_array_expr ~alias:true) defvars elist in
- defvars, mk_norm_expr offsets expr (Expr_array norm_elist)
+ let defvars, norm_elist =
+ normalize_list alias norm_ctx offsets
+ (fun _ -> normalize_array_expr ~alias:true)
+ defvars elist
+ in
+ defvars, mk_norm_expr offsets expr (Expr_array norm_elist)
| Expr_appl (id, args, None) when Basic_library.is_expr_internal_fun expr ->
- let defvars, norm_args = normalize_list alias norm_ctx offsets (fun _ -> normalize_array_expr ~alias:true) defvars (expr_list_of_expr args) in
- defvars, mk_norm_expr offsets expr (Expr_appl (id, expr_of_expr_list args.expr_loc norm_args, None))
- | _ -> normalize_expr ~alias:alias norm_ctx offsets defvars expr
-
-and normalize_cond_expr ?(alias=true) norm_ctx offsets defvars expr =
+ let defvars, norm_args =
+ normalize_list alias norm_ctx offsets
+ (fun _ -> normalize_array_expr ~alias:true)
+ defvars (expr_list_of_expr args)
+ in
+ ( defvars,
+ mk_norm_expr offsets expr
+ (Expr_appl (id, expr_of_expr_list args.expr_loc norm_args, None)) )
+ | _ -> normalize_expr ~alias norm_ctx offsets defvars expr
+
+and normalize_cond_expr ?(alias = true) norm_ctx offsets defvars expr =
(* Format.eprintf "normalize_cond %B %a [%a]@." alias Printers.pp_expr expr (Utils.fprintf_list ~sep:"," Dimension.pp_dimension) offsets; *)
match expr.expr_desc with
| Expr_access (e1, d) ->
- normalize_cond_expr ~alias:alias norm_ctx (d::offsets) defvars e1
+ normalize_cond_expr ~alias norm_ctx (d :: offsets) defvars e1
| Expr_ite (c, t, e) ->
- let defvars, norm_c = normalize_guard norm_ctx defvars c in
- let defvars, norm_t = normalize_cond_expr norm_ctx offsets defvars t in
- let defvars, norm_e = normalize_cond_expr norm_ctx offsets defvars e in
- defvars, mk_norm_expr offsets expr (Expr_ite (norm_c, norm_t, norm_e))
+ let defvars, norm_c = normalize_guard norm_ctx defvars c in
+ let defvars, norm_t = normalize_cond_expr norm_ctx offsets defvars t in
+ let defvars, norm_e = normalize_cond_expr norm_ctx offsets defvars e in
+ defvars, mk_norm_expr offsets expr (Expr_ite (norm_c, norm_t, norm_e))
| Expr_merge (c, hl) ->
- let defvars, norm_hl = normalize_branches norm_ctx offsets defvars hl in
- defvars, mk_norm_expr offsets expr (Expr_merge (c, norm_hl))
+ let defvars, norm_hl = normalize_branches norm_ctx offsets defvars hl in
+ defvars, mk_norm_expr offsets expr (Expr_merge (c, norm_hl))
| _ when !params.force_alias_ite ->
- (* Forcing alias creation for then/else expressions *)
- let defvars, norm_expr =
- normalize_expr ~alias:alias norm_ctx offsets defvars expr
- in
- mk_expr_alias_opt true norm_ctx defvars norm_expr
- | _ -> (* default case without the force_alias_ite option *)
- normalize_expr ~alias:alias norm_ctx offsets defvars expr
-
+ (* Forcing alias creation for then/else expressions *)
+ let defvars, norm_expr =
+ normalize_expr ~alias norm_ctx offsets defvars expr
+ in
+ mk_expr_alias_opt true norm_ctx defvars norm_expr
+ | _ ->
+ (* default case without the force_alias_ite option *)
+ normalize_expr ~alias norm_ctx offsets defvars expr
+
and normalize_guard norm_ctx defvars expr =
- let defvars, norm_expr = normalize_expr ~alias_basic:true norm_ctx [] defvars expr in
+ let defvars, norm_expr =
+ normalize_expr ~alias_basic:true norm_ctx [] defvars expr
+ in
mk_expr_alias_opt true norm_ctx defvars norm_expr
(* outputs cannot be memories as well. If so, introduce new local variable.
@@ -383,92 +432,100 @@ and normalize_guard norm_ctx defvars expr =
let decouple_outputs norm_ctx defvars eq =
let rec fold_lhs defvars lhs tys cks =
match lhs, tys, cks with
- | [], [], [] -> defvars, []
- | v::qv, t::qt, c::qc -> let (defs_q, vars_q), lhs_q = fold_lhs defvars qv qt qc in
- if norm_ctx.is_output v
- then
- let newvar = mk_fresh_var (norm_ctx.parentid, norm_ctx.vars) eq.eq_loc t c in
- let neweq = mkeq eq.eq_loc ([v], expr_of_vdecl newvar) in
- (neweq :: defs_q, newvar :: vars_q), newvar.var_id :: lhs_q
- else
- (defs_q, vars_q), v::lhs_q
- | _ -> assert false in
+ | [], [], [] -> defvars, []
+ | v :: qv, t :: qt, c :: qc ->
+ let (defs_q, vars_q), lhs_q = fold_lhs defvars qv qt qc in
+ if norm_ctx.is_output v then
+ let newvar =
+ mk_fresh_var (norm_ctx.parentid, norm_ctx.vars) eq.eq_loc t c
+ in
+ let neweq = mkeq eq.eq_loc ([ v ], expr_of_vdecl newvar) in
+ (neweq :: defs_q, newvar :: vars_q), newvar.var_id :: lhs_q
+ else (defs_q, vars_q), v :: lhs_q
+ | _ -> assert false
+ in
let defvars', lhs' =
- fold_lhs
- defvars
- eq.eq_lhs
+ fold_lhs defvars eq.eq_lhs
(Types.type_list_of_type eq.eq_rhs.expr_type)
- (Clocks.clock_list_of_clock eq.eq_rhs.expr_clock) in
- defvars', {eq with eq_lhs = lhs' }
+ (Clocks.clock_list_of_clock eq.eq_rhs.expr_clock)
+ in
+ defvars', { eq with eq_lhs = lhs' }
let normalize_eq norm_ctx defvars eq =
-(*Format.eprintf "normalize_eq %a@." Types.print_ty eq.eq_rhs.expr_type;*)
+ (*Format.eprintf "normalize_eq %a@." Types.print_ty eq.eq_rhs.expr_type;*)
match eq.eq_rhs.expr_desc with
- | Expr_pre _
- | Expr_fby _ ->
- let (defvars', eq') = decouple_outputs norm_ctx defvars eq in
- let (defs', vars'), norm_rhs = normalize_expr ~alias:false norm_ctx [] defvars' eq'.eq_rhs in
- let norm_eq = { eq' with eq_rhs = norm_rhs } in
- (norm_eq::defs', vars')
+ | Expr_pre _ | Expr_fby _ ->
+ let defvars', eq' = decouple_outputs norm_ctx defvars eq in
+ let (defs', vars'), norm_rhs =
+ normalize_expr ~alias:false norm_ctx [] defvars' eq'.eq_rhs
+ in
+ let norm_eq = { eq' with eq_rhs = norm_rhs } in
+ norm_eq :: defs', vars'
| Expr_array _ ->
- let (defs', vars'), norm_rhs = normalize_array_expr ~alias:false norm_ctx [] defvars eq.eq_rhs in
- let norm_eq = { eq with eq_rhs = norm_rhs } in
- (norm_eq::defs', vars')
- | Expr_appl (id, _, None) when Basic_library.is_homomorphic_fun id && Types.is_array_type eq.eq_rhs.expr_type ->
- let (defs', vars'), norm_rhs = normalize_array_expr ~alias:false norm_ctx [] defvars eq.eq_rhs in
- let norm_eq = { eq with eq_rhs = norm_rhs } in
- (norm_eq::defs', vars')
+ let (defs', vars'), norm_rhs =
+ normalize_array_expr ~alias:false norm_ctx [] defvars eq.eq_rhs
+ in
+ let norm_eq = { eq with eq_rhs = norm_rhs } in
+ norm_eq :: defs', vars'
+ | Expr_appl (id, _, None)
+ when Basic_library.is_homomorphic_fun id
+ && Types.is_array_type eq.eq_rhs.expr_type ->
+ let (defs', vars'), norm_rhs =
+ normalize_array_expr ~alias:false norm_ctx [] defvars eq.eq_rhs
+ in
+ let norm_eq = { eq with eq_rhs = norm_rhs } in
+ norm_eq :: defs', vars'
| Expr_appl _ ->
- let (defs', vars'), norm_rhs = normalize_expr ~alias:false norm_ctx [] defvars eq.eq_rhs in
- let norm_eq = { eq with eq_rhs = norm_rhs } in
- (norm_eq::defs', vars')
+ let (defs', vars'), norm_rhs =
+ normalize_expr ~alias:false norm_ctx [] defvars eq.eq_rhs
+ in
+ let norm_eq = { eq with eq_rhs = norm_rhs } in
+ norm_eq :: defs', vars'
| _ ->
- let (defs', vars'), norm_rhs = normalize_cond_expr ~alias:false norm_ctx [] defvars eq.eq_rhs in
- let norm_eq = { eq with eq_rhs = norm_rhs } in
- norm_eq::defs', vars'
+ let (defs', vars'), norm_rhs =
+ normalize_cond_expr ~alias:false norm_ctx [] defvars eq.eq_rhs
+ in
+ let norm_eq = { eq with eq_rhs = norm_rhs } in
+ norm_eq :: defs', vars'
let normalize_eq_split norm_ctx defvars eq =
try
let defs, vars = normalize_eq norm_ctx defvars eq in
- List.fold_right (fun eq (def, vars) ->
+ List.fold_right
+ (fun eq (def, vars) ->
let eq_defs = Splitting.tuple_split_eq eq in
- if eq_defs = [eq] then
- eq::def, vars
- else
- List.fold_left (normalize_eq norm_ctx) (def, vars) eq_defs
- ) defs ([], vars)
-
- with ex -> (
+ if eq_defs = [ eq ] then eq :: def, vars
+ else List.fold_left (normalize_eq norm_ctx) (def, vars) eq_defs)
+ defs ([], vars)
+ with ex ->
Format.eprintf "Issue normalizing eq split: %a@." Printers.pp_node_eq eq;
raise ex
- )
(* Projecting an eexpr to an eexpr associated to a single
variable. Returns the updated ee, the bounded variable and the
associated statement *)
-let normalize_pred_eexpr norm_ctx (def,vars) ee =
- assert (ee.eexpr_quantifiers = []); (* We do not normalize quantifiers yet. This is for very far future. *)
+let normalize_pred_eexpr norm_ctx (def, vars) ee =
+ assert (ee.eexpr_quantifiers = []);
+ (* We do not normalize quantifiers yet. This is for very far future. *)
(* don't do anything is eexpr is just a variable *)
let skip =
match ee.eexpr_qfexpr.expr_desc with
| Expr_ident _ | Expr_const _ -> true
| _ -> false
in
- if skip then
- ee, (def, vars)
- else (
+ if skip then ee, (def, vars)
+ else
(* New output variable *)
let output_id = "spec" ^ string_of_int ee.eexpr_tag in
- let output_var =
- mkvar_decl
- ee.eexpr_loc
- (output_id,
- mktyp ee.eexpr_loc Tydec_bool, (* It is a predicate, hence a bool *)
- mkclock ee.eexpr_loc Ckdec_any,
- false (* not a constant *),
- None,
- None
- )
+ let output_var =
+ mkvar_decl ee.eexpr_loc
+ ( output_id,
+ mktyp ee.eexpr_loc Tydec_bool,
+ (* It is a predicate, hence a bool *)
+ mkclock ee.eexpr_loc Ckdec_any,
+ false (* not a constant *),
+ None,
+ None )
in
let output_expr = expr_of_vdecl output_var in
(* Rebuilding an eexpr with a silly expression, just a variable *)
@@ -476,9 +533,8 @@ let normalize_pred_eexpr norm_ctx (def,vars) ee =
(* Now processing a fresh equation output_id = eexpr_qfexpr. We
inline possible calls within, normalize it and type/clock the
- result. *)
- let eq = mkeq ee.eexpr_loc ([output_id], ee.eexpr_qfexpr) in
-
+ result. *)
+ let eq = mkeq ee.eexpr_loc ([ output_id ], ee.eexpr_qfexpr) in
(* (\* Inlining any calls *\)
* let nodes = get_nodes decls in
@@ -489,20 +545,24 @@ let normalize_pred_eexpr norm_ctx (def,vars) ee =
* else
* assert false (\* TODO *\)
* in *)
-
+
(* Normalizing expr and eqs *)
- let defs, vars = List.fold_left (normalize_eq_split norm_ctx) (def, vars) [eq] in
- let vars = output_var :: vars in
-(* let todefine =
- List.fold_left
- (fun m x-> if List.exists (fun y-> x.var_id = y.var_id) (locals) then m else ISet.add x.var_id m)
- (ISet.add output_id ISet.empty) vars in
- *)
+ let defs, vars =
+ List.fold_left (normalize_eq_split norm_ctx) (def, vars) [ eq ]
+ in
+ let vars = output_var :: vars in
+
+ (* let todefine =
+ List.fold_left
+ (fun m x-> if List.exists (fun y-> x.var_id = y.var_id) (locals) then m else ISet.add x.var_id m)
+ (ISet.add output_id ISet.empty) vars in
+ *)
(* Typing / Clocking *)
try
ignore (Typing.type_var_decl_list vars !Global.type_env vars);
- (*
+
+ (*
let env = Typing.type_var_decl [] !Global.type_env xxxx output_var in (* typing the variable *)
(* Format.eprintf "typing var %s: %a@." output_id Types.print_ty output_var.var_type; *)
let env = Typing.type_var_decl_list (vars@node.node_outputs@node.node_inputs) env (vars@node.node_outputs@node.node_inputs) in
@@ -515,23 +575,16 @@ let normalize_pred_eexpr norm_ctx (def,vars) ee =
(*Format.eprintf "normalized eqs %a@.@?"
(Utils.fprintf_list ~sep:", " Printers.pp_node_eq) defs; *)
*)
+ ee', (defs, vars)
+ with Types.Error (loc, err) as exc ->
+ eprintf "Typing error for eexpr %a: %a%a%a@." Printers.pp_eexpr ee
+ Types.pp_error err
+ (Utils.fprintf_list ~sep:", " Printers.pp_node_eq)
+ defs Location.pp_loc loc;
- ee', (defs, vars)
-
- with (Types.Error (loc,err)) as exc ->
- eprintf "Typing error for eexpr %a: %a%a%a@."
- Printers.pp_eexpr ee
- Types.pp_error err
- (Utils.fprintf_list ~sep:", " Printers.pp_node_eq) defs
- Location.pp_loc loc
-
-
- ;
- raise exc
-
- )
-
- (*
+ raise exc
+
+(*
let quant_vars = List.flatten (List.map snd ee.eexpr_quantifiers) in
(* Calls are first inlined *)
@@ -580,64 +633,72 @@ let normalize_pred_eexpr norm_ctx (def,vars) ee =
;
raise exc
- *)
-
+ *)
-(* We use node local vars to make sure we are creating fresh variables *)
+(* We use node local vars to make sure we are creating fresh variables *)
let normalize_spec parentid (in_vars, out_vars, l_vars) s =
(* Original set of variables actually visible from here: in/out and
spec locals (no node locals) *)
let orig_vars = in_vars @ out_vars @ s.locals in
(* Format.eprintf "NormSpec: init locals: %a@." Printers.pp_vars s.locals; *)
- let not_is_orig_var v =
- List.for_all ((!=) v) orig_vars in
- let norm_ctx = {
- parentid = parentid;
+ let not_is_orig_var v = List.for_all (( != ) v) orig_vars in
+ let norm_ctx =
+ {
+ parentid;
vars = in_vars @ out_vars @ l_vars;
- is_output = (fun _ -> false) (* no need to introduce fresh variables for outputs *);
+ is_output =
+ (fun _ -> false) (* no need to introduce fresh variables for outputs *);
}
in
(* Normalizing existing stmts *)
- let eqs, auts = List.fold_right (fun s (el,al) -> match s with Eq e -> e::el, al | Aut a -> el, a::al) s.stmts ([], []) in
- if auts != [] then assert false; (* Automata should be expanded by now. *)
- let defsvars =
- List.fold_left (normalize_eq norm_ctx) ([], orig_vars) eqs
+ let eqs, auts =
+ List.fold_right
+ (fun s (el, al) ->
+ match s with Eq e -> e :: el, al | Aut a -> el, a :: al)
+ s.stmts ([], [])
in
+ if auts != [] then assert false;
+ (* Automata should be expanded by now. *)
+ let defsvars = List.fold_left (normalize_eq norm_ctx) ([], orig_vars) eqs in
(* Iterate through predicates and normalize them on the go, creating
fresh variables for any guarantees/assumes/require/ensure *)
let process_predicates l defvars =
(* Format.eprintf "ProcPred: vars: %a@." Printers.pp_vars (snd defvars); *)
- let res = List.fold_right (fun ee (accu, defvars) ->
- let ee', defvars = normalize_pred_eexpr norm_ctx defvars ee in
- ee'::accu, defvars
- ) l ([], defvars)
+ let res =
+ List.fold_right
+ (fun ee (accu, defvars) ->
+ let ee', defvars = normalize_pred_eexpr norm_ctx defvars ee in
+ ee' :: accu, defvars)
+ l ([], defvars)
in
(* Format.eprintf "ProcStmt: %a@." Printers.pp_node_eqs (fst (snd res));
* Format.eprintf "ProcPred: vars: %a@." Printers.pp_vars (snd (snd res)); *)
res
in
-
let assume', defsvars = process_predicates s.assume defsvars in
let guarantees', defsvars = process_predicates s.guarantees defsvars in
let modes', (defs, vars) =
- List.fold_right (
- fun m (accu_m, defsvars) ->
+ List.fold_right
+ (fun m (accu_m, defsvars) ->
let require', defsvars = process_predicates m.require defsvars in
let ensure', defsvars = process_predicates m.ensure defsvars in
- { m with require = require'; ensure = ensure' }:: accu_m, defsvars
- ) s.modes ([], defsvars)
+ { m with require = require'; ensure = ensure' } :: accu_m, defsvars)
+ s.modes ([], defsvars)
in
-
- let new_locals = List.filter not_is_orig_var vars in (* removing inouts and initial locals ones *)
- new_locals, defs,
- {s with
- (* locals = s.locals @ new_locals; *)
- stmts = [];
- assume = assume';
- guarantees = guarantees';
- modes = modes'
- }
+
+ let new_locals = List.filter not_is_orig_var vars in
+ (* removing inouts and initial locals ones *)
+ ( new_locals,
+ defs,
+ {
+ s with
+ (* locals = s.locals @ new_locals; *)
+ stmts = [];
+ assume = assume';
+ guarantees = guarantees';
+ modes = modes';
+ } )
(* let nee _ = () in
* (\*normalize_eexpr decls iovars in *\)
* List.iter nee s.assume;
@@ -646,12 +707,7 @@ let normalize_spec parentid (in_vars, out_vars, l_vars) s =
* List.iter nee m.require;
* List.iter nee m.ensure
* ) s.modes; *)
-
-
-
-
-
(* The normalization phase introduces new local variables
- output cannot be memories. If this happen, new local variables acting as
memories are introduced.
@@ -671,153 +727,173 @@ let normalize_spec parentid (in_vars, out_vars, l_vars) s =
*)
let normalize_node node =
reset_cpt_fresh ();
- let orig_vars = node.node_inputs@node.node_outputs@node.node_locals in
- let not_is_orig_var v =
- List.for_all ((!=) v) orig_vars in
- let norm_ctx = {
+ let orig_vars = node.node_inputs @ node.node_outputs @ node.node_locals in
+ let not_is_orig_var v = List.for_all (( != ) v) orig_vars in
+ let norm_ctx =
+ {
parentid = node.node_id;
vars = get_node_vars node;
- is_output = (fun vid -> List.exists (fun v -> v.var_id = vid) node.node_outputs);
+ is_output =
+ (fun vid -> List.exists (fun v -> v.var_id = vid) node.node_outputs);
}
in
let eqs, auts = get_node_eqs node in
- if auts != [] then assert false; (* Automata should be expanded by now. *)
+ if auts != [] then assert false;
+ (* Automata should be expanded by now. *)
let spec, new_vars, eqs =
- begin
- (* Update mutable fields of eexpr to perform normalization of
- specification.
-
- Careful: we do not normalize annotations, since they can have the form
- x = (a, b, c) *)
- match node.node_spec with
- | None
- | Some (NodeSpec _) -> node.node_spec, [], eqs
- | Some (Contract s) ->
- let new_locals, new_stmts, s' = normalize_spec
- node.node_id
- (node.node_inputs, node.node_outputs, node.node_locals)
- s
- in
- (* Format.eprintf "Normalization bounded new locals: %a@." Printers.pp_vars new_locals;
- * Format.eprintf "Normalization bounded stmts: %a@." Printers.pp_node_eqs new_stmts; *)
- Some (Contract s'), new_locals, new_stmts@eqs
- end
+ (* Update mutable fields of eexpr to perform normalization of
+ specification.
+
+ Careful: we do not normalize annotations, since they can have the form
+ x = (a, b, c) *)
+ match node.node_spec with
+ | None | Some (NodeSpec _) -> node.node_spec, [], eqs
+ | Some (Contract s) ->
+ let new_locals, new_stmts, s' =
+ normalize_spec node.node_id
+ (node.node_inputs, node.node_outputs, node.node_locals)
+ s
+ in
+ (* Format.eprintf "Normalization bounded new locals: %a@." Printers.pp_vars new_locals;
+ * Format.eprintf "Normalization bounded stmts: %a@." Printers.pp_node_eqs new_stmts; *)
+ Some (Contract s'), new_locals, new_stmts @ eqs
in
let defs, vars =
- List.fold_left (normalize_eq norm_ctx) ([], new_vars@orig_vars) eqs in
+ List.fold_left (normalize_eq norm_ctx) ([], new_vars @ orig_vars) eqs
+ 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 =
- normalize_expr
- ~alias:true (* forcing introduction of new equations for fcn calls *)
- norm_ctx
- [] (* empty offset for arrays *)
- ([], vars) (* defvar only contains vars *)
- assert_expr
- in
+ List.fold_left
+ (fun (vars, def_accu, assert_accu) assert_ ->
+ let assert_expr = assert_.assert_expr in
+ let (defs, vars'), expr =
+ normalize_expr ~alias:true
+ (* forcing introduction of new equations for fcn calls *)
+ norm_ctx []
+ (* empty offset for arrays *)
+ ([], vars)
+ (* defvar only contains vars *)
+ assert_expr
+ in
(*Format.eprintf "New assert vars: %a@.@?" (fprintf_list ~sep:", " Printers.pp_var) vars';*)
- vars', defs@def_accu, {assert_ with assert_expr = expr}::assert_accu
- ) (vars, [], []) node.node_asserts in
- let new_locals = List.filter not_is_orig_var vars in (* we filter out inout
- vars and initial locals ones *)
-
- let all_locals = node.node_locals @ new_locals in (* we add again, at the
- beginning of the list the
- local declared ones *)
- (*Format.eprintf "New locals: %a@.@?" (fprintf_list ~sep:", " Printers.pp_var) new_locals;*)
+ ( vars',
+ defs @ def_accu,
+ { assert_ with assert_expr = expr } :: assert_accu ))
+ (vars, [], []) node.node_asserts
+ in
+ let new_locals = List.filter not_is_orig_var vars in
+
+ (* we filter out inout
+ vars and initial locals ones *)
+ let all_locals = node.node_locals @ new_locals in
+ (* we add again, at the
+ beginning of the list the
+ local declared ones *)
+ (*Format.eprintf "New locals: %a@.@?" (fprintf_list ~sep:", " Printers.pp_var) new_locals;*)
(* Updating annotations: traceability and machine types for fresh variables *)
-
+
(* Compute traceability info:
- gather newly bound variables
- compute the associated expression without aliases
- *)
+ *)
let new_annots =
if !Options.traces then
- begin
- let diff_vars = List.filter (fun v -> not (List.mem v node.node_locals) ) all_locals in
- let norm_traceability = {
- annots = List.map (fun v ->
- let eq =
- try
- List.find (fun eq -> List.exists (fun v' -> v' = v.var_id ) eq.eq_lhs) (defs@assert_defs)
- with Not_found ->
- (
- Format.eprintf "Traceability annotation generation: var %s not found@." v.var_id;
- assert false
- )
- in
- let expr = substitute_expr diff_vars (defs@assert_defs) eq.eq_rhs in
- let pair = mkeexpr expr.expr_loc (mkexpr expr.expr_loc (Expr_tuple [expr_of_ident v.var_id expr.expr_loc; expr])) in
- Annotations.add_expr_ann node.node_id pair.eexpr_tag ["traceability"];
- (["traceability"], pair)
- ) diff_vars;
- annot_loc = Location.dummy_loc
- }
- in
- norm_traceability::node.node_annot
- end
- else
- node.node_annot
+ let diff_vars =
+ List.filter (fun v -> not (List.mem v node.node_locals)) all_locals
+ in
+ let norm_traceability =
+ {
+ annots =
+ List.map
+ (fun v ->
+ let eq =
+ try
+ List.find
+ (fun eq ->
+ List.exists (fun v' -> v' = v.var_id) eq.eq_lhs)
+ (defs @ assert_defs)
+ with Not_found ->
+ Format.eprintf
+ "Traceability annotation generation: var %s not found@."
+ v.var_id;
+ assert false
+ in
+ let expr =
+ substitute_expr diff_vars (defs @ assert_defs) eq.eq_rhs
+ in
+ let pair =
+ mkeexpr expr.expr_loc
+ (mkexpr expr.expr_loc
+ (Expr_tuple
+ [ expr_of_ident v.var_id expr.expr_loc; expr ]))
+ in
+ Annotations.add_expr_ann node.node_id pair.eexpr_tag
+ [ "traceability" ];
+ [ "traceability" ], pair)
+ diff_vars;
+ annot_loc = Location.dummy_loc;
+ }
+ in
+ norm_traceability :: node.node_annot
+ else node.node_annot
in
let new_annots =
- List.fold_left (fun annots v ->
- if Machine_types.is_active && Machine_types.is_exportable v then
- let typ = Machine_types.get_specified_type v in
- let typ_name = Machine_types.type_name typ in
-
- let loc = v.var_loc in
- let typ_as_string =
- mkexpr
- loc
- (Expr_const
- (Const_string typ_name))
- in
- let pair = expr_to_eexpr (expr_of_expr_list loc [expr_of_vdecl v; typ_as_string]) in
- Annotations.add_expr_ann node.node_id pair.eexpr_tag Machine_types.keyword;
- {annots = [Machine_types.keyword, pair]; annot_loc = loc}::annots
- else
- annots
- ) new_annots new_locals
+ List.fold_left
+ (fun annots v ->
+ if Machine_types.is_active && Machine_types.is_exportable v then (
+ let typ = Machine_types.get_specified_type v in
+ let typ_name = Machine_types.type_name typ in
+
+ let loc = v.var_loc in
+ let typ_as_string = mkexpr loc (Expr_const (Const_string typ_name)) in
+ let pair =
+ expr_to_eexpr
+ (expr_of_expr_list loc [ expr_of_vdecl v; typ_as_string ])
+ in
+ Annotations.add_expr_ann node.node_id pair.eexpr_tag
+ Machine_types.keyword;
+ { annots = [ Machine_types.keyword, pair ]; annot_loc = loc }
+ :: annots)
+ else annots)
+ new_annots new_locals
in
-
-
+
let node =
- { node with
+ {
+ node with
node_locals = all_locals;
node_stmts = List.map (fun eq -> Eq eq) (defs @ assert_defs);
node_asserts = asserts;
node_annot = new_annots;
node_spec = spec;
}
- in ((*Printers.pp_node Format.err_formatter node;*)
- node
- )
+ in
+ (*Printers.pp_node Format.err_formatter node;*)
+ node
let normalize_inode nd =
reset_cpt_fresh ();
match nd.nodei_spec with
- None | Some (NodeSpec _) -> nd
- | Some (Contract _) -> assert false
-
-let normalize_decl (decl: top_decl) : top_decl =
+ | None | Some (NodeSpec _) -> nd
+ | Some (Contract _) -> assert false
+
+let normalize_decl (decl : top_decl) : top_decl =
match decl.top_decl_desc with
| Node nd ->
- let decl' = {decl with top_decl_desc = Node (normalize_node nd)} in
- update_node nd.node_id decl';
- decl'
+ let decl' = { decl with top_decl_desc = Node (normalize_node nd) } in
+ update_node nd.node_id decl';
+ decl'
| ImportedNode nd ->
- let decl' = {decl with top_decl_desc = ImportedNode (normalize_inode nd)} in
- update_node nd.nodei_id decl';
- decl'
-
- | Include _| Open _ | Const _ | TypeDef _ -> decl
+ let decl' =
+ { decl with top_decl_desc = ImportedNode (normalize_inode nd) }
+ in
+ update_node nd.nodei_id decl';
+ decl'
+ | Include _ | Open _ | Const _ | TypeDef _ -> decl
let normalize_prog p decls =
(* Backend specific configurations for normalization *)
@@ -826,17 +902,12 @@ let normalize_prog p decls =
(* Main algorithm: iterates over nodes *)
List.map normalize_decl decls
-
(* Fake interface for outside uses *)
let mk_expr_alias_opt opt (parentid, ctx_vars) (defs, vars) expr =
- mk_expr_alias_opt
- opt
- {parentid = parentid; vars = ctx_vars; is_output = (fun _ -> false) }
- (defs, vars)
- expr
+ mk_expr_alias_opt opt
+ { parentid; vars = ctx_vars; is_output = (fun _ -> false) }
+ (defs, vars) expr
-
- (* Local Variables: *)
- (* compile-command:"make -C .." *)
- (* End: *)
-
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
diff --git a/src/normalization.mli b/src/normalization.mli
index 10e8376dbbcf7b856b26d9bf0447ef66945e4ea4..51027651429e2478f4ba7822ebdad438e463d7df 100644
--- a/src/normalization.mli
+++ b/src/normalization.mli
@@ -1,12 +1,16 @@
open Lustre_types
-type param_t =
- {
- unfold_arrow_active: bool;
- force_alias_ite: bool;
- force_alias_internal_fun: bool;
- }
+type param_t = {
+ unfold_arrow_active : bool;
+ force_alias_ite : bool;
+ force_alias_internal_fun : bool;
+}
+val mk_expr_alias_opt :
+ bool ->
+ ident * var_decl list ->
+ eq list * var_decl list ->
+ expr ->
+ (eq list * var_decl list) * expr
-val mk_expr_alias_opt: bool -> (ident * var_decl list) -> (eq list * var_decl list)-> expr -> (eq list * var_decl list) * expr
-val normalize_prog: param_t -> program_t -> program_t
+val normalize_prog : param_t -> program_t -> program_t
diff --git a/src/optimize_machine.ml b/src/optimize_machine.ml
index 49952f6556dcfd49d6f2a0d1f58fa144642391b4..5de389e9035e9e36d09f3214d838ef5df17dff38 100644
--- a/src/optimize_machine.ml
+++ b/src/optimize_machine.ml
@@ -10,7 +10,7 @@
(********************************************************************)
open Utils
-open Lustre_types
+open Lustre_types
open Machine_code_types
open Corelang
open Causality
@@ -18,761 +18,891 @@ open Machine_code_common
open Dimension
module Mpfr = Lustrec_mpfr
-
let pp_elim m fmt elim =
pp_imap ~comment:"/* elim table: */" (pp_val m) fmt elim
- (* Format.fprintf fmt "@[<hv 0>@[<hv 2>{ /* elim table: */";
- * IMap.iter (fun v expr -> Format.fprintf fmt "@ %s |-> %a," v (pp_val m) expr) elim;
- * Format.fprintf fmt "@]@ }@]" *)
+(* Format.fprintf fmt "@[<hv 0>@[<hv 2>{ /* elim table: */";
+ * IMap.iter (fun v expr -> Format.fprintf fmt "@ %s |-> %a," v (pp_val m) expr) elim;
+ * Format.fprintf fmt "@]@ }@]" *)
let rec eliminate m elim instr =
let e_expr = eliminate_expr m elim in
match get_instr_desc instr with
- | MLocalAssign (i,v) -> update_instr_desc instr (MLocalAssign (i, e_expr v))
- | MStateAssign (i,v) -> update_instr_desc instr (MStateAssign (i, e_expr v))
+ | MLocalAssign (i, v) ->
+ update_instr_desc instr (MLocalAssign (i, e_expr v))
+ | MStateAssign (i, v) ->
+ update_instr_desc instr (MStateAssign (i, e_expr v))
| MSetReset _
| MNoReset _
| MClearReset
| MResetAssign _
| MSpec _
- | MComment _ -> instr
- | MStep (il, i, vl) -> update_instr_desc instr (MStep(il, i, List.map e_expr vl))
- | MBranch (g,hl) ->
- update_instr_desc instr (
- MBranch
- (e_expr g,
- (List.map
- (fun (l, il) -> l, List.map (eliminate m elim) il)
- hl
- )
- )
- )
-
+ | MComment _ ->
+ instr
+ | MStep (il, i, vl) ->
+ update_instr_desc instr (MStep (il, i, List.map e_expr vl))
+ | MBranch (g, hl) ->
+ update_instr_desc instr
+ (MBranch
+ ( e_expr g,
+ List.map (fun (l, il) -> l, List.map (eliminate m elim) il) hl ))
+
and eliminate_expr m elim expr =
let eliminate_expr = eliminate_expr m in
match expr.value_desc with
- | Var v -> if is_memory m v then
- expr
- else
- (try IMap.find v.var_id elim with Not_found -> expr)
- | Fun (id, vl) -> {expr with value_desc = Fun (id, List.map (eliminate_expr elim) vl)}
- | Array(vl) -> {expr with value_desc = Array(List.map (eliminate_expr elim) vl)}
- | Access(v1, v2) -> { expr with value_desc = Access(eliminate_expr elim v1, eliminate_expr elim v2)}
- | Power(v1, v2) -> { expr with value_desc = Power(eliminate_expr elim v1, eliminate_expr elim v2)}
- | Cst _ | ResetFlag -> expr
+ | Var v -> (
+ if is_memory m v then expr
+ else try IMap.find v.var_id elim with Not_found -> expr)
+ | Fun (id, vl) ->
+ { expr with value_desc = Fun (id, List.map (eliminate_expr elim) vl) }
+ | Array vl ->
+ { expr with value_desc = Array (List.map (eliminate_expr elim) vl) }
+ | Access (v1, v2) ->
+ {
+ expr with
+ value_desc = Access (eliminate_expr elim v1, eliminate_expr elim v2);
+ }
+ | Power (v1, v2) ->
+ {
+ expr with
+ value_desc = Power (eliminate_expr elim v1, eliminate_expr elim v2);
+ }
+ | Cst _ | ResetFlag ->
+ expr
let eliminate_dim elim dim =
- Dimension.expr_replace_expr
- (fun v -> try
- dimension_of_value (IMap.find v elim)
- with Not_found -> mkdim_ident dim.dim_loc v)
+ Dimension.expr_replace_expr
+ (fun v ->
+ try dimension_of_value (IMap.find v elim)
+ with Not_found -> mkdim_ident dim.dim_loc v)
dim
-
(* 8th Jan 2016: issues when merging salsa with horn_encoding: The following
- functions seem unsused. They have to be adapted to the new type for expr
-*)
+ functions seem unsused. They have to be adapted to the new type for expr *)
let unfold_expr_offset m offset expr =
List.fold_left
(fun res -> function
- | Index i ->
- mk_val (Access (res, value_of_dimension m i))
- (Types.array_element_type res.value_type)
- | Field _ ->
- Format.eprintf "internal error: not yet implemented !";
- assert false)
+ | Index i ->
+ mk_val
+ (Access (res, value_of_dimension m i))
+ (Types.array_element_type res.value_type)
+ | Field _ ->
+ Format.eprintf "internal error: not yet implemented !";
+ assert false)
expr offset
let rec simplify_cst_expr m offset typ cst =
- match offset, cst with
- | [] , _
- -> mk_val (Cst cst) typ
- | Index i :: q, Const_array cl when Dimension.is_dimension_const i
- -> let elt_typ = Types.array_element_type typ in
- simplify_cst_expr m q elt_typ (List.nth cl (Dimension.size_const_dimension i))
- | Index i :: q, Const_array cl
- -> let elt_typ = Types.array_element_type typ in
- unfold_expr_offset m [Index i] (mk_val (Array (List.map (simplify_cst_expr m q elt_typ) cl)) typ)
- | Field f :: q, Const_struct fl
- -> let fld_typ = Types.struct_field_type typ f in
- simplify_cst_expr m q fld_typ (List.assoc f fl)
- | _ -> (Format.eprintf "internal error: Optimize_machine.simplify_cst_expr %a@." Printers.pp_const cst; assert false)
+ match offset, cst with
+ | [], _ ->
+ mk_val (Cst cst) typ
+ | Index i :: q, Const_array cl when Dimension.is_dimension_const i ->
+ let elt_typ = Types.array_element_type typ in
+ simplify_cst_expr m q elt_typ
+ (List.nth cl (Dimension.size_const_dimension i))
+ | Index i :: q, Const_array cl ->
+ let elt_typ = Types.array_element_type typ in
+ unfold_expr_offset m [ Index i ]
+ (mk_val (Array (List.map (simplify_cst_expr m q elt_typ) cl)) typ)
+ | Field f :: q, Const_struct fl ->
+ let fld_typ = Types.struct_field_type typ f in
+ simplify_cst_expr m q fld_typ (List.assoc f fl)
+ | _ ->
+ Format.eprintf "internal error: Optimize_machine.simplify_cst_expr %a@."
+ Printers.pp_const cst;
+ assert false
let simplify_expr_offset m expr =
let rec simplify offset expr =
match offset, expr.value_desc with
- | Field _ ::_ , _ -> failwith "not yet implemented"
- | _ , Fun (id, vl) when Basic_library.is_value_internal_fun expr
- -> mk_val (Fun (id, List.map (simplify offset) vl)) expr.value_type
- | _ , Fun _
- | _ , Var _ -> unfold_expr_offset m offset expr
- | _ , Cst cst -> simplify_cst_expr m offset expr.value_type cst
- | _ , Access (expr, i) -> simplify (Index (dimension_of_value i) :: offset) expr
- | _ , ResetFlag -> expr
- | [] , _ -> expr
- | Index _ :: q, Power (expr, _) -> simplify q expr
- | Index i :: q, Array vl when Dimension.is_dimension_const i
- -> simplify q (List.nth vl (Dimension.size_const_dimension i))
- | Index i :: q, Array vl -> unfold_expr_offset m [Index i] (mk_val (Array (List.map (simplify q) vl)) expr.value_type)
- (*Format.eprintf "simplify_expr %a %a = %a@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset pp_val res; res)
- with e -> (Format.eprintf "simplify_expr %a %a = <FAIL>@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset; raise e*)
- in simplify [] expr
+ | Field _ :: _, _ ->
+ failwith "not yet implemented"
+ | _, Fun (id, vl) when Basic_library.is_value_internal_fun expr ->
+ mk_val (Fun (id, List.map (simplify offset) vl)) expr.value_type
+ | _, Fun _ | _, Var _ ->
+ unfold_expr_offset m offset expr
+ | _, Cst cst ->
+ simplify_cst_expr m offset expr.value_type cst
+ | _, Access (expr, i) ->
+ simplify (Index (dimension_of_value i) :: offset) expr
+ | _, ResetFlag ->
+ expr
+ | [], _ ->
+ expr
+ | Index _ :: q, Power (expr, _) ->
+ simplify q expr
+ | Index i :: q, Array vl when Dimension.is_dimension_const i ->
+ simplify q (List.nth vl (Dimension.size_const_dimension i))
+ | Index i :: q, Array vl ->
+ unfold_expr_offset m [ Index i ]
+ (mk_val (Array (List.map (simplify q) vl)) expr.value_type)
+ (*Format.eprintf "simplify_expr %a %a = %a@." pp_val expr
+ (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset pp_val res; res)
+ with e -> (Format.eprintf "simplify_expr %a %a = <FAIL>@." pp_val expr
+ (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset; raise e*)
+ in
+ simplify [] expr
let rec simplify_instr_offset m instr =
match get_instr_desc instr with
- | MLocalAssign (v, expr) -> update_instr_desc instr (MLocalAssign (v, simplify_expr_offset m expr))
- | MStateAssign (v, expr) -> update_instr_desc instr (MStateAssign (v, simplify_expr_offset m expr))
+ | MLocalAssign (v, expr) ->
+ update_instr_desc instr (MLocalAssign (v, simplify_expr_offset m expr))
+ | MStateAssign (v, expr) ->
+ update_instr_desc instr (MStateAssign (v, simplify_expr_offset m expr))
| MSetReset _
| MNoReset _
| MClearReset
| MResetAssign _
| MSpec _
- | MComment _ -> instr
- | MStep (outputs, id, inputs) -> update_instr_desc instr (MStep (outputs, id, List.map (simplify_expr_offset m) inputs))
- | MBranch (cond, brl)
- -> update_instr_desc instr (
- MBranch(simplify_expr_offset m cond, List.map (fun (l, il) -> l, simplify_instrs_offset m il) brl)
- )
-
-and simplify_instrs_offset m instrs =
- List.map (simplify_instr_offset m) instrs
+ | MComment _ ->
+ instr
+ | MStep (outputs, id, inputs) ->
+ update_instr_desc instr
+ (MStep (outputs, id, List.map (simplify_expr_offset m) inputs))
+ | MBranch (cond, brl) ->
+ update_instr_desc instr
+ (MBranch
+ ( simplify_expr_offset m cond,
+ List.map (fun (l, il) -> l, simplify_instrs_offset m il) brl ))
+
+and simplify_instrs_offset m instrs = List.map (simplify_instr_offset m) instrs
let is_scalar_const c =
- match c with
- | Const_real _
- | Const_int _
- | Const_tag _ -> true
- | _ -> false
-
-(* An instruction v = expr may (and will) be unfolded iff:
- - either expr is atomic
- (no complex expressions, only const, vars and array/struct accesses)
- - or v has a fanin <= 1 (used at most once)
-*)
+ match c with Const_real _ | Const_int _ | Const_tag _ -> true | _ -> false
+
+(* An instruction v = expr may (and will) be unfolded iff: - either expr is
+ atomic (no complex expressions, only const, vars and array/struct accesses) -
+ or v has a fanin <= 1 (used at most once) *)
let is_unfoldable_expr fanin expr =
let rec unfold_const offset cst =
match offset, cst with
- | _ , Const_int _
- | _ , Const_real _
- | _ , Const_tag _ -> true
- | Field f :: q, Const_struct fl -> unfold_const q (List.assoc f fl)
- | [] , Const_struct _ -> false
- | Index i :: q, Const_array cl when Dimension.is_dimension_const i
- -> unfold_const q (List.nth cl (Dimension.size_const_dimension i))
- | _ , Const_array _ -> false
- | _ -> assert false in
+ | _, Const_int _ | _, Const_real _ | _, Const_tag _ ->
+ true
+ | Field f :: q, Const_struct fl ->
+ unfold_const q (List.assoc f fl)
+ | [], Const_struct _ ->
+ false
+ | Index i :: q, Const_array cl when Dimension.is_dimension_const i ->
+ unfold_const q (List.nth cl (Dimension.size_const_dimension i))
+ | _, Const_array _ ->
+ false
+ | _ ->
+ assert false
+ in
let rec unfold offset expr =
match offset, expr.value_desc with
- | _ , Cst cst -> unfold_const offset cst
- | _ , Var _ -> true
- | [] , Power _
- | [] , Array _ -> false
- | Index _ :: q, Power (v, _) -> unfold q v
- | Index i :: q, Array vl when Dimension.is_dimension_const i
- -> unfold q (List.nth vl (Dimension.size_const_dimension i))
- | _ , Array _ -> false
- | _ , Access (v, i) -> unfold (Index (dimension_of_value i) :: offset) v
- | _ , Fun (_, vl) when fanin < 2 && Basic_library.is_value_internal_fun expr
- -> List.for_all (unfold offset) vl
- | _ , Fun _ -> false
- | _ -> assert false
- in unfold [] expr
+ | _, Cst cst ->
+ unfold_const offset cst
+ | _, Var _ ->
+ true
+ | [], Power _ | [], Array _ ->
+ false
+ | Index _ :: q, Power (v, _) ->
+ unfold q v
+ | Index i :: q, Array vl when Dimension.is_dimension_const i ->
+ unfold q (List.nth vl (Dimension.size_const_dimension i))
+ | _, Array _ ->
+ false
+ | _, Access (v, i) ->
+ unfold (Index (dimension_of_value i) :: offset) v
+ | _, Fun (_, vl) when fanin < 2 && Basic_library.is_value_internal_fun expr
+ ->
+ List.for_all (unfold offset) vl
+ | _, Fun _ ->
+ false
+ | _ ->
+ assert false
+ in
+ unfold [] expr
let basic_unfoldable_assign fanin v expr =
try
- let d = Hashtbl.find fanin v.var_id
- in is_unfoldable_expr d expr
+ let d = Hashtbl.find fanin v.var_id in
+ is_unfoldable_expr d expr
with Not_found -> false
let unfoldable_assign fanin v expr =
- (if !Options.mpfr then Mpfr.unfoldable_value expr else true)
-&& basic_unfoldable_assign fanin v expr
+ (if !Options.mpfr then Mpfr.unfoldable_value expr else true)
+ && basic_unfoldable_assign fanin v expr
let merge_elim elim1 elim2 =
let merge _ e1 e2 =
match e1, e2 with
- | Some e1, Some e2 -> if e1 = e2 then Some e1 else None
- | _ , Some e2 -> Some e2
- | Some e1, _ -> Some e1
- | _ -> None
- in IMap.merge merge elim1 elim2
-
-(* see if elim has to take in account the provided instr:
- if so, update elim and return the remove flag,
- otherwise, the expression should be kept and elim is left untouched *)
+ | Some e1, Some e2 ->
+ if e1 = e2 then Some e1 else None
+ | _, Some e2 ->
+ Some e2
+ | Some e1, _ ->
+ Some e1
+ | _ ->
+ None
+ in
+ IMap.merge merge elim1 elim2
+
+(* see if elim has to take in account the provided instr: if so, update elim and
+ return the remove flag, otherwise, the expression should be kept and elim is
+ left untouched *)
let rec instrs_unfold m fanin elim instrs =
- let elim, rev_instrs =
- List.fold_left (fun (elim, instrs) instr ->
- (* each subexpression in instr that could be rewritten by the elim set is
- rewritten *)
- let instr = eliminate m (IMap.map fst elim) instr in
- (* if instr is a simple local assign, then (a) elim is simplified with it (b) it
- is stored as the elim set *)
- instr_unfold m fanin instrs elim instr
- ) (elim, []) instrs
- in elim, List.rev rev_instrs
-
-and instr_unfold m fanin instrs (elim:(value_t * eq) IMap.t) instr =
-(* Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*)
+ let elim, rev_instrs =
+ List.fold_left
+ (fun (elim, instrs) instr ->
+ (* each subexpression in instr that could be rewritten by the elim set
+ is rewritten *)
+ let instr = eliminate m (IMap.map fst elim) instr in
+ (* if instr is a simple local assign, then (a) elim is simplified with
+ it (b) it is stored as the elim set *)
+ instr_unfold m fanin instrs elim instr)
+ (elim, []) instrs
+ in
+ elim, List.rev rev_instrs
+
+and instr_unfold m fanin instrs (elim : (value_t * eq) IMap.t) instr =
+ (* Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE
+ IT@." pp_instr instr;*)
match get_instr_desc instr with
(* Simple cases*)
- | MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type)
- -> instr_unfold m fanin instrs elim (update_instr_desc instr (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type)))
- | MLocalAssign(v, expr) when not (is_clock_dec_type v.var_dec_type.ty_dec_desc) && unfoldable_assign fanin v expr
- -> (* we don't eliminate clock definitions *)
- let new_eq =
- Corelang.mkeq
- (desome instr.lustre_eq).eq_loc
- ([v.var_id], (desome instr.lustre_eq).eq_rhs)
- in
- (IMap.add v.var_id (expr, new_eq ) elim, instrs)
- | MBranch(g, hl) when false
- -> let elim_branches = List.map (fun (h, l) -> (h, instrs_unfold m fanin elim l)) hl in
- let (elim, branches) =
- List.fold_right
- (fun (h, (e, l)) (elim, branches) -> (merge_elim elim e, (h, l)::branches))
- elim_branches (elim, [])
- in elim, ((update_instr_desc instr (MBranch (g, branches))) :: instrs)
- | _
- -> (elim, instr :: instrs)
- (* default case, we keep the instruction and do not modify elim *)
-
-
-(** We iterate in the order, recording simple local assigns in an accumulator
- 1. each expression is rewritten according to the accumulator
- 2. local assigns then rewrite occurrences of the lhs in the computed accumulator
-*)
+ | MStep ([ v ], id, vl)
+ when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type)
+ ->
+ instr_unfold m fanin instrs elim
+ (update_instr_desc instr
+ (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type)))
+ | MLocalAssign (v, expr)
+ when (not (is_clock_dec_type v.var_dec_type.ty_dec_desc))
+ && unfoldable_assign fanin v expr ->
+ (* we don't eliminate clock definitions *)
+ let new_eq =
+ Corelang.mkeq (desome instr.lustre_eq).eq_loc
+ ([ v.var_id ], (desome instr.lustre_eq).eq_rhs)
+ in
+ IMap.add v.var_id (expr, new_eq) elim, instrs
+ | MBranch (g, hl) when false ->
+ let elim_branches =
+ List.map (fun (h, l) -> h, instrs_unfold m fanin elim l) hl
+ in
+ let elim, branches =
+ List.fold_right
+ (fun (h, (e, l)) (elim, branches) ->
+ merge_elim elim e, (h, l) :: branches)
+ elim_branches (elim, [])
+ in
+ elim, update_instr_desc instr (MBranch (g, branches)) :: instrs
+ | _ ->
+ elim, instr :: instrs
+(* default case, we keep the instruction and do not modify elim *)
+
+(** We iterate in the order, recording simple local assigns in an accumulator 1.
+ each expression is rewritten according to the accumulator 2. local assigns
+ then rewrite occurrences of the lhs in the computed accumulator *)
let static_call_unfold elim (inst, (n, args)) =
let replace v =
- try
- dimension_of_value (IMap.find v elim)
+ try dimension_of_value (IMap.find v elim)
with Not_found -> Dimension.mkdim_ident Location.dummy_loc v
- in (inst, (n, List.map (Dimension.expr_replace_expr replace) args))
+ in
+ inst, (n, List.map (Dimension.expr_replace_expr replace) args)
-(** Perform optimization on machine code:
- - iterate through step instructions and remove simple local assigns
-
-*)
+(** Perform optimization on machine code: - iterate through step instructions
+ and remove simple local assigns *)
let machine_unfold fanin elim machine =
- Log.report ~level:3 (fun fmt -> Format.fprintf fmt "machine_unfold %s %a@ "
- machine.mname.node_id (pp_elim machine) (IMap.map fst elim));
+ Log.report ~level:3 (fun fmt ->
+ Format.fprintf fmt "machine_unfold %s %a@ " machine.mname.node_id
+ (pp_elim machine) (IMap.map fst elim));
let elim_consts, mconst = instrs_unfold machine fanin elim machine.mconst in
- let elim_vars, instrs = instrs_unfold machine fanin elim_consts machine.mstep.step_instrs in
+ let elim_vars, instrs =
+ instrs_unfold machine fanin elim_consts machine.mstep.step_instrs
+ in
let instrs = simplify_instrs_offset machine instrs in
- let checks = List.map
- (fun (loc, check) ->
- loc,
- eliminate_expr machine (IMap.map fst elim_vars) check
- ) machine.mstep.step_checks
+ let checks =
+ List.map
+ (fun (loc, check) ->
+ loc, eliminate_expr machine (IMap.map fst elim_vars) check)
+ machine.mstep.step_checks
+ in
+ let locals =
+ List.filter
+ (fun v -> not (IMap.mem v.var_id elim_vars))
+ machine.mstep.step_locals
in
- let locals = List.filter (fun v -> not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in
let elim_consts = IMap.map fst elim_consts in
- let minstances = List.map (static_call_unfold elim_consts) machine.minstances in
- let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls
+ let minstances =
+ List.map (static_call_unfold elim_consts) machine.minstances
in
- {
- machine with
- mstep = {
- machine.mstep with
- step_locals = locals;
- step_instrs = instrs;
- step_checks = checks
- };
- mconst = mconst;
- minstances = minstances;
- mcalls = mcalls;
- },
- elim_vars
+ let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls in
+ ( {
+ machine with
+ mstep =
+ {
+ machine.mstep with
+ step_locals = locals;
+ step_instrs = instrs;
+ step_checks = checks;
+ };
+ mconst;
+ minstances;
+ mcalls;
+ },
+ elim_vars )
let instr_of_const top_const =
let const = const_of_top top_const in
let loc = const.const_loc in
let id = const.const_id in
- let vdecl = mkvar_decl loc (id, mktyp Location.dummy_loc Tydec_any, mkclock loc Ckdec_any, true, None, None) in
+ let vdecl =
+ mkvar_decl loc
+ ( id,
+ mktyp Location.dummy_loc Tydec_any,
+ mkclock loc Ckdec_any,
+ true,
+ None,
+ None )
+ in
let vdecl = { vdecl with var_type = const.const_type } in
- let lustre_eq = mkeq loc ([const.const_id], mkexpr loc (Expr_const const.const_value)) in
- mkinstr
- ~lustre_eq
+ let lustre_eq =
+ mkeq loc ([ const.const_id ], mkexpr loc (Expr_const const.const_value))
+ in
+ mkinstr ~lustre_eq
(MLocalAssign (vdecl, mk_val (Cst const.const_value) vdecl.var_type))
-(* We do not perform this optimization on contract nodes since there
- is not explicit dependence btw variables and their use in
- contracts. *)
+(* We do not perform this optimization on contract nodes since there is not
+ explicit dependence btw variables and their use in contracts. *)
let machines_unfold consts node_schs machines =
- List.fold_right (fun m (machines, removed) ->
- let is_contract = match m.mspec.mnode_spec with
- | Some (Contract _) -> true
- | _ -> false in
- if is_contract then
- m :: machines, removed
- else
- let fanin = (IMap.find m.mname.node_id node_schs).Scheduling_type.fanin_table in
- let elim_consts, _ = instrs_unfold m fanin IMap.empty (List.map instr_of_const consts) in
- let (m, removed_m) = machine_unfold fanin elim_consts m in
- (m::machines, IMap.add m.mname.node_id removed_m removed)
- )
- machines
- ([], IMap.empty)
+ List.fold_right
+ (fun m (machines, removed) ->
+ let is_contract =
+ match m.mspec.mnode_spec with Some (Contract _) -> true | _ -> false
+ in
+ if is_contract then m :: machines, removed
+ else
+ let fanin =
+ (IMap.find m.mname.node_id node_schs).Scheduling_type.fanin_table
+ in
+ let elim_consts, _ =
+ instrs_unfold m fanin IMap.empty (List.map instr_of_const consts)
+ in
+ let m, removed_m = machine_unfold fanin elim_consts m in
+ m :: machines, IMap.add m.mname.node_id removed_m removed)
+ machines ([], IMap.empty)
let get_assign_lhs instr =
match get_instr_desc instr with
- | MLocalAssign(v, e) -> mk_val (Var v) e.value_type
- | MStateAssign(v, e) -> mk_val (Var v) e.value_type
- | _ -> assert false
+ | MLocalAssign (v, e) ->
+ mk_val (Var v) e.value_type
+ | MStateAssign (v, e) ->
+ mk_val (Var v) e.value_type
+ | _ ->
+ assert false
let get_assign_rhs instr =
match get_instr_desc instr with
- | MLocalAssign(_, e)
- | MStateAssign(_, e) -> e
- | _ -> assert false
+ | MLocalAssign (_, e) | MStateAssign (_, e) ->
+ e
+ | _ ->
+ assert false
let is_assign instr =
match get_instr_desc instr with
- | MLocalAssign _
- | MStateAssign _ -> true
- | _ -> false
+ | MLocalAssign _ | MStateAssign _ ->
+ true
+ | _ ->
+ false
let mk_assign m v e =
- match v.value_desc with
- | Var v -> if is_memory m v then MStateAssign(v, e) else MLocalAssign(v, e)
- | _ -> assert false
+ match v.value_desc with
+ | Var v ->
+ if is_memory m v then MStateAssign (v, e) else MLocalAssign (v, e)
+ | _ ->
+ assert false
let rec assigns_instr instr assign =
- match get_instr_desc instr with
- | MLocalAssign (i,_)
- | MStateAssign (i,_) -> VSet.add i assign
- | MStep (ol, _, _) -> List.fold_right VSet.add ol assign
- | MBranch (_,hl) -> List.fold_right (fun (_, il) -> assigns_instrs il) hl assign
- | _ -> assign
+ match get_instr_desc instr with
+ | MLocalAssign (i, _) | MStateAssign (i, _) ->
+ VSet.add i assign
+ | MStep (ol, _, _) ->
+ List.fold_right VSet.add ol assign
+ | MBranch (_, hl) ->
+ List.fold_right (fun (_, il) -> assigns_instrs il) hl assign
+ | _ ->
+ assign
and assigns_instrs instrs assign =
List.fold_left (fun assign instr -> assigns_instr instr assign) assign instrs
-(*
-and substitute_expr subst expr =
- match expr with
- | Var v -> (try IMap.find expr subst with Not_found -> expr)
- | Fun (id, vl) -> Fun (id, List.map (substitute_expr subst) vl)
- | Array(vl) -> Array(List.map (substitute_expr subst) vl)
- | Access(v1, v2) -> Access(substitute_expr subst v1, substitute_expr subst v2)
- | Power(v1, v2) -> Power(substitute_expr subst v1, substitute_expr subst v2)
- | Cst _ -> expr
-*)
-(** Finds a substitute for [instr] in [instrs],
- i.e. another instr' with the same rhs expression.
- Then substitute this expression with the first assigned var
-*)
+(* and substitute_expr subst expr = match expr with | Var v -> (try IMap.find
+ expr subst with Not_found -> expr) | Fun (id, vl) -> Fun (id, List.map
+ (substitute_expr subst) vl) | Array(vl) -> Array(List.map (substitute_expr
+ subst) vl) | Access(v1, v2) -> Access(substitute_expr subst v1,
+ substitute_expr subst v2) | Power(v1, v2) -> Power(substitute_expr subst v1,
+ substitute_expr subst v2) | Cst _ -> expr *)
+
+(** Finds a substitute for [instr] in [instrs], i.e. another instr' with the
+ same rhs expression. Then substitute this expression with the first assigned
+ var *)
let subst_instr m subst instrs instr =
(* Format.eprintf "subst instr: %a@." (pp_instr m) instr; *)
let instr = eliminate m subst instr in
- let instr_v = get_assign_lhs instr in
+ let instr_v = get_assign_lhs instr in
let instr_e = get_assign_rhs instr in
try
(* Searching for equivalent asssign *)
- let instr' = List.find (fun instr' -> is_assign instr' &&
- get_assign_rhs instr' = instr_e) instrs in
+ let instr' =
+ List.find
+ (fun instr' -> is_assign instr' && get_assign_rhs instr' = instr_e)
+ instrs
+ in
(* Registering the instr_v as instr'_v while replacing *)
match instr_v.value_desc with
- | Var v ->
- let instr'_v = get_assign_lhs instr' in
- if not (is_memory m v) then
- (* The current instruction defines a local variables, ie not
- memory, we can just record the relationship and continue
- *)
- IMap.add v.var_id instr'_v subst, instrs
- else (
- (* The current instruction defines a memory. We need to keep
- the definition, simplified *)
- (match instr'_v.value_desc with
- | Var v' ->
- if not (is_memory m v') then
- (* We define v' = v. Don't need to update the records. *)
- let instr = eliminate m subst (update_instr_desc instr (mk_assign m instr_v instr'_v)) in
- subst, instr :: instrs
- else ( (* Last case, v', the lhs of the previous similar
- definition is, itself, a memory *)
-
- (* TODO regarder avec X. Il me semble qu'on peut faire plus simple: *)
- (* Filtering out the list of instructions:
- - we copy in the same order the list of instr in instrs (fold_right)
- - if the current instr is this instr' then apply
- the elimination with v' -> v on instr' before recording it as an instruction.
- *)
- let subst_v' = IMap.add v'.var_id instr_v IMap.empty in
- let instrs' =
- snd
- (List.fold_right
- (fun instr (ok, instrs) ->
- (ok || instr = instr',
- if ok then
- instr :: instrs
- else
- if instr = instr' then
- instrs
- else
- eliminate m subst_v' instr :: instrs))
- instrs (false, []))
- in
- IMap.add v'.var_id instr_v subst, instr :: instrs'
- )
- | _ -> assert false)
- )
- | _ -> assert false
-
+ | Var v -> (
+ let instr'_v = get_assign_lhs instr' in
+ if not (is_memory m v) then
+ (* The current instruction defines a local variables, ie not memory, we
+ can just record the relationship and continue *)
+ IMap.add v.var_id instr'_v subst, instrs
+ else
+ (* The current instruction defines a memory. We need to keep the
+ definition, simplified *)
+ match instr'_v.value_desc with
+ | Var v' ->
+ if not (is_memory m v') then
+ (* We define v' = v. Don't need to update the records. *)
+ let instr =
+ eliminate m subst
+ (update_instr_desc instr (mk_assign m instr_v instr'_v))
+ in
+ subst, instr :: instrs
+ else
+ (* Last case, v', the lhs of the previous similar definition is,
+ itself, a memory *)
+
+ (* TODO regarder avec X. Il me semble qu'on peut faire plus simple: *)
+ (* Filtering out the list of instructions: - we copy in the same
+ order the list of instr in instrs (fold_right) - if the current
+ instr is this instr' then apply the elimination with v' -> v on
+ instr' before recording it as an instruction. *)
+ let subst_v' = IMap.add v'.var_id instr_v IMap.empty in
+ let instrs' =
+ snd
+ (List.fold_right
+ (fun instr (ok, instrs) ->
+ ( ok || instr = instr',
+ if ok then instr :: instrs
+ else if instr = instr' then instrs
+ else eliminate m subst_v' instr :: instrs ))
+ instrs (false, []))
+ in
+ IMap.add v'.var_id instr_v subst, instr :: instrs'
+ | _ ->
+ assert false)
+ | _ ->
+ assert false
with Not_found ->
(* No such equivalent expr: keeping the definition *)
subst, instr :: instrs
-
+
+(* - [subst] : hashtable from ident to (simple) definition it is an equivalence
+ table - [elim] : set of eliminated variables - [instrs] : previous
+ instructions, which [instr] is compared against - [instr] : current
+ instruction, normalized by [subst] *)
+
(** Common sub-expression elimination for machine instructions *)
-(* - [subst] : hashtable from ident to (simple) definition
- it is an equivalence table
- - [elim] : set of eliminated variables
- - [instrs] : previous instructions, which [instr] is compared against
- - [instr] : current instruction, normalized by [subst]
-*)
let rec instr_cse m (subst, instrs) instr =
match get_instr_desc instr with
(* Simple cases*)
- | MStep([v], id, vl) when Basic_library.is_internal_fun id (List.map (fun v -> v.value_type) vl)
- -> instr_cse m (subst, instrs) (update_instr_desc instr (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type)))
- | MLocalAssign(v, expr) when is_unfoldable_expr 2 expr
- -> (IMap.add v.var_id expr subst, instr :: instrs)
- | _ when is_assign instr
- -> subst_instr m subst instrs instr
- | _ -> (subst, instr :: instrs)
-
-(** Apply common sub-expression elimination to a sequence of instrs
-*)
+ | MStep ([ v ], id, vl)
+ when Basic_library.is_internal_fun id (List.map (fun v -> v.value_type) vl)
+ ->
+ instr_cse m (subst, instrs)
+ (update_instr_desc instr
+ (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type)))
+ | MLocalAssign (v, expr) when is_unfoldable_expr 2 expr ->
+ IMap.add v.var_id expr subst, instr :: instrs
+ | _ when is_assign instr ->
+ subst_instr m subst instrs instr
+ | _ ->
+ subst, instr :: instrs
+
+(** Apply common sub-expression elimination to a sequence of instrs *)
let instrs_cse m subst instrs =
- let subst, rev_instrs =
- List.fold_left (instr_cse m) (subst, []) instrs
- in subst, List.rev rev_instrs
+ let subst, rev_instrs = List.fold_left (instr_cse m) (subst, []) instrs in
+ subst, List.rev rev_instrs
-(** Apply common sub-expression elimination to a machine
- - iterate through step instructions and remove simple local assigns
-*)
+(** Apply common sub-expression elimination to a machine - iterate through step
+ instructions and remove simple local assigns *)
let machine_cse subst machine =
- (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_cse %a@." pp_elim subst);*)
+ (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_cse %a@."
+ pp_elim subst);*)
let _, instrs = instrs_cse machine subst machine.mstep.step_instrs in
- let assigned = assigns_instrs instrs VSet.empty
- in
+ let assigned = assigns_instrs instrs VSet.empty in
{
machine with
- mmemory = List.filter (fun vdecl -> VSet.mem vdecl assigned) machine.mmemory;
- mstep = {
- machine.mstep with
- step_locals = List.filter (fun vdecl -> VSet.mem vdecl assigned) machine.mstep.step_locals;
- step_instrs = instrs
- }
+ mmemory = List.filter (fun vdecl -> VSet.mem vdecl assigned) machine.mmemory;
+ mstep =
+ {
+ machine.mstep with
+ step_locals =
+ List.filter
+ (fun vdecl -> VSet.mem vdecl assigned)
+ machine.mstep.step_locals;
+ step_instrs = instrs;
+ };
}
-let machines_cse machines =
- List.map
- (machine_cse IMap.empty)
- machines
+let machines_cse machines = List.map (machine_cse IMap.empty) machines
(* variable substitution for optimizing purposes *)
(* checks whether an [instr] is skip and can be removed from program *)
let rec instr_is_skip instr =
match get_instr_desc instr with
- | MLocalAssign (i, { value_desc = (Var v) ; _}) when i = v -> true
- | MStateAssign (i, { value_desc = Var v; _}) when i = v -> true
- | MBranch (_, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl
- | _ -> false
-and instrs_are_skip instrs =
- List.for_all instr_is_skip instrs
+ | MLocalAssign (i, { value_desc = Var v; _ }) when i = v ->
+ true
+ | MStateAssign (i, { value_desc = Var v; _ }) when i = v ->
+ true
+ | MBranch (_, hl) ->
+ List.for_all (fun (_, il) -> instrs_are_skip il) hl
+ | _ ->
+ false
+
+and instrs_are_skip instrs = List.for_all instr_is_skip instrs
-let instr_cons instr cont =
- if instr_is_skip instr then cont else instr::cont
+let instr_cons instr cont = if instr_is_skip instr then cont else instr :: cont
let rec instr_remove_skip instr cont =
match get_instr_desc instr with
- | MLocalAssign (i, { value_desc = Var v; _ }) when i = v -> cont
- | MStateAssign (i, { value_desc = Var v; _ }) when i = v -> cont
- | MBranch (g, hl) -> update_instr_desc instr (MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl)) :: cont
- | _ -> instr::cont
+ | MLocalAssign (i, { value_desc = Var v; _ }) when i = v ->
+ cont
+ | MStateAssign (i, { value_desc = Var v; _ }) when i = v ->
+ cont
+ | MBranch (g, hl) ->
+ update_instr_desc instr
+ (MBranch (g, List.map (fun (h, il) -> h, instrs_remove_skip il []) hl))
+ :: cont
+ | _ ->
+ instr :: cont
and instrs_remove_skip instrs cont =
List.fold_right instr_remove_skip instrs cont
let rec value_replace_var fvar value =
match value.value_desc with
- | Cst _ | ResetFlag -> value
- | Var v -> { value with value_desc = Var (fvar v) }
- | Fun (id, args) -> { value with value_desc = Fun (id, List.map (value_replace_var fvar) args) }
- | Array vl -> { value with value_desc = Array (List.map (value_replace_var fvar) vl)}
- | Access (t, i) -> { value with value_desc = Access(value_replace_var fvar t, i)}
- | Power (v, n) -> { value with value_desc = Power(value_replace_var fvar v, n)}
+ | Cst _ | ResetFlag ->
+ value
+ | Var v ->
+ { value with value_desc = Var (fvar v) }
+ | Fun (id, args) ->
+ { value with value_desc = Fun (id, List.map (value_replace_var fvar) args) }
+ | Array vl ->
+ { value with value_desc = Array (List.map (value_replace_var fvar) vl) }
+ | Access (t, i) ->
+ { value with value_desc = Access (value_replace_var fvar t, i) }
+ | Power (v, n) ->
+ { value with value_desc = Power (value_replace_var fvar v, n) }
let rec instr_replace_var fvar instr cont =
match get_instr_desc instr with
- | MLocalAssign (i, v) -> instr_cons (update_instr_desc instr (MLocalAssign (fvar i, value_replace_var fvar v))) cont
- | MStateAssign (i, v) -> instr_cons (update_instr_desc instr (MStateAssign (i, value_replace_var fvar v))) cont
+ | MLocalAssign (i, v) ->
+ instr_cons
+ (update_instr_desc instr
+ (MLocalAssign (fvar i, value_replace_var fvar v)))
+ cont
+ | MStateAssign (i, v) ->
+ instr_cons
+ (update_instr_desc instr (MStateAssign (i, value_replace_var fvar v)))
+ cont
| MSetReset _
| MNoReset _
| MClearReset
| MResetAssign _
| MSpec _
- | MComment _ -> instr_cons instr cont
- | MStep (il, i, vl) -> instr_cons (update_instr_desc instr (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl))) cont
- | MBranch (g, hl) -> instr_cons (update_instr_desc instr (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl))) cont
+ | MComment _ ->
+ instr_cons instr cont
+ | MStep (il, i, vl) ->
+ instr_cons
+ (update_instr_desc instr
+ (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)))
+ cont
+ | MBranch (g, hl) ->
+ instr_cons
+ (update_instr_desc instr
+ (MBranch
+ ( value_replace_var fvar g,
+ List.map (fun (h, il) -> h, instrs_replace_var fvar il []) hl )))
+ cont
and instrs_replace_var fvar instrs cont =
List.fold_right (instr_replace_var fvar) instrs cont
let step_replace_var fvar step =
- (* Some outputs may have been replaced by locals.
- We then need to rename those outputs
- without changing their clocks, etc *)
+ (* Some outputs may have been replaced by locals. We then need to rename those
+ outputs without changing their clocks, etc *)
let outputs' =
- List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs in
- let locals' =
- List.fold_left (fun res l ->
- let l' = fvar l in
- if List.exists (fun o -> o.var_id = l'.var_id) outputs'
- then res
- else Utils.add_cons l' res)
- [] step.step_locals in
- { step with
- step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks;
+ List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs
+ in
+ let locals' =
+ List.fold_left
+ (fun res l ->
+ let l' = fvar l in
+ if List.exists (fun o -> o.var_id = l'.var_id) outputs' then res
+ else Utils.add_cons l' res)
+ [] step.step_locals
+ in
+ {
+ step with
+ step_checks =
+ List.map (fun (l, v) -> l, value_replace_var fvar v) step.step_checks;
step_outputs = outputs';
step_locals = locals';
step_instrs = instrs_replace_var fvar step.step_instrs [];
-}
+ }
let machine_replace_variables fvar m =
- { m with
- mstep = step_replace_var fvar m.mstep
- }
+ { m with mstep = step_replace_var fvar m.mstep }
let machine_reuse_variables m reuse =
- let fvar v =
- try
- Hashtbl.find reuse v.var_id
- with Not_found -> v in
+ let fvar v = try Hashtbl.find reuse v.var_id with Not_found -> v in
machine_replace_variables fvar m
let machines_reuse_variables prog reuse_tables =
- List.map
- (fun m ->
- machine_reuse_variables m (Utils.IMap.find m.mname.node_id reuse_tables)
- ) prog
+ List.map
+ (fun m ->
+ machine_reuse_variables m (Utils.IMap.find m.mname.node_id reuse_tables))
+ prog
let rec instr_assign res instr =
match get_instr_desc instr with
- | MLocalAssign (i, _) -> Disjunction.CISet.add i res
- | MStateAssign (i, _) -> Disjunction.CISet.add i res
- | MBranch (_, hl) -> List.fold_left (fun res (_, b) -> instrs_assign res b) res hl
- | MStep (il, _, _) -> List.fold_right Disjunction.CISet.add il res
- | _ -> res
-
-and instrs_assign res instrs =
- List.fold_left instr_assign res instrs
+ | MLocalAssign (i, _) ->
+ Disjunction.CISet.add i res
+ | MStateAssign (i, _) ->
+ Disjunction.CISet.add i res
+ | MBranch (_, hl) ->
+ List.fold_left (fun res (_, b) -> instrs_assign res b) res hl
+ | MStep (il, _, _) ->
+ List.fold_right Disjunction.CISet.add il res
+ | _ ->
+ res
+
+and instrs_assign res instrs = List.fold_left instr_assign res instrs
let rec instr_constant_assign var instr =
match get_instr_desc instr with
| MLocalAssign (i, { value_desc = Cst (Const_tag _); _ })
- | MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) -> i = var
- | MBranch (_, hl) -> List.for_all (fun (_, b) -> instrs_constant_assign var b) hl
- | _ -> false
+ | MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) ->
+ i = var
+ | MBranch (_, hl) ->
+ List.for_all (fun (_, b) -> instrs_constant_assign var b) hl
+ | _ ->
+ false
and instrs_constant_assign var instrs =
- List.fold_left (fun res i -> if Disjunction.CISet.mem var (instr_assign Disjunction.CISet.empty i) then instr_constant_assign var i else res) false instrs
+ List.fold_left
+ (fun res i ->
+ if Disjunction.CISet.mem var (instr_assign Disjunction.CISet.empty i) then
+ instr_constant_assign var i
+ else res)
+ false instrs
let rec instr_reduce branches instr1 cont =
match get_instr_desc instr1 with
- | MLocalAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont)
- | MStateAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont)
- | MBranch (g, hl) -> (update_instr_desc instr1 (MBranch (g, List.map (fun (h, b) -> (h, instrs_reduce branches b [])) hl))) :: cont
- | _ -> instr1 :: cont
+ | MLocalAssign (_, { value_desc = Cst (Const_tag c); _ }) ->
+ instr1 :: (List.assoc c branches @ cont)
+ | MStateAssign (_, { value_desc = Cst (Const_tag c); _ }) ->
+ instr1 :: (List.assoc c branches @ cont)
+ | MBranch (g, hl) ->
+ update_instr_desc instr1
+ (MBranch (g, List.map (fun (h, b) -> h, instrs_reduce branches b []) hl))
+ :: cont
+ | _ ->
+ instr1 :: cont
and instrs_reduce branches instrs cont =
- match instrs with
- | [] -> cont
- | [i] -> instr_reduce branches i cont
- | i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont
+ match instrs with
+ | [] ->
+ cont
+ | [ i ] ->
+ instr_reduce branches i cont
+ | i1 :: i2 :: q ->
+ i1 :: instrs_reduce branches (i2 :: q) cont
let rec instrs_fusion instrs =
match instrs, List.map get_instr_desc instrs with
- | [], []
- | [_], [_] ->
+ | [], [] | [ _ ], [ _ ] ->
instrs
- | i1::_::q, _::(MBranch ({ value_desc = Var v; _}, hl))::_ when instr_constant_assign v i1 ->
- instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q)
- | i1::i2::q, _ ->
- i1 :: instrs_fusion (i2::q)
- | _ -> assert false (* Other cases should not happen since both lists are of same size *)
-
-let step_fusion step =
- { step with
- step_instrs = instrs_fusion step.step_instrs;
- }
+ | i1 :: _ :: q, _ :: MBranch ({ value_desc = Var v; _ }, hl) :: _
+ when instr_constant_assign v i1 ->
+ instr_reduce
+ (List.map (fun (h, b) -> h, instrs_fusion b) hl)
+ i1 (instrs_fusion q)
+ | i1 :: i2 :: q, _ ->
+ i1 :: instrs_fusion (i2 :: q)
+ | _ ->
+ assert false
+(* Other cases should not happen since both lists are of same size *)
-let machine_fusion m =
- { m with
- mstep = step_fusion m.mstep
- }
+let step_fusion step =
+ { step with step_instrs = instrs_fusion step.step_instrs }
-let machines_fusion prog =
- List.map machine_fusion prog
+let machine_fusion m = { m with mstep = step_fusion m.mstep }
+let machines_fusion prog = List.map machine_fusion prog
(* Additional function to modify the prog according to removed variables map *)
let elim_prog_variables prog removed_table =
- List.map (fun t -> match t.top_decl_desc with
- | Node nd ->
- begin match IMap.find_opt nd.node_id removed_table with
- | Some nd_elim_map ->
- (* Iterating through the elim map to compute
- - the list of variables to remove
- - the associated list of lustre definitions x = expr to
- be used when removing these variables *)
- let vars_to_replace, defs = (* Recovering vid from node locals *)
- IMap.fold (fun v (_,eq) (accu_locals, accu_defs) ->
- let locals =
- try
- List.find (fun v' -> v'.var_id = v) nd.node_locals
- :: accu_locals
- with Not_found -> accu_locals (* Variable v shall
- be a global
- constant, we do no
- need to eliminate
- it from the locals
- *)
- in
- (* xxx let new_eq = { eq_lhs = [v]; eq_rhs = e; eq_loc = e.expr_loc } in *)
- let defs = eq::accu_defs in
- locals, defs
- ) nd_elim_map ([], [])
- in
-
- let node_locals, node_stmts =
- List.fold_right (fun stmt (locals, res_stmts) ->
- match stmt with
- | Aut _ -> assert false (* should be processed by now *)
- | Eq eq ->
- begin match eq.eq_lhs with
- | [] -> assert false (* shall not happen *)
- | _::_::_ ->
- (* When more than one lhs we just keep the
- equation and do not delete it *)
- let eq_rhs' = substitute_expr vars_to_replace defs eq.eq_rhs in
- locals, (Eq { eq with eq_rhs = eq_rhs' })::res_stmts
- | [lhs] ->
- if List.exists (fun v -> v.var_id = lhs) vars_to_replace then
- (* We remove the def *)
- List.filter (fun v -> v.var_id <> lhs) locals,
- res_stmts
- else (* We keep it but modify any use of an eliminatend var *)
- let eq_rhs' = substitute_expr vars_to_replace defs eq.eq_rhs in
- locals,
- (Eq { eq with eq_rhs = eq_rhs' })::res_stmts
- end
- ) nd.node_stmts (nd.node_locals, [])
- in
- let nd' = { nd with node_locals; node_stmts } in
- { t with top_decl_desc = Node nd' }
- | None -> t
- end
- | _ -> t
- ) prog
+ List.map
+ (fun t ->
+ match t.top_decl_desc with
+ | Node nd -> (
+ match IMap.find_opt nd.node_id removed_table with
+ | Some nd_elim_map ->
+ (* Iterating through the elim map to compute - the list of variables
+ to remove - the associated list of lustre definitions x = expr to
+ be used when removing these variables *)
+ let vars_to_replace, defs =
+ (* Recovering vid from node locals *)
+ IMap.fold
+ (fun v (_, eq) (accu_locals, accu_defs) ->
+ let locals =
+ try
+ List.find (fun v' -> v'.var_id = v) nd.node_locals
+ :: accu_locals
+ with Not_found -> accu_locals
+ (* Variable v shall be a global constant, we do no need to
+ eliminate it from the locals *)
+ in
+ (* xxx let new_eq = { eq_lhs = [v]; eq_rhs = e; eq_loc =
+ e.expr_loc } in *)
+ let defs = eq :: accu_defs in
+ locals, defs)
+ nd_elim_map ([], [])
+ in
+
+ let node_locals, node_stmts =
+ List.fold_right
+ (fun stmt (locals, res_stmts) ->
+ match stmt with
+ | Aut _ ->
+ assert false (* should be processed by now *)
+ | Eq eq -> (
+ match eq.eq_lhs with
+ | [] ->
+ assert false (* shall not happen *)
+ | _ :: _ :: _ ->
+ (* When more than one lhs we just keep the equation and do
+ not delete it *)
+ let eq_rhs' =
+ substitute_expr vars_to_replace defs eq.eq_rhs
+ in
+ locals, Eq { eq with eq_rhs = eq_rhs' } :: res_stmts
+ | [ lhs ] ->
+ if List.exists (fun v -> v.var_id = lhs) vars_to_replace
+ then
+ (* We remove the def *)
+ List.filter (fun v -> v.var_id <> lhs) locals, res_stmts
+ else
+ (* We keep it but modify any use of an eliminatend var *)
+ let eq_rhs' =
+ substitute_expr vars_to_replace defs eq.eq_rhs
+ in
+ locals, Eq { eq with eq_rhs = eq_rhs' } :: res_stmts))
+ nd.node_stmts (nd.node_locals, [])
+ in
+ let nd' = { nd with node_locals; node_stmts } in
+ { t with top_decl_desc = Node nd' }
+ | None ->
+ t)
+ | _ ->
+ t)
+ prog
(*** Main function ***)
-(*
-This functions produces an optimzed prog * machines
-It
-1- eliminates common sub-expressions (TODO how is this different from normalization?)
-2- inline constants and eliminate duplicated variables
-3- try to reuse variables whenever possible
+(* This functions produces an optimzed prog * machines It 1- eliminates common
+ sub-expressions (TODO how is this different from normalization?) 2- inline
+ constants and eliminate duplicated variables 3- try to reuse variables
+ whenever possible
-When item (2) identified eliminated variables, the initial prog is modified, its normalized recomputed, as well as its scheduling, before regenerating the machines.
+ When item (2) identified eliminated variables, the initial prog is modified,
+ its normalized recomputed, as well as its scheduling, before regenerating the
+ machines.
-The function returns both the (possibly updated) prog as well as the machines
-
-
-*)
+ The function returns both the (possibly updated) prog as well as the machines *)
let optimize params prog node_schs machine_code =
let machine_code =
- if !Options.optimization >= 4 (* && !Options.output <> "horn" *) then begin
- Log.report ~level:1
- (fun fmt -> Format.fprintf fmt "@ @[<v 2>.. machines optimization: sub-expression elimination@ ");
+ if !Options.optimization >= 4 (* && !Options.output <> "horn" *) then (
+ Log.report ~level:1 (fun fmt ->
+ Format.fprintf fmt
+ "@ @[<v 2>.. machines optimization: sub-expression elimination@ ");
let machine_code = machines_cse machine_code in
- Log.report ~level:3 (fun fmt -> Format.fprintf fmt "@[<v 2>.. generated machines (sub-expr elim):@ %a@]@ "
- pp_machines machine_code);
+ Log.report ~level:3 (fun fmt ->
+ Format.fprintf fmt
+ "@[<v 2>.. generated machines (sub-expr elim):@ %a@]@ " pp_machines
+ machine_code);
Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@]");
- machine_code
- end else
- machine_code
+ machine_code)
+ else machine_code
in
(* Optimize machine code *)
- let prog, machine_code, removed_table =
- if !Options.optimization >= 2
- && !Options.output <> "emf" (*&& !Options.output <> "horn"*)
- then begin
- Log.report ~level:1
- (fun fmt ->
- Format.fprintf fmt
- "@ @[<v 2>.. machines optimization: const. inlining (partial eval. with const)@ ");
+ let prog, machine_code, removed_table =
+ if
+ !Options.optimization >= 2 && !Options.output <> "emf"
+ (*&& !Options.output <> "horn"*)
+ then (
+ Log.report ~level:1 (fun fmt ->
+ Format.fprintf fmt
+ "@ @[<v 2>.. machines optimization: const. inlining (partial eval. \
+ with const)@ ");
let machine_code, removed_table =
- machines_unfold (Corelang.get_consts prog) node_schs machine_code in
- Log.report ~level:3
- (fun fmt ->
- Format.fprintf fmt "@ Eliminated flows: %a@ "
- (pp_imap (fun fmt m -> pp_elim empty_machine fmt (IMap.map fst m))) removed_table);
- Log.report ~level:3
- (fun fmt ->
- Format.fprintf fmt
- "@ @[<v 2>.. generated machines (const inlining):@ %a@]@ "
- pp_machines machine_code);
- (* If variables were eliminated, relaunch the
- normalization/machine generation *)
+ machines_unfold (Corelang.get_consts prog) node_schs machine_code
+ in
+ Log.report ~level:3 (fun fmt ->
+ Format.fprintf fmt "@ Eliminated flows: %a@ "
+ (pp_imap (fun fmt m -> pp_elim empty_machine fmt (IMap.map fst m)))
+ removed_table);
+ Log.report ~level:3 (fun fmt ->
+ Format.fprintf fmt
+ "@ @[<v 2>.. generated machines (const inlining):@ %a@]@ "
+ pp_machines machine_code);
+ (* If variables were eliminated, relaunch the normalization/machine
+ generation *)
let prog, machine_code, removed_table =
if IMap.is_empty removed_table then
(* stopping here, no need to reupdate the prog *)
prog, machine_code, removed_table
- else (
+ else
let prog = elim_prog_variables prog removed_table in
(* Mini stage1 *)
let prog = Normalization.normalize_prog params prog in
let prog = SortProg.sort_nodes_locals prog in
- (* Mini stage2: note that we do not protect against
- alg. loop since this should have been handled before *)
+ (* Mini stage2: note that we do not protect against alg. loop since
+ this should have been handled before *)
let prog, node_schs = Scheduling.schedule_prog prog in
let machine_code = Machine_code.translate_prog prog node_schs in
(* Mini stage2 machine optimiation *)
let machine_code, removed_table =
- machines_unfold (Corelang.get_consts prog) node_schs machine_code in
+ machines_unfold (Corelang.get_consts prog) node_schs machine_code
+ in
prog, machine_code, removed_table
- )
- in
- Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@]");
- prog, machine_code, removed_table
-
- end else
- prog, machine_code, IMap.empty
- in
+ in
+ Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@]");
+ prog, machine_code, removed_table)
+ else prog, machine_code, IMap.empty
+ in
(* Optimize machine code *)
let machine_code =
- if !Options.optimization >= 3 && not (Backends.is_functional ()) then
- begin
- Log.report ~level:1 (fun fmt -> Format.fprintf fmt ".. machines optimization: minimize stack usage by reusing variables@,");
- let node_schs = Scheduling.remove_prog_inlined_locals removed_table node_schs in
- let reuse_tables = Scheduling.compute_prog_reuse_table node_schs in
- machines_fusion (machines_reuse_variables machine_code reuse_tables)
- end
- else
- machine_code
+ if !Options.optimization >= 3 && not (Backends.is_functional ()) then (
+ Log.report ~level:1 (fun fmt ->
+ Format.fprintf fmt
+ ".. machines optimization: minimize stack usage by reusing \
+ variables@,");
+ let node_schs =
+ Scheduling.remove_prog_inlined_locals removed_table node_schs
+ in
+ let reuse_tables = Scheduling.compute_prog_reuse_table node_schs in
+ machines_fusion (machines_reuse_variables machine_code reuse_tables))
+ else machine_code
in
-
prog, machine_code
-
- (* Local Variables: *)
- (* compile-command:"make -C .." *)
- (* End: *)
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
diff --git a/src/optimize_prog.ml b/src/optimize_prog.ml
index 22e90b381dada373bbc05ef8addbe7e0d0c0ecae..834999e440c2870df6ebb23dcd5891fe7abb62f9 100644
--- a/src/optimize_prog.ml
+++ b/src/optimize_prog.ml
@@ -14,34 +14,48 @@ open Corelang
(* open LustreSpec *)
(* Consts unfoooolding *)
-let is_const i consts =
- List.exists (fun c -> c.const_id = i) consts
+let is_const i consts = List.exists (fun c -> c.const_id = i) consts
let get_const i consts =
let c = List.find (fun c -> c.const_id = i) consts in
c.const_value
-let rec expr_unfold_consts consts e =
-{ e with expr_desc = expr_desc_unfold_consts consts e.expr_desc e.expr_type }
+let rec expr_unfold_consts consts e =
+ { e with expr_desc = expr_desc_unfold_consts consts e.expr_desc e.expr_type }
and expr_desc_unfold_consts consts e e_type =
let unfold = expr_unfold_consts consts in
match e with
- | Expr_const _ -> e
- | Expr_ident i -> if is_const i consts && not (Types.is_array_type e_type) then Expr_const (get_const i consts) else e
- | Expr_array el -> Expr_array (List.map unfold el)
- | Expr_access (e1, d) -> Expr_access (unfold e1, d)
- | Expr_power (e1, d) -> Expr_power (unfold e1, d)
- | Expr_tuple el -> Expr_tuple (List.map unfold el)
- | Expr_ite (c, t, e) -> Expr_ite (unfold c, unfold t, unfold e)
- | Expr_arrow (e1, e2)-> Expr_arrow (unfold e1, unfold e2)
- | Expr_fby (e1, e2) -> Expr_fby (unfold e1, unfold e2)
+ | Expr_const _ ->
+ e
+ | Expr_ident i ->
+ if is_const i consts && not (Types.is_array_type e_type) then
+ Expr_const (get_const i consts)
+ else e
+ | Expr_array el ->
+ Expr_array (List.map unfold el)
+ | Expr_access (e1, d) ->
+ Expr_access (unfold e1, d)
+ | Expr_power (e1, d) ->
+ Expr_power (unfold e1, d)
+ | Expr_tuple el ->
+ Expr_tuple (List.map unfold el)
+ | Expr_ite (c, t, e) ->
+ Expr_ite (unfold c, unfold t, unfold e)
+ | Expr_arrow (e1, e2) ->
+ Expr_arrow (unfold e1, unfold e2)
+ | Expr_fby (e1, e2) ->
+ Expr_fby (unfold e1, unfold e2)
(* | Expr_concat (e1, e2) -> Expr_concat (unfold e1, unfold e2) *)
(* | Expr_tail e' -> Expr_tail (unfold e') *)
- | Expr_pre e' -> Expr_pre (unfold e')
- | Expr_when (e', i, l)-> Expr_when (unfold e', i, l)
- | Expr_merge (i, hl) -> Expr_merge (i, List.map (fun (t, h) -> (t, unfold h)) hl)
- | Expr_appl (i, e', i') -> Expr_appl (i, unfold e', i')
+ | Expr_pre e' ->
+ Expr_pre (unfold e')
+ | Expr_when (e', i, l) ->
+ Expr_when (unfold e', i, l)
+ | Expr_merge (i, hl) ->
+ Expr_merge (i, List.map (fun (t, h) -> t, unfold h) hl)
+ | Expr_appl (i, e', i') ->
+ Expr_appl (i, unfold e', i')
let eq_unfold_consts consts eq =
{ eq with eq_rhs = expr_unfold_consts consts eq.eq_rhs }
@@ -49,50 +63,69 @@ let eq_unfold_consts consts eq =
let node_unfold_consts consts node =
let eqs, automata = get_node_eqs node in
assert (automata = []);
- { node with node_stmts = List.map (fun eq -> Eq (eq_unfold_consts consts eq)) eqs }
+ {
+ node with
+ node_stmts = List.map (fun eq -> Eq (eq_unfold_consts consts eq)) eqs;
+ }
let prog_unfold_consts prog =
let consts = List.map const_of_top (get_consts prog) in
- List.map (
- fun decl -> match decl.top_decl_desc with
- | Node nd -> {decl with top_decl_desc = Node (node_unfold_consts consts nd)}
- | _ -> decl
- ) prog
+ List.map
+ (fun decl ->
+ match decl.top_decl_desc with
+ | Node nd ->
+ { decl with top_decl_desc = Node (node_unfold_consts consts nd) }
+ | _ ->
+ decl)
+ prog
-(* Distribution of when inside sub-expressions, i.e. (a+b) when c --> a when c + b when c
- May increase clock disjointness of variables, which is useful for code optimization
-*)
+(* Distribution of when inside sub-expressions, i.e. (a+b) when c --> a when c +
+ b when c May increase clock disjointness of variables, which is useful for
+ code optimization *)
let apply_stack expr stack =
- List.fold_left (fun expr (v, t) -> mkexpr expr.expr_loc (Expr_when (expr, v, t))) expr stack
+ List.fold_left
+ (fun expr (v, t) -> mkexpr expr.expr_loc (Expr_when (expr, v, t)))
+ expr stack
let expr_distribute_when expr =
let rec distrib stack expr =
match expr.expr_desc with
- | Expr_const _
- | Expr_ident _
- | Expr_arrow _
- | Expr_fby _
- | Expr_pre _
- -> apply_stack expr stack
+ | Expr_const _ | Expr_ident _ | Expr_arrow _ | Expr_fby _ | Expr_pre _ ->
+ apply_stack expr stack
| Expr_appl (id, _, _) when not (Stateless.check_node (node_from_name id))
- -> apply_stack expr stack
- | Expr_ite (c, t, e)
- -> let cid = ident_of_expr c in
- mkexpr expr.expr_loc
- (Expr_merge (cid,
- [(tag_true , distrib ((cid,tag_true )::stack) t);
- (tag_false, distrib ((cid,tag_false)::stack) e)]))
- | Expr_array el -> { expr with expr_desc = (Expr_array (List.map (distrib stack) el)) }
- | Expr_access (e1, d) -> { expr with expr_desc = Expr_access (distrib stack e1, d) }
- | Expr_power (e1, d) -> { expr with expr_desc = Expr_power (distrib stack e1, d) }
- | Expr_tuple el -> { expr with expr_desc = Expr_tuple (List.map (distrib stack) el) }
- | Expr_when (e', i, l)-> distrib ((i, l)::stack) e'
- | Expr_merge (i, hl) -> { expr with expr_desc = Expr_merge (i, List.map (fun (t, h) -> (t, distrib stack h)) hl) }
- | Expr_appl (id, e', i') -> { expr with expr_desc = Expr_appl (id, distrib stack e', i')}
- in distrib [] expr
+ ->
+ apply_stack expr stack
+ | Expr_ite (c, t, e) ->
+ let cid = ident_of_expr c in
+ mkexpr expr.expr_loc
+ (Expr_merge
+ ( cid,
+ [
+ tag_true, distrib ((cid, tag_true) :: stack) t;
+ tag_false, distrib ((cid, tag_false) :: stack) e;
+ ] ))
+ | Expr_array el ->
+ { expr with expr_desc = Expr_array (List.map (distrib stack) el) }
+ | Expr_access (e1, d) ->
+ { expr with expr_desc = Expr_access (distrib stack e1, d) }
+ | Expr_power (e1, d) ->
+ { expr with expr_desc = Expr_power (distrib stack e1, d) }
+ | Expr_tuple el ->
+ { expr with expr_desc = Expr_tuple (List.map (distrib stack) el) }
+ | Expr_when (e', i, l) ->
+ distrib ((i, l) :: stack) e'
+ | Expr_merge (i, hl) ->
+ {
+ expr with
+ expr_desc =
+ Expr_merge (i, List.map (fun (t, h) -> t, distrib stack h) hl);
+ }
+ | Expr_appl (id, e', i') ->
+ { expr with expr_desc = Expr_appl (id, distrib stack e', i') }
+ in
+ distrib [] expr
-let eq_distribute_when eq =
- { eq with eq_rhs = expr_distribute_when eq.eq_rhs }
+let eq_distribute_when eq = { eq with eq_rhs = expr_distribute_when eq.eq_rhs }
let node_distribute_when node =
let eqs, automata = get_node_eqs node in
@@ -100,11 +133,14 @@ let node_distribute_when node =
{ node with node_stmts = List.map (fun eq -> Eq (eq_distribute_when eq)) eqs }
let prog_distribute_when prog =
- List.map (
- fun decl -> match decl.top_decl_desc with
- | Node nd -> {decl with top_decl_desc = Node (node_distribute_when nd)}
- | _ -> decl
- ) prog
+ List.map
+ (fun decl ->
+ match decl.top_decl_desc with
+ | Node nd ->
+ { decl with top_decl_desc = Node (node_distribute_when nd) }
+ | _ ->
+ decl)
+ prog
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/options.ml b/src/options.ml
index c2779f3c050f610344a9de7f84e5bfd231f8ec92..7a481a4deaf05c7f485f461e11a5f5d28c400087 100644
--- a/src/options.ml
+++ b/src/options.ml
@@ -10,57 +10,91 @@
(********************************************************************)
let version = Version.number
+
let codename = Version.codename
-let include_dirs = ref ["."]
+
+let include_dirs = ref [ "." ]
let main_node = ref ""
+
let static_mem = ref true
+
let print_types = ref false
+
let print_clocks = ref false
+
let delay_calculus = ref true
+
let track_exceptions = ref true
+
let ansi = ref false
+
let check = ref false
+
let spec = ref "no"
+
let output = ref "C"
+
let dest_dir = ref "."
+
let verbose_level = ref 1
+
let global_inline = ref false
+
let witnesses = ref false
+
let optimization = ref 2
+
let lusi = ref false
+
let print_nodes = ref false
+
let print_reuse = ref false
+
let const_unfold = ref false
+
let mpfr = ref false
+
let mpfr_prec = ref 100
+
let print_dec_types = ref false
+
let compile_header = ref true
-(* Option to select the expected behavior of integer division: Euclidian or
- C. Default C !!! *)
+(* Option to select the expected behavior of integer division: Euclidian or C.
+ Default C !!! *)
let integer_div_euclidean = ref false
-
+
let traces = ref false
+
let horn_cex = ref false
+
let horn_query = ref true
-let cpp = ref false
-let int_type = ref "int"
+let cpp = ref false
+
+let int_type = ref "int"
+
let real_type = ref "double"
+
let print_prec_double = ref 15
+
let print_prec_float = ref 10
let sfunction = ref ""
let mauve = ref ""
+
(* test generation options *)
let nb_mutants = ref 1000
+
let gen_mcdc = ref false
+
let no_mutation_suffix = ref false
(* Algebraic loops unrolling *)
let solve_al = ref false
+
let al_nb_max = ref 15
(* Printer options *)
diff --git a/src/options_management.ml b/src/options_management.ml
index dd81492f253f74b13122b724d576b7efc14b3505..fa950c51e4ad1aa1312243f1ba5959b11209ae8f 100644
--- a/src/options_management.ml
+++ b/src/options_management.ml
@@ -13,58 +13,51 @@ open Options
let print_version () =
let open Utils.Format in
printf
- "@[<v>\
- Lustrec compiler, version %s (%s)@,\
+ "@[<v>Lustrec compiler, version %s (%s)@,\
Standard lib: %s@,\
- User provided include directory: @[<h>%a@]\
- @]@."
- version codename
+ User provided include directory: @[<h>%a@]@]@." version codename
Version.include_path
- (pp_print_list ~pp_sep:pp_print_space pp_print_string) !include_dirs
+ (pp_print_list ~pp_sep:pp_print_space pp_print_string)
+ !include_dirs
let add_include_dir dir =
let removed_slash_suffix =
let len = String.length dir in
- if dir.[len-1] = '/' then
- String.sub dir 0 (len - 1)
- else
- dir
+ if dir.[len - 1] = '/' then String.sub dir 0 (len - 1) else dir
in
include_dirs := removed_slash_suffix :: !include_dirs
-
-(** Solving the path of required library:
- If local: look in the folders described in !Options.include_dirs
- If non local: look first as a local, then in Version.include_path:
- ie. in Version.include_path::!Options.include_dirs
+(** Solving the path of required library: If local: look in the folders
+ described in !Options.include_dirs If non local: look first as a local, then
+ in Version.include_path: ie. in Version.include_path::!Options.include_dirs
Note that in options.ml, include folder are added as heads. One need to
- perform a fold_right to respect the order
-*)
+ perform a fold_right to respect the order *)
let search_lib_path (local, full_file_name) =
- let paths = (if local then !include_dirs else Version.include_path::!include_dirs) in
+ let paths =
+ if local then !include_dirs else Version.include_path :: !include_dirs
+ in
let name =
- List.fold_right (fun dir res ->
- match res with Some _ -> res
- | None ->
- let path_to_lib = dir ^ "/" ^ full_file_name in
- if Sys.file_exists path_to_lib then
- Some dir
- else
- None
- )
- paths
- None
+ List.fold_right
+ (fun dir res ->
+ match res with
+ | Some _ ->
+ res
+ | None ->
+ let path_to_lib = dir ^ "/" ^ full_file_name in
+ if Sys.file_exists path_to_lib then Some dir else None)
+ paths None
in
match name with
| None ->
Format.eprintf "Unable to find library %s in paths %a@.@?" full_file_name
- (Utils.fprintf_list ~sep:", " Format.pp_print_string) paths;
- raise Not_found
- | Some s -> s
+ (Utils.fprintf_list ~sep:", " Format.pp_print_string)
+ paths;
+ raise Not_found
+ | Some s ->
+ s
(* Search for path of core libs (without lusic: arrow and io_frontend *)
-let core_dependency lib_name =
- search_lib_path (false, lib_name ^ ".h")
+let core_dependency lib_name = search_lib_path (false, lib_name ^ ".h")
let name_dependency (_, dep) ext =
let dir = search_lib_path (false, dep ^ ext) in
@@ -74,111 +67,205 @@ let set_mpfr prec =
if prec > 0 then (
mpfr := true;
mpfr_prec := prec;
- real_type := "mpfr";
- (* salsa_enabled := false; (* We deactivate salsa *) TODO *)
- )
- else
- failwith "mpfr requires a positive integer"
+ real_type := "mpfr"
+ (* salsa_enabled := false; (* We deactivate salsa *) TODO *))
+ else failwith "mpfr requires a positive integer"
let set_real_type s =
match s with
- "mpfr" -> (
- mpfr := true;
- real_type := "mpfr";
- )
- | _ -> real_type := s
+ | "mpfr" ->
+ mpfr := true;
+ real_type := "mpfr"
+ | _ ->
+ real_type := s
-let setup () =
- Backends.setup ()
+let setup () = Backends.setup ()
-let set_backend s =
- output := s
+let set_backend s = output := s
let common_options =
- [ "-d", Arg.Set_string dest_dir, "uses the specified \x1b[4mdirectory\x1b[0m as root for generated/imported object and C files <default: .>";
+ [
+ ( "-d",
+ Arg.Set_string dest_dir,
+ "uses the specified \x1b[4mdirectory\x1b[0m as root for \
+ generated/imported object and C files <default: .>" );
"-I", Arg.String add_include_dir, "sets include \x1b[4mdirectory\x1b[0m";
"-node", Arg.Set_string main_node, "specifies the \x1b[4mmain\x1b[0m node";
"-print-types", Arg.Set print_types, "prints node types";
"-print-clocks", Arg.Set print_clocks, "prints node clocks";
- "-print-nodes", Arg.Set print_nodes, "prints node list";
+ "-print-nodes", Arg.Set print_nodes, "prints node list";
"-algebraic-loop-solve", Arg.Set solve_al, "try to solve algebraic loops";
- "-algebraic-loop-max", Arg.Set_int al_nb_max, "try to solve \x1b[4mnb\x1b[0m number of algebraic loops <default: 15>";
+ ( "-algebraic-loop-max",
+ Arg.Set_int al_nb_max,
+ "try to solve \x1b[4mnb\x1b[0m number of algebraic loops <default: 15>" );
"-kind2", Arg.Set kind2_print, "active kind2 output";
- "-verbose", Arg.Set_int verbose_level, "changes verbose \x1b[4mlevel\x1b[0m <default: 1>";
+ ( "-verbose",
+ Arg.Set_int verbose_level,
+ "changes verbose \x1b[4mlevel\x1b[0m <default: 1>" );
"-version", Arg.Unit print_version, " displays the version";
]
let lustrec_options =
- common_options @
- [
- "-init", Arg.Set delay_calculus, "performs an initialisation analysis for Lustre nodes <default: no analysis>";
- "-dynamic", Arg.Clear static_mem, "specifies a dynamic allocation scheme for main Lustre node <default: static>";
- "-check-access", Arg.Set check, "checks at runtime that array accesses always lie within bounds <default: no check>";
- "-mpfr", Arg.Int set_mpfr, "replaces FP numbers by the MPFR library multiple precision numbers with a precision of \x1b[4mprec\x1b[0m bits <default: keep FP numbers>";
- "-lusi", Arg.Set lusi, "only generates a .lusi interface source file from a Lustre source <default: no generation>";
- "-no-spec", Arg.Unit (fun () -> spec := "no"), "do not generate any specification";
- "-acsl-spec", Arg.Unit (fun () -> spec := "acsl"), "generates an ACSL encoding of the specification. Only meaningful for the C backend <default>";
- "-c-spec", Arg.Unit (fun () -> spec := "c"), "generates a C encoding of the specification instead of ACSL contracts and annotations. Only meaningful for the C backend";
- (* "-java", Arg.Unit (fun () -> output := "java"), "generates Java output instead of C"; *)
- "-ada", Arg.Unit (fun () -> set_backend "Ada"), "generates Ada encoding output instead of C";
- "-horn", Arg.Unit (fun () -> set_backend "horn"), "generates Horn clauses encoding output instead of C";
- "-horn-traces", Arg.Unit (fun () -> set_backend "horn"; traces:=true), "produce traceability file for Horn backend. Enable the horn backend.";
- "-horn-cex", Arg.Unit (fun () -> set_backend "horn"; horn_cex:=true), "generate cex enumeration. Enable the horn backend (work in progress)";
- "-horn-query", Arg.Unit (fun () -> set_backend "horn"; horn_query:=true), "generate queries in generated Horn file. Enable the horn backend (work in progress)";
- "-horn-sfunction", Arg.Set_string sfunction, "Gets the endpoint predicate of the \x1b[4msfunction\x1b[0m";
+ common_options
+ @ [
+ ( "-init",
+ Arg.Set delay_calculus,
+ "performs an initialisation analysis for Lustre nodes <default: no \
+ analysis>" );
+ ( "-dynamic",
+ Arg.Clear static_mem,
+ "specifies a dynamic allocation scheme for main Lustre node <default: \
+ static>" );
+ ( "-check-access",
+ Arg.Set check,
+ "checks at runtime that array accesses always lie within bounds \
+ <default: no check>" );
+ ( "-mpfr",
+ Arg.Int set_mpfr,
+ "replaces FP numbers by the MPFR library multiple precision numbers \
+ with a precision of \x1b[4mprec\x1b[0m bits <default: keep FP \
+ numbers>" );
+ ( "-lusi",
+ Arg.Set lusi,
+ "only generates a .lusi interface source file from a Lustre source \
+ <default: no generation>" );
+ ( "-no-spec",
+ Arg.Unit (fun () -> spec := "no"),
+ "do not generate any specification" );
+ ( "-acsl-spec",
+ Arg.Unit (fun () -> spec := "acsl"),
+ "generates an ACSL encoding of the specification. Only meaningful for \
+ the C backend <default>" );
+ ( "-c-spec",
+ Arg.Unit (fun () -> spec := "c"),
+ "generates a C encoding of the specification instead of ACSL contracts \
+ and annotations. Only meaningful for the C backend" );
+ (* "-java", Arg.Unit (fun () -> output := "java"), "generates Java output
+ instead of C"; *)
+ ( "-ada",
+ Arg.Unit (fun () -> set_backend "Ada"),
+ "generates Ada encoding output instead of C" );
+ ( "-horn",
+ Arg.Unit (fun () -> set_backend "horn"),
+ "generates Horn clauses encoding output instead of C" );
+ ( "-horn-traces",
+ Arg.Unit
+ (fun () ->
+ set_backend "horn";
+ traces := true),
+ "produce traceability file for Horn backend. Enable the horn backend." );
+ ( "-horn-cex",
+ Arg.Unit
+ (fun () ->
+ set_backend "horn";
+ horn_cex := true),
+ "generate cex enumeration. Enable the horn backend (work in progress)" );
+ ( "-horn-query",
+ Arg.Unit
+ (fun () ->
+ set_backend "horn";
+ horn_query := true),
+ "generate queries in generated Horn file. Enable the horn backend \
+ (work in progress)" );
+ ( "-horn-sfunction",
+ Arg.Set_string sfunction,
+ "Gets the endpoint predicate of the \x1b[4msfunction\x1b[0m" );
"-print-reuse", Arg.Set print_reuse, "prints variable reuse policy";
- "-lustre", Arg.Unit (fun () -> output := "lustre"), "generates Lustre output, performing all active optimizations";
- "-emf", Arg.Unit (fun () -> set_backend "emf"), "generates EMF output, to be used by CocoSim";
- "-inline", Arg.Unit (fun () -> global_inline := true; const_unfold := true), "inlines all node calls (require a main node). Implies constant unfolding";
- "-witnesses", Arg.Set witnesses, "enables production of witnesses during compilation";
- "-O", Arg.Set_int optimization, "changes optimization \x1b[4mlevel\x1b[0m <default: 2>";
-
- "-c++" , Arg.Set cpp , "c++ backend";
- "-int" , Arg.Set_string int_type , "specifies the integer type (default=\"int\")";
- "-real", Arg.String set_real_type, "specifies the real type (default=\"double\" without mpfr option)";
- "-real-print-prec", Arg.Set_int print_prec_double, "specifies the number of digits to be printed for real values (default=15)";
- "-int_div_euclidean", Arg.Set integer_div_euclidean, "interprets integer division as Euclidean (default : C division semantics)";
- "-int_div_C", Arg.Clear integer_div_euclidean, "interprets integer division as C division (default)";
-
- "-mauve", Arg.String (fun node -> mauve := node; cpp := true; static_mem := false), "generates the mauve code";
-]
+ ( "-lustre",
+ Arg.Unit (fun () -> output := "lustre"),
+ "generates Lustre output, performing all active optimizations" );
+ ( "-emf",
+ Arg.Unit (fun () -> set_backend "emf"),
+ "generates EMF output, to be used by CocoSim" );
+ ( "-inline",
+ Arg.Unit
+ (fun () ->
+ global_inline := true;
+ const_unfold := true),
+ "inlines all node calls (require a main node). Implies constant \
+ unfolding" );
+ ( "-witnesses",
+ Arg.Set witnesses,
+ "enables production of witnesses during compilation" );
+ ( "-O",
+ Arg.Set_int optimization,
+ "changes optimization \x1b[4mlevel\x1b[0m <default: 2>" );
+ "-c++", Arg.Set cpp, "c++ backend";
+ ( "-int",
+ Arg.Set_string int_type,
+ "specifies the integer type (default=\"int\")" );
+ ( "-real",
+ Arg.String set_real_type,
+ "specifies the real type (default=\"double\" without mpfr option)" );
+ ( "-real-print-prec",
+ Arg.Set_int print_prec_double,
+ "specifies the number of digits to be printed for real values \
+ (default=15)" );
+ ( "-int_div_euclidean",
+ Arg.Set integer_div_euclidean,
+ "interprets integer division as Euclidean (default : C division \
+ semantics)" );
+ ( "-int_div_C",
+ Arg.Clear integer_div_euclidean,
+ "interprets integer division as C division (default)" );
+ ( "-mauve",
+ Arg.String
+ (fun node ->
+ mauve := node;
+ cpp := true;
+ static_mem := false),
+ "generates the mauve code" );
+ ]
let lustret_options =
- common_options @
- [ "-nb-mutants", Arg.Set_int nb_mutants, "\x1b[4mnumber\x1b[0m of mutants to produce <default: 1000>";
- "-mcdc-cond", Arg.Set gen_mcdc, "generates MC/DC coverage";
- "-no-mutation-suffix", Arg.Set no_mutation_suffix, "does not rename node with the _mutant suffix"
- ]
+ common_options
+ @ [
+ ( "-nb-mutants",
+ Arg.Set_int nb_mutants,
+ "\x1b[4mnumber\x1b[0m of mutants to produce <default: 1000>" );
+ "-mcdc-cond", Arg.Set gen_mcdc, "generates MC/DC coverage";
+ ( "-no-mutation-suffix",
+ Arg.Set no_mutation_suffix,
+ "does not rename node with the _mutant suffix" );
+ ]
let lustrev_options =
- common_options @
- [
- "-inline", Arg.Unit (fun () -> global_inline := true; const_unfold := true), "inlines all node calls (require a main node). Implies constant unfolding";
- "-O", Arg.Set_int optimization, "changes optimization \x1b[4mlevel\x1b[0m <default: 2>";
-]
+ common_options
+ @ [
+ ( "-inline",
+ Arg.Unit
+ (fun () ->
+ global_inline := true;
+ const_unfold := true),
+ "inlines all node calls (require a main node). Implies constant \
+ unfolding" );
+ ( "-O",
+ Arg.Set_int optimization,
+ "changes optimization \x1b[4mlevel\x1b[0m <default: 2>" );
+ ]
-
let plugin_opt (name, activate, usage, options) =
let usage () =
Format.printf "@[<v 2>Plugin %s:@ %t@]@." name usage;
exit 0
in
- ( "-" ^ name , Arg.Unit activate, "activate plugin " ^ name ) ::
- ( "-" ^ name ^ "-help" , Arg.Unit usage, "plugin " ^ name ^ " help") ::
- (List.map (fun (opt, act, desc) -> "-" ^ name ^ opt, act, desc) options)
-
+ ("-" ^ name, Arg.Unit activate, "activate plugin " ^ name)
+ ::
+ ("-" ^ name ^ "-help", Arg.Unit usage, "plugin " ^ name ^ " help")
+ :: List.map (fun (opt, act, desc) -> "-" ^ name ^ opt, act, desc) options
+
let verifier_opt (name, activate, options) =
- ( "-" ^ name , Arg.Unit activate, "run verifier " ^ name ) ::
- (List.map (fun (opt, act, desc) -> "-" ^ name ^ opt, act, desc) options)
+ ("-" ^ name, Arg.Unit activate, "run verifier " ^ name)
+ :: List.map (fun (opt, act, desc) -> "-" ^ name ^ opt, act, desc) options
let get_witness_dir filename =
(* Make sure the directory exists *)
- let dir = !dest_dir ^ "/" ^ (Filename.basename filename) ^ "_witnesses" in
- let _ = try
- if not (Sys.is_directory dir) then (
- Format.eprintf "File of name %s exists. It should be a directory.@." dir;
- exit 1
- )
+ let dir = !dest_dir ^ "/" ^ Filename.basename filename ^ "_witnesses" in
+ let _ =
+ try
+ if not (Sys.is_directory dir) then (
+ Format.eprintf "File of name %s exists. It should be a directory.@." dir;
+ exit 1)
with Sys_error _ -> Unix.mkdir dir 0o750
in
dir
diff --git a/src/parsers/dune b/src/parsers/dune
index 4a80a405e353831010140054538c1c372a4d9eb4..e24a35e92d08801baa9d84c16534d494621121d5 100644
--- a/src/parsers/dune
+++ b/src/parsers/dune
@@ -5,6 +5,7 @@
;; The use of [--external-tokens Parser] is required for the two parsers
;; to share a single [token] type. This makes them usable with the same
;; lexer.
+
(menhir
(modules parser_lustre)
(merge_into parser_lustre_table)
@@ -22,16 +23,21 @@
(rule
(deps parser_lustre.check)
- (action (with-stdout-to parser_lustre_messages.ml
- (run menhir
- %{dep:parser_lustre.mly}
- --compile-errors %{dep:parser_lustre.messages}))))
+ (action
+ (with-stdout-to
+ parser_lustre_messages.ml
+ (run
+ menhir
+ %{dep:parser_lustre.mly}
+ --compile-errors
+ %{dep:parser_lustre.messages}))))
;; This rule generates a file "parser_lustre.auto.messages" that contains a
;; list of all error states. It is used by the completeness check.
(rule
- (with-stdout-to parser_lustre.auto.messages
+ (with-stdout-to
+ parser_lustre.auto.messages
(run menhir %{dep:parser_lustre.mly} --list-errors)))
;; This rule implements the completeness check. It checks that every error
@@ -40,8 +46,12 @@
;; by the programmer.
(rule
- (with-stdout-to parser_lustre.check
- (run menhir
- %{dep:parser_lustre.mly}
- --compare-errors %{dep:parser_lustre.auto.messages}
- --compare-errors %{dep:parser_lustre.messages})))
+ (with-stdout-to
+ parser_lustre.check
+ (run
+ menhir
+ %{dep:parser_lustre.mly}
+ --compare-errors
+ %{dep:parser_lustre.auto.messages}
+ --compare-errors
+ %{dep:parser_lustre.messages})))
diff --git a/src/parsers/parse.ml b/src/parsers/parse.ml
index 55def447458058995248940594aec54d82347b18..faa1b25b3fdf599eb6c65969679cedcabb2ff1ed 100644
--- a/src/parsers/parse.ml
+++ b/src/parsers/parse.ml
@@ -9,7 +9,6 @@
(* *)
(********************************************************************)
open Utils.Format
-
module I = Parser_lustre_table.MenhirInterpreter
module Inc = Parser_lustre_table.Incremental
module E = MenhirLib.ErrorReports
@@ -17,16 +16,12 @@ module L = MenhirLib.LexerUtil
exception Error
-type start_symbol =
- | Header
- | Program
+type start_symbol = Header | Program
-(* [env checkpoint] extracts a parser environment out of a checkpoint,
- which must be of the form [HandlingError env]. *)
+(* [env checkpoint] extracts a parser environment out of a checkpoint, which
+ must be of the form [HandlingError env]. *)
let env checkpoint =
- match checkpoint with
- | I.HandlingError env -> env
- | _ -> assert false
+ match checkpoint with I.HandlingError env -> env | _ -> assert false
(* [state checkpoint] extracts the number of the current state out of a
checkpoint. *)
@@ -35,19 +30,17 @@ let state checkpoint : int =
| Some (I.Element (s, _, _, _)) ->
I.number s
| None ->
- (* Hmm... The parser is in its initial state. The incremental API
- currently lacks a way of finding out the number of the initial
- state. It is usually 0, so we return 0. This is unsatisfactory
- and should be fixed in the future. *)
- 0
+ (* Hmm... The parser is in its initial state. The incremental API currently
+ lacks a way of finding out the number of the initial state. It is usually
+ 0, so we return 0. This is unsatisfactory and should be fixed in the
+ future. *)
+ 0
-(* [show text (pos1, pos2)] displays a range of the input text [text]
- delimited by the positions [pos1] and [pos2]. *)
+(* [show text (pos1, pos2)] displays a range of the input text [text] delimited
+ by the positions [pos1] and [pos2]. *)
let show text positions =
- E.extract text positions
- |> E.sanitize
- |> E.compress
- |> E.shorten 20 (* max width 43 *)
+ E.extract text positions |> E.sanitize |> E.compress |> E.shorten 20
+(* max width 43 *)
(* (\* [get text checkpoint i] extracts and shows the range of the input text that
* corresponds to the [i]-th stack cell. The top stack cell is numbered zero. *\)
@@ -63,34 +56,39 @@ let show text positions =
* "???" *)
module type LEXER = sig
- val token: Lexing.lexbuf -> Parser_lustre.token
+ val token : Lexing.lexbuf -> Parser_lustre.token
+
type error
+
exception Error of Location.t * error
- val pp_error: formatter -> error -> unit
+
+ val pp_error : formatter -> error -> unit
end
let reparse (module Lexer : LEXER) ?orig_loc filename start src =
(* Allocate and initialize a lexing buffer. *)
let lexbuf = L.init filename (Lexing.from_string src) in
- (* Wrap the lexer and lexbuf together into a supplier, that is, a
- function of type [unit -> token * position * position]. *)
+ (* Wrap the lexer and lexbuf together into a supplier, that is, a function of
+ type [unit -> token * position * position]. *)
let supplier = I.lexer_lexbuf_to_supplier Lexer.token lexbuf in
- (* Equip the supplier with a two-place buffer that records the positions
- of the last two tokens. This is useful when a syntax error occurs, as
- these are the token just before and just after the error. *)
+ (* Equip the supplier with a two-place buffer that records the positions of
+ the last two tokens. This is useful when a syntax error occurs, as these
+ are the token just before and just after the error. *)
let buffer, supplier = E.wrap_supplier supplier in
(* Fetch the parser's initial checkpoint. *)
let checkpoint = start lexbuf.lex_curr_p in
(* [succeed v] is invoked when the parser has succeeded and produced a
semantic value [v]. In our setting, this cannot happen, since the
- table-based parser is invoked only when we know that there is a
- syntax error in the input file. *)
+ table-based parser is invoked only when we know that there is a syntax
+ error in the input file. *)
let succeed _v = assert false in
(* [fail checkpoint] is invoked when parser has encountered a syntax error. *)
let fail (checkpoint : _ I.checkpoint) =
(* Indicate where in the input file the error occurred. *)
let loc = E.last buffer in
- let loc = match orig_loc with Some loc' -> Location.shift loc' loc | _ -> loc in
+ let loc =
+ match orig_loc with Some loc' -> Location.shift loc' loc | _ -> loc
+ in
(* Show the tokens just before and just after the error. *)
let indication = E.show (show src) buffer in
(* Fetch an error message from the database. *)
@@ -98,32 +96,36 @@ let reparse (module Lexer : LEXER) ?orig_loc filename start src =
(* Expand away the $i keywords that might appear in the message. *)
(* let message = E.expand (get src checkpoint) message in *)
(* Show these three components. *)
- eprintf "@[<v>%aSyntax error %s.@,%s@]@."
- Location.pp_loc loc indication message;
+ eprintf "@[<v>%aSyntax error %s.@,%s@]@." Location.pp_loc loc indication
+ message;
raise Error
in
(* Run the parser. *)
- (* We do not handle [Lexer.Error] because we know that we will not
- encounter a lexical error during this second parsing run. *)
+ (* We do not handle [Lexer.Error] because we know that we will not encounter a
+ lexical error during this second parsing run. *)
I.loop_handle succeed fail supplier checkpoint
-let parse (module Lexer : LEXER) ?orig_loc filename src lexbuf start_mono start_incr =
+let parse (module Lexer : LEXER) ?orig_loc filename src lexbuf start_mono
+ start_incr =
let lexbuf = L.init filename lexbuf in
- try
- start_mono Lexer.token lexbuf
- with
+ try start_mono Lexer.token lexbuf with
| Lexer.Error (loc, err) ->
- let loc = match orig_loc with Some loc' -> Location.shift loc' loc | _ -> loc in
- eprintf "@[<v>%aSyntax error.@,%a@]@."
- Location.pp_loc loc Lexer.pp_error err;
+ let loc =
+ match orig_loc with Some loc' -> Location.shift loc' loc | _ -> loc
+ in
+ eprintf "@[<v>%aSyntax error.@,%a@]@." Location.pp_loc loc Lexer.pp_error
+ err;
raise Error
| Parser_lustre.Error ->
reparse (module Lexer) ?orig_loc filename start_incr src
let parse_filename (module Lexer : LEXER) filename start =
- let start_mono, start_incr = match start with
- | Header -> Parser_lustre.header, Inc.header
- | Program -> Parser_lustre.prog, Inc.prog
+ let start_mono, start_incr =
+ match start with
+ | Header ->
+ Parser_lustre.header, Inc.header
+ | Program ->
+ Parser_lustre.prog, Inc.prog
in
let src, lexbuf = L.read filename in
Location.set_input filename;
diff --git a/src/pathConditions.ml b/src/pathConditions.ml
index 280adfde89374a71aa178cb3301aeb7a1139b200..6abf681f4ffdc872c95626ddb1f32c47ce73690b 100644
--- a/src/pathConditions.ml
+++ b/src/pathConditions.ml
@@ -1,322 +1,385 @@
-open Lustre_types
+open Lustre_types
open Corelang
open Log
-module IdSet = Set.Make (struct type t = expr * int let compare = compare end)
+module IdSet = Set.Make (struct
+ type t = expr * int
-let inout_vars = ref []
+ let compare = compare
+end)
+
+let inout_vars = ref []
(* This was used to add inout variables in the final signature. May have to be
reactivated later *)
-
+
(* let print_tautology_var fmt v = *)
(* match (Types.repr v.var_type).Types.tdesc with *)
(* | Types.Tbool -> Format.fprintf fmt "(%s or not %s)" v.var_id v.var_id *)
-(* | Types.Tint -> Format.fprintf fmt "(%s > 0 or %s <= 0)" v.var_id v.var_id *)
-(* | Types.Treal -> Format.fprintf fmt "(%s > 0 or %s <= 0)" v.var_id v.var_id *)
-(* | _ -> Format.fprintf fmt "(true)" *)
+(* | Types.Tint -> Format.fprintf fmt "(%s > 0 or %s <= 0)" v.var_id v.var_id *)
+(* | Types.Treal -> Format.fprintf fmt "(%s > 0 or %s <= 0)" v.var_id v.var_id *)
+(* | _ -> Format.fprintf fmt "(true)" *)
(* let print_path arg = match !inout_vars with *)
(* | [] -> Format.printf "%t@." arg *)
-(* | l -> Format.printf "%t and %a@." arg (Utils.fprintf_list ~sep:" and " (fun fmt elem -> print_tautology_var fmt elem)) l *)
+(* | l -> Format.printf "%t and %a@." arg (Utils.fprintf_list ~sep:" and " (fun
+ fmt elem -> print_tautology_var fmt elem)) l *)
-let rel_op = ["="; "!="; "<"; "<="; ">" ; ">=" ]
+let rel_op = [ "="; "!="; "<"; "<="; ">"; ">=" ]
(* Used when we were printing the expression directly. Now we are constructing
them as regular expressions.
let rec print_pre fmt nb_pre = if nb_pre <= 0 then () else ( Format.fprintf
- fmt "pre "; print_pre fmt (nb_pre-1) )
-*)
-
-let mk_pre n e =
- if n <= 0 then
- e
- else
- mkexpr e.expr_loc (Expr_pre e)
-
-(*
- let combine2 f sub1 sub2 =
- let elem_e1 = List.fold_right IdSet.add (List.map fst sub1) IdSet.empty in
- let elem_e2 = List.fold_right IdSet.add (List.map fst sub2) IdSet.empty in
- let common = IdSet.inter elem_e1 elem_e2 in
- let sub1_filtered = List.filter (fun (v, _) -> not (IdSet.mem v common)) sub1 in
- let sub2_filtered = List.filter (fun (v, _) -> not (IdSet.mem v common)) sub2 in
- (List.map (fun (v, negv) -> (v, f negv e2)) sub1_filtered) @
- (List.map (fun (v, negv) -> (v, f e1 negv)) sub2_filtered) @
- (List.map (fun v -> (v, {expr with expr_desc = Expr_arrow(List.assoc v sub1, List.assoc v sub2)}) (IdSet.elements common)) )
-*)
+ fmt "pre "; print_pre fmt (nb_pre-1) ) *)
-let rec select (v: expr * int) (active: bool list) (modified: ((expr * int) * expr) list list) (orig: expr list) =
-match active, modified, orig with
-| true::active_tl, e::modified_tl, _::orig_tl -> (List.assoc v e)::(select v active_tl modified_tl orig_tl)
-| false::active_tl, _::modified_tl, e::orig_tl -> e::(select v active_tl modified_tl orig_tl)
-| [], [], [] -> []
-| _ -> assert false
-
-let combine (f: expr list -> expr ) subs orig : ((expr * int) * expr) list =
- let elems = List.map (fun sub_i -> List.fold_right IdSet.add (List.map fst sub_i) IdSet.empty) subs in
- let all = List.fold_right IdSet.union elems IdSet.empty in
- List.map (fun v ->
- let active_subs = List.map (IdSet.mem v) elems in
- v, f (select v active_subs subs orig)
- ) (IdSet.elements all)
+let mk_pre n e = if n <= 0 then e else mkexpr e.expr_loc (Expr_pre e)
+(* let combine2 f sub1 sub2 = let elem_e1 = List.fold_right IdSet.add (List.map
+ fst sub1) IdSet.empty in let elem_e2 = List.fold_right IdSet.add (List.map
+ fst sub2) IdSet.empty in let common = IdSet.inter elem_e1 elem_e2 in let
+ sub1_filtered = List.filter (fun (v, _) -> not (IdSet.mem v common)) sub1 in
+ let sub2_filtered = List.filter (fun (v, _) -> not (IdSet.mem v common)) sub2
+ in (List.map (fun (v, negv) -> (v, f negv e2)) sub1_filtered) @ (List.map
+ (fun (v, negv) -> (v, f e1 negv)) sub2_filtered) @ (List.map (fun v -> (v,
+ {expr with expr_desc = Expr_arrow(List.assoc v sub1, List.assoc v sub2)})
+ (IdSet.elements common)) ) *)
-(* In a previous version, the printer was introducing fake
- description, ie tautologies, over inout variables to make sure they
- were not suppresed by some other algorithms *)
+let rec select (v : expr * int) (active : bool list)
+ (modified : ((expr * int) * expr) list list) (orig : expr list) =
+ match active, modified, orig with
+ | true :: active_tl, e :: modified_tl, _ :: orig_tl ->
+ List.assoc v e :: select v active_tl modified_tl orig_tl
+ | false :: active_tl, _ :: modified_tl, e :: orig_tl ->
+ e :: select v active_tl modified_tl orig_tl
+ | [], [], [] ->
+ []
+ | _ ->
+ assert false
-(* Takes the variable on which these coverage criteria will apply, as
- well as the expression and its negated version. Returns the expr
- and the variable expression, as well as the two new boolean
- expressions descibing the two associated modes. *)
+let combine (f : expr list -> expr) subs orig : ((expr * int) * expr) list =
+ let elems =
+ List.map
+ (fun sub_i -> List.fold_right IdSet.add (List.map fst sub_i) IdSet.empty)
+ subs
+ in
+ let all = List.fold_right IdSet.union elems IdSet.empty in
+ List.map
+ (fun v ->
+ let active_subs = List.map (IdSet.mem v) elems in
+ v, f (select v active_subs subs orig))
+ (IdSet.elements all)
+
+(* In a previous version, the printer was introducing fake description, ie
+ tautologies, over inout variables to make sure they were not suppresed by
+ some other algorithms *)
+
+(* Takes the variable on which these coverage criteria will apply, as well as
+ the expression and its negated version. Returns the expr and the variable
+ expression, as well as the two new boolean expressions descibing the two
+ associated modes. *)
let mcdc_var vi_as_expr nb_elems expr expr_neg_vi =
let loc = expr.expr_loc in
- let not_vi_as_expr = mkpredef_call loc "not" [vi_as_expr] in
+ let not_vi_as_expr = mkpredef_call loc "not" [ vi_as_expr ] in
let expr1, expr2 =
- if nb_elems > 1 then
- let changed_expr = mkpredef_call loc "!=" [expr; expr_neg_vi] in
- let expr1 = mkpredef_call loc "&&" [vi_as_expr; changed_expr] in
- let expr2 = mkpredef_call loc "&&" [not_vi_as_expr; changed_expr] in
+ if nb_elems > 1 then
+ let changed_expr = mkpredef_call loc "!=" [ expr; expr_neg_vi ] in
+ let expr1 = mkpredef_call loc "&&" [ vi_as_expr; changed_expr ] in
+ let expr2 = mkpredef_call loc "&&" [ not_vi_as_expr; changed_expr ] in
expr1, expr2
- else
- vi_as_expr, not_vi_as_expr
+ else vi_as_expr, not_vi_as_expr
in
- ((expr,vi_as_expr),[(true,expr1);(false,expr2)]) (* expr1 corresponds to atom
- true while expr2
- corresponds to atom
- false *)
+ (expr, vi_as_expr), [ true, expr1; false, expr2 ]
+(* expr1 corresponds to atom true while expr2 corresponds to atom false *)
+
+(* Format.printf "%a@." Printers.pp_expr expr1; *)
+(* print_path (fun fmt -> Format.fprintf fmt "%a and (%a != %a)" *)
+(* Printers.pp_expr vi_as_expr *)
+(* Printers.pp_expr expr (\*v*\) *)
+(* Printers.pp_expr expr_neg_vi); *)
+(* Format.printf "%a@." Printers.pp_expr expr2; *)
+(* print_path (fun fmt -> Format.fprintf fmt "(not %a) and (%a != %a)" *)
+(* Printers.pp_expr vi_as_expr *)
+(* Printers.pp_expr expr (\*v*\) *)
+(* Printers.pp_expr expr_neg_vi) *)
- (* Format.printf "%a@." Printers.pp_expr expr1; *)
- (* print_path (fun fmt -> Format.fprintf fmt "%a and (%a != %a)" *)
- (* Printers.pp_expr vi_as_expr *)
- (* Printers.pp_expr expr (\*v*\) *)
- (* Printers.pp_expr expr_neg_vi); *)
- (* Format.printf "%a@." Printers.pp_expr expr2; *)
- (* print_path (fun fmt -> Format.fprintf fmt "(not %a) and (%a != %a)" *)
- (* Printers.pp_expr vi_as_expr *)
- (* Printers.pp_expr expr (\*v*\) *)
- (* Printers.pp_expr expr_neg_vi) *)
-
-let rec compute_neg_expr cpt_pre (expr: Lustre_types.expr) =
- let neg_list l =
- List.fold_right (fun e (vl,el) -> let vl', e' = compute_neg_expr cpt_pre e in (vl'@vl), e'::el) l ([], [])
+let rec compute_neg_expr cpt_pre (expr : Lustre_types.expr) =
+ let neg_list l =
+ List.fold_right
+ (fun e (vl, el) ->
+ let vl', e' = compute_neg_expr cpt_pre e in
+ vl' @ vl, e' :: el)
+ l ([], [])
in
match expr.expr_desc with
- | Expr_tuple l ->
- let vl, neg = neg_list l in
- vl, combine (fun l' -> {expr with expr_desc = Expr_tuple l'}) neg l
-
- | Expr_ite (i,t,e) when (Types.is_bool_type t.expr_type) -> (
- let list = [i; t; e] in
+ | Expr_tuple l ->
+ let vl, neg = neg_list l in
+ vl, combine (fun l' -> { expr with expr_desc = Expr_tuple l' }) neg l
+ | Expr_ite (i, t, e) when Types.is_bool_type t.expr_type ->
+ let list = [ i; t; e ] in
let vl, neg = neg_list list in
- vl, combine (fun l ->
- match l with
- | [i'; t'; e'] -> {expr with expr_desc = Expr_ite(i', t', e')}
- | _ -> assert false
- ) neg list
- )
- | Expr_ite (i,t,e) -> ( (* We return the guard as a new guard *)
+ ( vl,
+ combine
+ (fun l ->
+ match l with
+ | [ i'; t'; e' ] ->
+ { expr with expr_desc = Expr_ite (i', t', e') }
+ | _ ->
+ assert false)
+ neg list )
+ | Expr_ite (i, t, e) ->
+ (* We return the guard as a new guard *)
let vl = gen_mcdc_cond_guard i in
- let list = [i; t; e] in
+ let list = [ i; t; e ] in
let vl', neg = neg_list list in
- vl@vl', combine (fun l ->
- match l with
- | [i'; t'; e'] -> {expr with expr_desc = Expr_ite(i', t', e')}
- | _ -> assert false
- ) neg list
- )
- | Expr_arrow (e1, e2) ->
- let vl1, e1' = compute_neg_expr cpt_pre e1 in
- let vl2, e2' = compute_neg_expr cpt_pre e2 in
- vl1@vl2, combine (fun l -> match l with
- | [x;y] -> { expr with expr_desc = Expr_arrow (x, y) }
- | _ -> assert false
- ) [e1'; e2'] [e1; e2]
-
+ ( vl @ vl',
+ combine
+ (fun l ->
+ match l with
+ | [ i'; t'; e' ] ->
+ { expr with expr_desc = Expr_ite (i', t', e') }
+ | _ ->
+ assert false)
+ neg list )
+ | Expr_arrow (e1, e2) ->
+ let vl1, e1' = compute_neg_expr cpt_pre e1 in
+ let vl2, e2' = compute_neg_expr cpt_pre e2 in
+ ( vl1 @ vl2,
+ combine
+ (fun l ->
+ match l with
+ | [ x; y ] ->
+ { expr with expr_desc = Expr_arrow (x, y) }
+ | _ ->
+ assert false)
+ [ e1'; e2' ] [ e1; e2 ] )
| Expr_pre e ->
- let vl, e' = compute_neg_expr (cpt_pre+1) e in
- vl, List.map
- (fun (v, negv) -> (v, { expr with expr_desc = Expr_pre negv } )) e'
-
+ let vl, e' = compute_neg_expr (cpt_pre + 1) e in
+ ( vl,
+ List.map (fun (v, negv) -> v, { expr with expr_desc = Expr_pre negv }) e'
+ )
| Expr_appl (op_name, _, _) when List.mem op_name rel_op ->
- [], [(expr, cpt_pre), mkpredef_call expr.expr_loc "not" [expr]]
-
+ [], [ (expr, cpt_pre), mkpredef_call expr.expr_loc "not" [ expr ] ]
| Expr_appl (op_name, args, r) ->
- let vl, args' = compute_neg_expr cpt_pre args in
- vl, List.map
- (fun (v, negv) -> (v, { expr with expr_desc = Expr_appl (op_name, negv, r) } ))
- args'
+ let vl, args' = compute_neg_expr cpt_pre args in
+ ( vl,
+ List.map
+ (fun (v, negv) ->
+ v, { expr with expr_desc = Expr_appl (op_name, negv, r) })
+ args' )
+ | Expr_ident _ when Types.is_bool_type expr.expr_type ->
+ [], [ (expr, cpt_pre), mkpredef_call expr.expr_loc "not" [ expr ] ]
+ | _ ->
+ [] (* empty vars *), []
- | Expr_ident _ when (Types.is_bool_type expr.expr_type) ->
- [], [(expr, cpt_pre), mkpredef_call expr.expr_loc "not" [expr]]
- | _ -> [] (* empty vars *) , []
and gen_mcdc_cond_var v expr =
report ~level:1 (fun fmt ->
- Format.fprintf fmt ".. Generating MC/DC cond for boolean flow %s and expression %a@."
- v
+ Format.fprintf fmt
+ ".. Generating MC/DC cond for boolean flow %s and expression %a@." v
Printers.pp_expr expr);
let vl, leafs_n_neg_expr = compute_neg_expr 0 expr in
- let len = List.length leafs_n_neg_expr in
- if len >= 1 then (
- List.fold_left (fun accu ((vi, nb_pre), expr_neg_vi) ->
- (mcdc_var (mk_pre nb_pre vi) len expr expr_neg_vi)::accu
- ) vl leafs_n_neg_expr
- )
- else
- vl
+ let len = List.length leafs_n_neg_expr in
+ if len >= 1 then
+ List.fold_left
+ (fun accu ((vi, nb_pre), expr_neg_vi) ->
+ mcdc_var (mk_pre nb_pre vi) len expr expr_neg_vi :: accu)
+ vl leafs_n_neg_expr
+ else vl
and gen_mcdc_cond_guard expr =
report ~level:1 (fun fmt ->
- Format.fprintf fmt".. Generating MC/DC cond for guard %a@."
+ Format.fprintf fmt ".. Generating MC/DC cond for guard %a@."
Printers.pp_expr expr);
let vl, leafs_n_neg_expr = compute_neg_expr 0 expr in
let len = List.length leafs_n_neg_expr in
- if len >= 1 then (
- List.fold_left (fun accu ((vi, nb_pre), expr_neg_vi) ->
- (mcdc_var (mk_pre nb_pre vi) len expr expr_neg_vi)::accu
- ) vl leafs_n_neg_expr)
- else
- vl
-
+ if len >= 1 then
+ List.fold_left
+ (fun accu ((vi, nb_pre), expr_neg_vi) ->
+ mcdc_var (mk_pre nb_pre vi) len expr expr_neg_vi :: accu)
+ vl leafs_n_neg_expr
+ else vl
-let rec mcdc_expr cpt_pre expr =
+let rec mcdc_expr cpt_pre expr =
match expr.expr_desc with
| Expr_tuple l ->
- let vl =
- List.fold_right (fun e accu_v ->
- let vl = mcdc_expr cpt_pre e in
- (vl@accu_v))
- l
- []
- in
- vl
- | Expr_ite (i,t,e) ->
- let vl_i = gen_mcdc_cond_guard i in
- let vl_t = mcdc_expr cpt_pre t in
- let vl_e = mcdc_expr cpt_pre e in
- vl_i@vl_t@vl_e
+ let vl =
+ List.fold_right
+ (fun e accu_v ->
+ let vl = mcdc_expr cpt_pre e in
+ vl @ accu_v)
+ l []
+ in
+ vl
+ | Expr_ite (i, t, e) ->
+ let vl_i = gen_mcdc_cond_guard i in
+ let vl_t = mcdc_expr cpt_pre t in
+ let vl_e = mcdc_expr cpt_pre e in
+ vl_i @ vl_t @ vl_e
| Expr_arrow (e1, e2) ->
- let vl1 = mcdc_expr cpt_pre e1 in
- let vl2 = mcdc_expr cpt_pre e2 in
- vl1@vl2
+ let vl1 = mcdc_expr cpt_pre e1 in
+ let vl2 = mcdc_expr cpt_pre e2 in
+ vl1 @ vl2
| Expr_pre e ->
- let vl = mcdc_expr (cpt_pre+1) e in
- vl
+ let vl = mcdc_expr (cpt_pre + 1) e in
+ vl
| Expr_appl (_, args, _) ->
- let vl = mcdc_expr cpt_pre args in
- vl
- | _ -> []
+ let vl = mcdc_expr cpt_pre args in
+ vl
+ | _ ->
+ []
-let mcdc_var_def v expr =
+let mcdc_var_def v expr =
if Types.is_bool_type expr.expr_type then
- let vl = gen_mcdc_cond_var v expr in
- vl
+ let vl = gen_mcdc_cond_var v expr in
+ vl
else
let vl = mcdc_expr 0 expr in
vl
-
+
let mcdc_node_eq eq =
let vl =
- match eq.eq_lhs, Types.is_bool_type eq.eq_rhs.expr_type, (Types.repr eq.eq_rhs.expr_type).Types.tdesc, eq.eq_rhs.expr_desc with
- | [lhs], true, _, _ -> gen_mcdc_cond_var lhs eq.eq_rhs
- | _::_, false, Types.Ttuple _, Expr_tuple rhs ->
- (* We iterate trough pairs, but accumulate variables aside. The resulting
- expression shall remain a tuple defintion *)
- let vl = List.fold_right2 (fun lhs rhs accu ->
- let v = mcdc_var_def lhs rhs in
- (* we don't care about the expression it. We focus on the coverage
- expressions in v *)
- v@accu
- ) eq.eq_lhs rhs []
- in
- vl
- | _ -> mcdc_expr 0 eq.eq_rhs
+ match
+ ( eq.eq_lhs,
+ Types.is_bool_type eq.eq_rhs.expr_type,
+ (Types.repr eq.eq_rhs.expr_type).Types.tdesc,
+ eq.eq_rhs.expr_desc )
+ with
+ | [ lhs ], true, _, _ ->
+ gen_mcdc_cond_var lhs eq.eq_rhs
+ | _ :: _, false, Types.Ttuple _, Expr_tuple rhs ->
+ (* We iterate trough pairs, but accumulate variables aside. The resulting
+ expression shall remain a tuple defintion *)
+ let vl =
+ List.fold_right2
+ (fun lhs rhs accu ->
+ let v = mcdc_var_def lhs rhs in
+ (* we don't care about the expression it. We focus on the coverage
+ expressions in v *)
+ v @ accu)
+ eq.eq_lhs rhs []
+ in
+ vl
+ | _ ->
+ mcdc_expr 0 eq.eq_rhs
in
vl
let mcdc_node_stmt stmt =
match stmt with
- | Eq eq -> let vl = mcdc_node_eq eq in vl
- | Aut _ -> assert false
+ | Eq eq ->
+ let vl = mcdc_node_eq eq in
+ vl
+ | Aut _ ->
+ assert false
-let mcdc_top_decl td =
+let mcdc_top_decl td =
match td.top_decl_desc with
| Node nd ->
- let new_coverage_exprs =
- List.fold_right (
- fun s accu_v ->
- let vl' = mcdc_node_stmt s in
- vl'@accu_v
- ) nd.node_stmts []
- in
- (* We add coverage vars as boolean internal flows. *)
- let fresh_cov_defs = List.flatten (List.map (fun ((_, atom), expr_l) -> List.map (fun (atom_valid, case) -> atom, atom_valid, case) expr_l) new_coverage_exprs) in
- let nb_total = List.length fresh_cov_defs in
- let fresh_cov_vars = List.mapi (fun i (atom, atom_valid, cov_expr) ->
- let loc = cov_expr.expr_loc in
- Format.fprintf Format.str_formatter "__cov_%i_%i" i nb_total;
- let cov_id = Format.flush_str_formatter () in
- let cov_var = mkvar_decl loc
- (cov_id, mktyp loc Tydec_bool, mkclock loc Ckdec_any, false, None, None) in
- let cov_def = Eq (mkeq loc ([cov_id], cov_expr)) in
- cov_var, cov_def, atom, atom_valid
- ) fresh_cov_defs
- in
- let fresh_vars, fresh_eqs =
- List.fold_right
- (fun (v,eq,_,_) (accuv, accueq)-> v::accuv, eq::accueq )
- fresh_cov_vars
- ([], [])
- in
- let fresh_annots = (* We produce two sets of annotations: PROPERTY ones for
- kind2, and regular ones to keep track of the nature
- of the annotations. *)
- List.map
- (fun (v, _, atom, atom_valid) ->
- let e = expr_of_vdecl v in
- let neg_ee = expr_to_eexpr (mkpredef_call e.expr_loc "not" [e]) in
- {annots = [["PROPERTY"], neg_ee; (* Using negated property to force
- model-checker to produce a
- suitable covering trace *)
- let loc = Location.dummy_loc in
- let valid_e = let open Corelang in mkexpr loc (Expr_const (const_of_bool atom_valid)) in
- ["coverage";"mcdc";v.var_id], expr_to_eexpr (Corelang.expr_of_expr_list loc [e; atom; valid_e])
- ];
- annot_loc = v.var_loc})
- fresh_cov_vars
- in
- Format.printf "%i coverage criteria generated for node %s@ " nb_total nd.node_id;
- (* And add them as annotations --%PROPERTY: var TODO *)
- {td with top_decl_desc = Node {nd with
- node_locals = nd.node_locals@fresh_vars;
- node_stmts = nd.node_stmts@fresh_eqs;
- node_annot = nd.node_annot@fresh_annots
- }}
- | _ -> td
-
+ let new_coverage_exprs =
+ List.fold_right
+ (fun s accu_v ->
+ let vl' = mcdc_node_stmt s in
+ vl' @ accu_v)
+ nd.node_stmts []
+ in
+ (* We add coverage vars as boolean internal flows. *)
+ let fresh_cov_defs =
+ List.flatten
+ (List.map
+ (fun ((_, atom), expr_l) ->
+ List.map (fun (atom_valid, case) -> atom, atom_valid, case) expr_l)
+ new_coverage_exprs)
+ in
+ let nb_total = List.length fresh_cov_defs in
+ let fresh_cov_vars =
+ List.mapi
+ (fun i (atom, atom_valid, cov_expr) ->
+ let loc = cov_expr.expr_loc in
+ Format.fprintf Format.str_formatter "__cov_%i_%i" i nb_total;
+ let cov_id = Format.flush_str_formatter () in
+ let cov_var =
+ mkvar_decl loc
+ ( cov_id,
+ mktyp loc Tydec_bool,
+ mkclock loc Ckdec_any,
+ false,
+ None,
+ None )
+ in
+ let cov_def = Eq (mkeq loc ([ cov_id ], cov_expr)) in
+ cov_var, cov_def, atom, atom_valid)
+ fresh_cov_defs
+ in
+ let fresh_vars, fresh_eqs =
+ List.fold_right
+ (fun (v, eq, _, _) (accuv, accueq) -> v :: accuv, eq :: accueq)
+ fresh_cov_vars ([], [])
+ in
+ let fresh_annots =
+ (* We produce two sets of annotations: PROPERTY ones for kind2, and
+ regular ones to keep track of the nature of the annotations. *)
+ List.map
+ (fun (v, _, atom, atom_valid) ->
+ let e = expr_of_vdecl v in
+ let neg_ee = expr_to_eexpr (mkpredef_call e.expr_loc "not" [ e ]) in
+ {
+ annots =
+ [
+ [ "PROPERTY" ], neg_ee;
+ (* Using negated property to force model-checker to produce a
+ suitable covering trace *)
+ (let loc = Location.dummy_loc in
+ let valid_e =
+ let open Corelang in
+ mkexpr loc (Expr_const (const_of_bool atom_valid))
+ in
+ ( [ "coverage"; "mcdc"; v.var_id ],
+ expr_to_eexpr
+ (Corelang.expr_of_expr_list loc [ e; atom; valid_e ]) ));
+ ];
+ annot_loc = v.var_loc;
+ })
+ fresh_cov_vars
+ in
+ Format.printf "%i coverage criteria generated for node %s@ " nb_total
+ nd.node_id;
+ (* And add them as annotations --%PROPERTY: var TODO *)
+ {
+ td with
+ top_decl_desc =
+ Node
+ {
+ nd with
+ node_locals = nd.node_locals @ fresh_vars;
+ node_stmts = nd.node_stmts @ fresh_eqs;
+ node_annot = nd.node_annot @ fresh_annots;
+ };
+ }
+ | _ ->
+ td
let mcdc prog =
- (* If main node is provided add silly constraints to show in/out variables in the path condition *)
- if !Options.main_node <> "" then (
- inout_vars :=
- let top = List.find
- (fun td ->
- match td.top_decl_desc with
- | Node nd when nd.node_id = !Options.main_node -> true
- | _ -> false)
- prog
- in
- match top.top_decl_desc with
- | Node nd -> nd.node_inputs @ nd.node_outputs
- | _ -> assert false);
+ (* If main node is provided add silly constraints to show in/out variables in
+ the path condition *)
+ (if !Options.main_node <> "" then
+ inout_vars :=
+ let top =
+ List.find
+ (fun td ->
+ match td.top_decl_desc with
+ | Node nd when nd.node_id = !Options.main_node ->
+ true
+ | _ ->
+ false)
+ prog
+ in
+ match top.top_decl_desc with
+ | Node nd ->
+ nd.node_inputs @ nd.node_outputs
+ | _ ->
+ assert false);
List.map mcdc_top_decl prog
-
-
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
-
-
diff --git a/src/plugins/mpfr/lustrec_mpfr.ml b/src/plugins/mpfr/lustrec_mpfr.ml
index ee728114c637d1d75d85648cdb649b4b151fd565..09387dfb294db62a48832bbb36a9580cd79e6eb0 100644
--- a/src/plugins/mpfr/lustrec_mpfr.ml
+++ b/src/plugins/mpfr/lustrec_mpfr.ml
@@ -17,10 +17,11 @@ open Normalization
open Machine_code_common
let report = Log.report ~plugin:"MPFR"
-
-let mpfr_module = mktop (Open(false, "mpfr_lustre"))
+
+let mpfr_module = mktop (Open (false, "mpfr_lustre"))
+
let cpt_fresh = ref 0
-
+
let mpfr_rnd () = "MPFR_RNDN"
let mpfr_prec () = !Options.mpfr_prec
@@ -41,214 +42,254 @@ 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 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 pp_val fmt (var, value) =
- Format.fprintf fmt "%s(%a, %a, %s);"
- inject_real_id
- pp_var var
- pp_val value
+ Format.fprintf fmt "%s(%a, %a, %s);" inject_real_id pp_var var pp_val 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 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
+ Format.fprintf fmt "%s(%a, %a, %s);" inject_copy_id pp_var var pp_var value
(mpfr_rnd ())
-let pp_inject_assign pp_var fmt (_, value as vv) =
- if is_const_value value
- then
- pp_inject_real pp_var pp_var fmt vv
- else
- pp_inject_copy pp_var fmt vv
+let pp_inject_assign pp_var fmt ((_, value) as vv) =
+ if is_const_value value then pp_inject_real pp_var pp_var fmt vv
+ else pp_inject_copy pp_var fmt vv
let pp_inject_init pp_var fmt var =
- Format.fprintf fmt "%s(%a, %i);"
- inject_init_id
- pp_var var
- (mpfr_prec ())
+ 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
+ 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"
+ | "+" ->
+ "MPFRPlus"
+ | "-" ->
+ "MPFRMinus"
+ | "*" ->
+ "MPFRTimes"
+ | "/" ->
+ "MPFRDiv"
+ | "uminus" ->
+ "MPFRUminus"
+ | "<=" ->
+ "MPFRLe"
+ | "<" ->
+ "MPFRLt"
+ | ">=" ->
+ "MPFRGe"
+ | ">" ->
+ "MPFRGt"
+ | "=" ->
+ "MPFREq"
+ | "!=" ->
+ "MPFRNeq"
(* Conv functions *)
- | "int_to_real" -> "MPFRint_to_real"
- | "real_to_int" -> "MPFRreal_to_int"
- | "_floor" -> "MPFRfloor"
- | "_ceil" -> "MPFRceil"
- | "_round" -> "MPFRround"
- | "_Floor" -> "MPFRFloor"
- | "_Ceiling" -> "MPFRCeiling"
- | "_Round" -> "MPFRRound"
-
+ | "int_to_real" ->
+ "MPFRint_to_real"
+ | "real_to_int" ->
+ "MPFRreal_to_int"
+ | "_floor" ->
+ "MPFRfloor"
+ | "_ceil" ->
+ "MPFRceil"
+ | "_round" ->
+ "MPFRround"
+ | "_Floor" ->
+ "MPFRFloor"
+ | "_Ceiling" ->
+ "MPFRCeiling"
+ | "_Round" ->
+ "MPFRRound"
(* Math library functions *)
- | "acos" -> "MPFRacos"
- | "acosh" -> "MPFRacosh"
- | "asin" -> "MPFRasin"
- | "asinh" -> "MPFRasinh"
- | "atan" -> "MPFRatan"
- | "atan2" -> "MPFRatan2"
- | "atanh" -> "MPFRatanh"
- | "cbrt" -> "MPFRcbrt"
- | "cos" -> "MPFRcos"
- | "cosh" -> "MPFRcosh"
- | "ceil" -> "MPFRceil"
- | "erf" -> "MPFRerf"
- | "exp" -> "MPFRexp"
- | "fabs" -> "MPFRfabs"
- | "floor" -> "MPFRfloor"
- | "fmod" -> "MPFRfmod"
- | "log" -> "MPFRlog"
- | "log10" -> "MPFRlog10"
- | "pow" -> "MPFRpow"
- | "round" -> "MPFRround"
- | "sin" -> "MPFRsin"
- | "sinh" -> "MPFRsinh"
- | "sqrt" -> "MPFRsqrt"
- | "trunc" -> "MPFRtrunc"
- | "tan" -> "MPFRtan"
- | _ -> raise Not_found
+ | "acos" ->
+ "MPFRacos"
+ | "acosh" ->
+ "MPFRacosh"
+ | "asin" ->
+ "MPFRasin"
+ | "asinh" ->
+ "MPFRasinh"
+ | "atan" ->
+ "MPFRatan"
+ | "atan2" ->
+ "MPFRatan2"
+ | "atanh" ->
+ "MPFRatanh"
+ | "cbrt" ->
+ "MPFRcbrt"
+ | "cos" ->
+ "MPFRcos"
+ | "cosh" ->
+ "MPFRcosh"
+ | "ceil" ->
+ "MPFRceil"
+ | "erf" ->
+ "MPFRerf"
+ | "exp" ->
+ "MPFRexp"
+ | "fabs" ->
+ "MPFRfabs"
+ | "floor" ->
+ "MPFRfloor"
+ | "fmod" ->
+ "MPFRfmod"
+ | "log" ->
+ "MPFRlog"
+ | "log10" ->
+ "MPFRlog10"
+ | "pow" ->
+ "MPFRpow"
+ | "round" ->
+ "MPFRround"
+ | "sin" ->
+ "MPFRsin"
+ | "sinh" ->
+ "MPFRsinh"
+ | "sqrt" ->
+ "MPFRsqrt"
+ | "trunc" ->
+ "MPFRtrunc"
+ | "tan" ->
+ "MPFRtan"
+ | _ ->
+ raise Not_found
let inject_op id =
- report ~level:3 (fun fmt -> Format.fprintf fmt "trying to inject mpfr into function %s@." id);
- try
- base_inject_op id
- with Not_found -> id
+ report ~level:3 (fun fmt ->
+ Format.fprintf fmt "trying to inject mpfr into function %s@." 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 []
+ 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 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_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
+ | _ ->
+ 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 ();
+ {
+ 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
+ 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> *)
+(* inject_<foo> : defs * used vars -> <foo> -> (updated defs * updated vars) *
+ normalized <foo> *)
let 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
+ 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 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) 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, [])
-
+ 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 inject_eq node defvars eq =
- let (defs', vars'), norm_rhs = inject_expr ~alias:false node defvars eq.eq_rhs in
+ 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'
+ norm_eq :: defs', vars'
(* let inject_eexpr ee =
* { ee with eexpr_qfexpr = inject_expr ee.eexpr_qfexpr }
@@ -264,75 +305,73 @@ let inject_eq node defvars eq =
* }
* ) s.modes
* } *)
-
-(** normalize_node node returns a normalized node,
- ie.
- - updated locals
- - new equations
- -
-*)
-let inject_node node =
+
+(** 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 norm_ctx = (node.node_id, get_node_vars node) in
- let is_local v =
- List.for_all ((!=) v) inputs_outputs in
- let orig_vars = inputs_outputs@node.node_locals in
+ let inputs_outputs = node.node_inputs @ node.node_outputs in
+ let norm_ctx = node.node_id, get_node_vars node in
+ let is_local v = List.for_all (( != ) v) inputs_outputs in
+ let orig_vars = inputs_outputs @ node.node_locals in
let defs, vars =
let eqs, auts = get_node_eqs node in
- if auts != [] then assert false; (* Automata should be expanded by now. *)
- List.fold_left (inject_eq norm_ctx) ([], orig_vars) eqs in
+ if auts != [] then assert false;
+ (* Automata should be expanded by now. *)
+ List.fold_left (inject_eq norm_ctx) ([], orig_vars) eqs
+ in
(* Normalize the asserts *)
let vars, assert_defs, _ =
- 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
- norm_ctx
- ([], vars) (* defvar only contains vars *)
- assert_expr
- in
- vars', defs@def_accu, {assert_ with assert_expr = expr}::assert_accu
- ) (vars, [], []) node.node_asserts in
+ 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 norm_ctx ([], 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 *)
+ (* 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 *)
(* See comment below
* let spec = match node.node_spec with
* | None -> None
* | Some spec -> Some (inject_spec spec)
* in *)
let node =
- { node with
- node_locals = new_locals;
- node_stmts = List.map (fun eq -> Eq eq) (defs @ assert_defs);
- (* Incomplete work: TODO. Do we have to inject MPFR code here?
- Does it make sense for annotations? For me, only if we produce
- C code for annotations. Otherwise the various verification
- backend should have their own understanding, but would not
- necessarily require this additional normalization. *)
- (*
- node_spec = spec;
- node_annot = List.map (fun ann -> {ann with
- annots = List.map (fun (ids, ee) -> ids, inject_eexpr ee) ann.annots}
- ) node.node_annot *)
- }
- in ((*Printers.pp_node Format.err_formatter node;*) node)
+ {
+ node with
+ node_locals = new_locals;
+ node_stmts =
+ List.map (fun eq -> Eq eq) (defs @ assert_defs)
+ (* Incomplete work: TODO. Do we have to inject MPFR code here? Does it
+ make sense for annotations? For me, only if we produce C code for
+ annotations. Otherwise the various verification backend should have
+ their own understanding, but would not necessarily require this
+ additional normalization. *)
+ (* node_spec = spec; node_annot = List.map (fun ann -> {ann with annots
+ = List.map (fun (ids, ee) -> ids, inject_eexpr ee) ann.annots} )
+ node.node_annot *);
+ }
+ 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)}
- | Include _ | Open _ | ImportedNode _ | Const _ | TypeDef _ -> decl
-
-let inject_prog decls =
- List.map inject_decl decls
+ { decl with top_decl_desc = Node (inject_node nd) }
+ | Include _ | Open _ | ImportedNode _ | Const _ | TypeDef _ ->
+ decl
+let inject_prog decls = List.map inject_decl decls
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/plugins/pluginType.ml b/src/plugins/pluginType.ml
index 100b4ff21f14c6ec69d8a899250cceab13d8bf60..4de83163ee801a2bf9c38325df02e82eb8535f9f 100644
--- a/src/plugins/pluginType.ml
+++ b/src/plugins/pluginType.ml
@@ -1,23 +1,37 @@
-module type S =
-sig
- val name: string
- val activate: unit -> unit
- val usage: Format.formatter -> unit
- val options: (string * Arg.spec * string) list
- val init: unit -> unit
+module type S = sig
+ val name : string
+
+ val activate : unit -> unit
+
+ val usage : Format.formatter -> unit
+
+ val options : (string * Arg.spec * string) list
+
+ val init : unit -> unit
+
val check_force_stateful : unit -> bool
- val refine_machine_code: Lustre_types.top_decl list ->
- Machine_code_types.machine_t list -> Machine_code_types.machine_t list
- val c_backend_main_loop_body_prefix : string -> string -> Format.formatter -> unit -> unit
- val c_backend_main_loop_body_suffix : Format.formatter -> unit -> unit
+
+ val refine_machine_code :
+ Lustre_types.top_decl list ->
+ Machine_code_types.machine_t list ->
+ Machine_code_types.machine_t list
+
+ val c_backend_main_loop_body_prefix :
+ string -> string -> Format.formatter -> unit -> unit
+
+ val c_backend_main_loop_body_suffix : Format.formatter -> unit -> unit
end
-module Default =
- 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
+module Default = 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
diff --git a/src/plugins/plugins.ml b/src/plugins/plugins.ml
index e7e9689d34c66f7596cf7351f85d15d7fba0e325..9b16e882c32021fb2582981eac652a47059fe5ce 100644
--- a/src/plugins/plugins.ml
+++ b/src/plugins/plugins.ml
@@ -1,71 +1,79 @@
open Lustre_types
-
open PluginList
let () = Sites.Plugins.Plugins.load_all ()
-let options () =
- List.flatten (
- List.map Options_management.plugin_opt (
- List.map (fun m ->
- let module M = (val m : PluginType.S) in
- (M.name, M.activate, M.usage, M.options)
- ) (plugins ())
- ))
+let options () =
+ List.flatten
+ (List.map Options_management.plugin_opt
+ (List.map
+ (fun m ->
+ let module M = (val m : PluginType.S) in
+ M.name, M.activate, M.usage, M.options)
+ (plugins ())))
let init () =
- List.iter (fun m ->
+ List.iter
+ (fun m ->
let module M = (val m : PluginType.S) in
- M.init ()
- ) (plugins ())
-
+ M.init ())
+ (plugins ())
+
let check_force_stateful () =
- List.exists (fun m ->
- let module M = (val m : PluginType.S) in
- M.check_force_stateful ()
- ) (plugins ())
+ List.exists
+ (fun m ->
+ let module M = (val m : PluginType.S) 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.S) in
- M.refine_machine_code prog accu
- ) machine_code (plugins ())
-
+ List.fold_left
+ (fun accu m ->
+ let module M = (val m : PluginType.S) in
+ M.refine_machine_code prog accu)
+ machine_code (plugins ())
-let c_backend_main_loop_body_prefix basename mname fmt () =
- List.iter (fun (m: (module PluginType.S)) ->
- let module M = (val m : PluginType.S) in
- M.c_backend_main_loop_body_prefix basename mname fmt ()) (plugins ())
+let c_backend_main_loop_body_prefix basename mname fmt () =
+ List.iter
+ (fun (m : (module PluginType.S)) ->
+ let module M = (val m : PluginType.S) in
+ M.c_backend_main_loop_body_prefix basename mname fmt ())
+ (plugins ())
-let c_backend_main_loop_body_suffix fmt () =
- List.iter (fun (m: (module PluginType.S)) ->
- let module M = (val m : PluginType.S) in
- M.c_backend_main_loop_body_suffix fmt ()) (plugins ())
+let c_backend_main_loop_body_suffix fmt () =
+ List.iter
+ (fun (m : (module PluginType.S)) ->
+ let module M = (val m : PluginType.S) in
+ M.c_backend_main_loop_body_suffix fmt ())
+ (plugins ())
(* Specific treatment of annotations when inlining, specific of declared plugins *)
let inline_annots rename_var_fun annot_list =
- List.map (
- fun ann ->
- { ann with
- annots = List.fold_left (
- fun accu (sl, eexpr) ->
- let items =
- match sl with
- | plugin_name::args ->
- if plugin_name = "salsa" then
- match args with
- | ["ranges";varname] ->
- [["salsa";"ranges";(rename_var_fun varname)], eexpr]
- | _ -> [(sl, eexpr)]
- else
- [(sl, eexpr)]
- | _ -> assert false
- in
- items@accu
- ) [] ann.annots
- }
- ) annot_list
+ List.map
+ (fun ann ->
+ {
+ ann with
+ annots =
+ List.fold_left
+ (fun accu (sl, eexpr) ->
+ let items =
+ match sl with
+ | plugin_name :: args ->
+ if plugin_name = "salsa" then
+ match args with
+ | [ "ranges"; varname ] ->
+ [ [ "salsa"; "ranges"; rename_var_fun varname ], eexpr ]
+ | _ ->
+ [ sl, eexpr ]
+ else [ sl, eexpr ]
+ | _ ->
+ assert false
+ in
+ items @ accu)
+ [] ann.annots;
+ })
+ annot_list
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/plugins/salsa/dune b/src/plugins/salsa/dune
index 70fbbfff5fd9420aa6a5ac713947eeda4ee064bf..cdec3fbf26e3dc3d337c414e08588f76c85e2451 100644
--- a/src/plugins/salsa/dune
+++ b/src/plugins/salsa/dune
@@ -9,5 +9,6 @@
(plugin
(name salsa_plugin)
(libraries lustrec.salsa_plugin)
- (site (lustrec plugins))
+ (site
+ (lustrec plugins))
(optional))
diff --git a/src/plugins/salsa/machine_salsa_opt.ml b/src/plugins/salsa/machine_salsa_opt.ml
index f5e106391673c82ea744e3bc01824427de78f4e7..0a6b32bd3579d55b8a5e7104ede7a7a1f9d0ce1e 100644
--- a/src/plugins/salsa/machine_salsa_opt.ml
+++ b/src/plugins/salsa/machine_salsa_opt.ml
@@ -6,81 +6,90 @@ module MC = Machine_code
(* Datatype for Salsa: FormalEnv, Ranges, Var set ... *)
open SalsaDatatypes
-
-let report = Log.report ~plugin:"salsa" ~verbose_level:Salsa.Log.verbose_level
+
+let report = Log.report ~plugin:"salsa" ~verbose_level:Salsa.Log.verbose_level
+
(******************************************************************)
(* TODO Xavier: should those functions be declared more globally? *)
-let fun_types node =
+let fun_types node =
try
- match node.LT.top_decl_desc with
- | LT.Node nd ->
+ match node.LT.top_decl_desc with
+ | LT.Node nd ->
let tin, tout = Types.split_arrow nd.LT.node_type in
Types.type_list_of_type tin, Types.type_list_of_type tout
- | _ -> Format.eprintf "%a is not a node@.@?" Printers.pp_decl node; assert false
- with Not_found -> Format.eprintf "Unable to find type def for function %s@.@?" (Corelang.node_name node); assert false
-
-let called_node_id m id =
+ | _ ->
+ Format.eprintf "%a is not a node@.@?" Printers.pp_decl node;
+ assert false
+ with Not_found ->
+ Format.eprintf "Unable to find type def for function %s@.@?"
+ (Corelang.node_name node);
+ assert false
+
+let called_node_id m id =
let td, _ =
- try
- List.assoc id m.MT.mcalls (* TODO Xavier: mcalls or minstances ? *)
+ try List.assoc id m.MT.mcalls (* TODO Xavier: mcalls or minstances ? *)
with Not_found -> assert false
in
td
-(******************************************************************)
+(******************************************************************)
(* Returns the set of vars that appear in the expression *)
let rec get_expr_real_vars e =
- let open MT in
+ let open MT in
match e.value_desc with
- | Var v when Types.is_real_type v.LT.var_type -> Vars.singleton v
- | Var _
- | Cst _ -> Vars.empty
- | Fun (_, args) ->
- List.fold_left
- (fun acc e -> Vars.union acc (get_expr_real_vars e))
+ | Var v when Types.is_real_type v.LT.var_type ->
+ Vars.singleton v
+ | Var _ | Cst _ ->
+ Vars.empty
+ | Fun (_, args) ->
+ List.fold_left
+ (fun acc e -> Vars.union acc (get_expr_real_vars e))
Vars.empty args
- | Array _
- | Access _
- | Power _ -> assert false
+ | Array _ | Access _ | Power _ ->
+ assert false
(* Extract the variables to appear as free variables in expressions (lhs) *)
let rec get_read_vars instrs =
let open MT in
match instrs with
- [] -> Vars.empty
- | i::tl -> (
- let vars_tl = get_read_vars tl in
+ | [] ->
+ Vars.empty
+ | i :: tl -> (
+ let vars_tl = get_read_vars tl in
match Corelang.get_instr_desc i with
- | MLocalAssign(_,e)
- | MStateAssign(_,e) -> Vars.union (get_expr_real_vars e) vars_tl
- | MStep(_, _, el) -> List.fold_left (fun accu e -> Vars.union (get_expr_real_vars e) accu) vars_tl el
- | MBranch(e, branches) -> (
+ | MLocalAssign (_, e) | MStateAssign (_, e) ->
+ Vars.union (get_expr_real_vars e) vars_tl
+ | MStep (_, _, el) ->
+ List.fold_left
+ (fun accu e -> Vars.union (get_expr_real_vars e) accu)
+ vars_tl el
+ | MBranch (e, branches) ->
let vars = Vars.union (get_expr_real_vars e) vars_tl in
- List.fold_left (fun vars (_, b) -> Vars.union vars (get_read_vars b) ) vars branches
- )
- | MReset _
- | MNoReset _
- | MSpec _ | MComment _ -> Vars.empty
- )
+ List.fold_left
+ (fun vars (_, b) -> Vars.union vars (get_read_vars b))
+ vars branches
+ | MReset _ | MNoReset _ | MSpec _ | MComment _ ->
+ Vars.empty)
let rec get_written_vars instrs =
let open MT in
match instrs with
- [] -> Vars.empty
- | i::tl -> (
- let vars_tl = get_written_vars tl in
+ | [] ->
+ Vars.empty
+ | i :: tl -> (
+ let vars_tl = get_written_vars tl in
match Corelang.get_instr_desc i with
- | MLocalAssign(v,_)
- | MStateAssign(v,_) -> Vars.add v vars_tl
- | MStep(vdl, _, _) -> List.fold_left (fun accu v -> Vars.add v accu) vars_tl vdl
- | MBranch(_, branches) -> (
- List.fold_left (fun vars (_, b) -> Vars.union vars (get_written_vars b) ) vars_tl branches
- )
- | MReset _
- | MNoReset _
- | MSpec _ | MComment _ -> Vars.empty
- )
+ | MLocalAssign (v, _) | MStateAssign (v, _) ->
+ Vars.add v vars_tl
+ | MStep (vdl, _, _) ->
+ List.fold_left (fun accu v -> Vars.add v accu) vars_tl vdl
+ | MBranch (_, branches) ->
+ List.fold_left
+ (fun vars (_, b) -> Vars.union vars (get_written_vars b))
+ vars_tl branches
+ | MReset _ | MNoReset _ | MSpec _ | MComment _ ->
+ Vars.empty)
(* let rec iterTransformExpr fresh_id e_salsa abstractEnv old_range = *)
(* let new_expr, new_range = *)
@@ -88,165 +97,169 @@ let rec get_written_vars instrs =
(* in *)
(* Format.eprintf "New range: %a@." RangesInt.pp_val new_range; *)
(* if Salsa.Float.errLt new_range old_range < 0 then *)
-
+
(* iterTransformExpr fresh_id new_expr abstractEnv new_range *)
(* else *)
(* new_expr, new_range *)
-
(* 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 *)
+ try
+ let fresh_id = "toto" in
+ (* TODO more meaningful name *)
let abstractEnv = RangesInt.to_abstract_env ranges in
- report ~level:2 (fun fmt -> Format.fprintf fmt
- "Launching analysis: %s@ "
- (Salsa.Print.printExpression e_salsa));
- let new_e_salsa, e_val =
+ report ~level:2 (fun fmt ->
+ Format.fprintf fmt "Launching analysis: %s@ "
+ (Salsa.Print.printExpression e_salsa));
+ let new_e_salsa, e_val =
Salsa.MainEPEG.transformExpression fresh_id e_salsa abstractEnv
in
- 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 " Analysis done: %s@ "
+ (Salsa.Print.printExpression new_e_salsa));
(* (\* Debug *\) *)
(* Format.eprintf "Salsa:@.input expr: %s@.outputexpr: %s@." *)
(* (Salsa.Print.printExpression e_salsa) *)
(* (Salsa.Print.printExpression new_e_salsa); *)
(* (\* Debug *\) *)
-
- report ~level:2 (fun fmt -> Format.fprintf fmt " Computing range progress@ ");
+ report ~level:2 (fun fmt ->
+ Format.fprintf fmt " Computing range progress@ ");
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 report ~level:2 (fun fmt ->
- Format.fprintf fmt "No improvement on abstract value %a@ " RangesInt.pp_val e_val;
- );
- e_salsa, Some old_val
- )
- | false, true -> (
- if !debug then report ~level:2 (fun fmt ->
- Format.fprintf fmt "Improved!@ ";
- );
- new_e_salsa, Some e_val
- )
+ 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
+ report ~level:2 (fun fmt ->
+ Format.fprintf fmt "No improvement on abstract value %a@ "
+ RangesInt.pp_val e_val);
+ e_salsa, Some old_val
+ | false, true ->
+ if !debug then
+ report ~level:2 (fun fmt -> Format.fprintf fmt "Improved!@ ");
+ new_e_salsa, Some e_val
| true, false ->
- report ~level:2 (fun fmt ->
- Format.fprintf fmt
- "CAREFUL --- new range is worse!. Restoring provided expression@ ");
- e_salsa, Some old_val
-
- | false, false -> (
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);
-
- new_e_salsa, Some e_val
- (* assert false *)
- )
+ "CAREFUL --- new range is worse!. Restoring provided expression@ ");
+ e_salsa, Some old_val
+ | false, false ->
+ 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);
+
+ new_e_salsa, Some e_val
+ (* assert false *)
in
report ~level:2 (fun fmt -> Format.fprintf fmt " Computing range done@ ");
- if !debug then 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;
- );
+ if !debug then
+ 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 _ -> (
+ with (* Not_found -> *)
+ | Salsa.Epeg_types.EPEGError _ ->
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 *));
+ 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 =
+(* 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 =
let rec opt_expr m vars_env ranges formalEnv e =
let open MT in
match e.value_desc with
| Cst cst ->
- (* Format.eprintf "optmizing constant expr @ "; *)
- (* the expression is a constant, we optimize it directly if it is a real
- constant *)
- let typ = Typing.type_const Location.dummy_loc cst in
- if Types.is_real_type typ then
- opt_num_expr m vars_env ranges formalEnv e
- else e, None, [], Vars.empty
- | Var v ->
- if not (Vars.mem v printed_vars) &&
- (* 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)
- then
- opt_num_expr m vars_env ranges formalEnv e
- else
- e, None, [], Vars.empty (* Nothing to optimize for expressions containing a single non real variable *)
+ (* Format.eprintf "optmizing constant expr @ "; *)
+ (* the expression is a constant, we optimize it directly if it is a real
+ constant *)
+ let typ = Typing.type_const Location.dummy_loc cst in
+ if Types.is_real_type typ then opt_num_expr m vars_env ranges formalEnv e
+ else e, None, [], Vars.empty
+ | Var v ->
+ if
+ (not (Vars.mem v printed_vars))
+ && (* 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)
+ then opt_num_expr m vars_env ranges formalEnv e
+ else e, None, [], Vars.empty
+ (* Nothing to optimize for expressions containing a single non real variable *)
(* (\* optimize only numerical vars *\) *)
- (* if Type_predef.is_real_type v.LT.var_type then opt_num_expr ranges formalEnv e *)
+ (* if Type_predef.is_real_type v.LT.var_type then opt_num_expr ranges
+ formalEnv e *)
(* else e, None *)
- | Fun (fun_id, args) -> (
- (* necessarily, this is a basic function (ie. + - * / && || mod ... ) *)
- (* if the return type is real then optimize it, otherwise call recusrsively on arguments *)
- if Types.is_real_type e.value_type then
- opt_num_expr m vars_env ranges formalEnv e
- else (
- (* We do not care for computed local ranges. *)
- let args', il, new_locals =
- List.fold_right (
- fun arg (al, il, nl) ->
- let arg', _, arg_il, arg_nl =
- opt_expr m 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
- )
- )
- | Array _
- | Access _
- | Power _ -> assert false
- and opt_num_expr m vars_env ranges formalEnv e =
- if !debug then (
- report ~level:2 (fun fmt -> Format.fprintf fmt "Optimizing expression @[<hov>%a@]@ "
- (MC.pp_val m) e);
- );
- (* if !debug then Format.eprintf "Optimizing expression %a with Salsa@ " MC.pp_val e; *)
+ | Fun (fun_id, args) ->
+ if
+ (* necessarily, this is a basic function (ie. + - * / && || mod ... ) *)
+ (* if the return type is real then optimize it, otherwise call
+ recusrsively on arguments *)
+ Types.is_real_type e.value_type
+ then opt_num_expr m vars_env ranges formalEnv e
+ else
+ (* We do not care for computed local ranges. *)
+ let args', il, new_locals =
+ List.fold_right
+ (fun arg (al, il, nl) ->
+ let arg', _, arg_il, arg_nl =
+ opt_expr m 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
+ | Array _ | Access _ | Power _ ->
+ assert false
+ and opt_num_expr m vars_env ranges formalEnv e =
+ if !debug then
+ report ~level:2 (fun fmt ->
+ Format.fprintf fmt "Optimizing expression @[<hov>%a@]@ " (MC.pp_val m)
+ e);
+ (* if !debug then Format.eprintf "Optimizing expression %a with Salsa@ "
+ MC.pp_val e; *)
(* Convert expression *)
- (* List.iter (fun (l,c) -> Format.eprintf "%s -> %a@ " l Printers.pp_const c) constEnv; *)
+ (* List.iter (fun (l,c) -> Format.eprintf "%s -> %a@ " l Printers.pp_const
+ c) constEnv; *)
let e_salsa : Salsa.Types.expression = value_t2salsa_expr constEnv e in
- (* Format.eprintf "apres deplaige constantes ok%a @." MC.pp_val (salsa_expr2value_t vars_env [](\* constEnv *\) e_salsa) ; *)
+
+ (* Format.eprintf "apres deplaige constantes ok%a @." MC.pp_val
+ (salsa_expr2value_t vars_env [](\* constEnv *\) e_salsa) ; *)
(* Convert formalEnv *)
- (* if !debug then Format.eprintf "Formal env is [%a]@ " FormalEnv.pp formalEnv; *)
+ (* if !debug then Format.eprintf "Formal env is [%a]@ " FormalEnv.pp
+ formalEnv; *)
(* if !debug then Format.eprintf "Formal env converted to salsa@ "; *)
- (* Format.eprintf "Expression avant et apres substVars.@.Avant %a@." MC.pp_val (salsa_expr2value_t vars_env [] e_salsa) ; *)
+ (* Format.eprintf "Expression avant et apres substVars.@.Avant %a@."
+ MC.pp_val (salsa_expr2value_t vars_env [] e_salsa) ; *)
(* Substitute all occurences of variables by their definition in env *)
- let (e_salsa: Salsa.Types.expression), _ =
- Salsa.Rewrite.substVars
- e_salsa
- (FormalEnv.to_salsa constEnv formalEnv)
- 0 (* TODO: Nasrine, what is this integer value for ? *)
+ let (e_salsa : Salsa.Types.expression), _ =
+ Salsa.Rewrite.substVars e_salsa (FormalEnv.to_salsa constEnv formalEnv) 0
+ (* TODO: Nasrine, what is this integer value for ? *)
in
- (* Format.eprintf "Apres %a@." MC.pp_val (salsa_expr2value_t vars_env [] e_salsa) ; *)
+ (* Format.eprintf "Apres %a@." MC.pp_val (salsa_expr2value_t vars_env []
+ e_salsa) ; *)
(* if !debug then Format.eprintf "Substituted def in expr@ "; *)
let abstractEnv = RangesInt.to_abstract_env ranges in
@@ -256,226 +269,245 @@ let optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv e :
garde evalPartExpr remplace les variables e qui sont dans env par la cst
- on garde *)
(* if !debug then Format.eprintf "avant avant eval part@ "; *)
- (* Format.eprintf "avant evalpart: %a@." MC.pp_val (salsa_expr2value_t vars_env constEnv e_salsa); *)
- let e_salsa =
- Salsa.Analyzer.evalPartExpr
- e_salsa
- (Salsa.Analyzer.valEnv2ExprEnv abstractEnv)
- ([] (* no blacklisted variables *))
- ([] (* no arrays *))
+ (* Format.eprintf "avant evalpart: %a@." MC.pp_val (salsa_expr2value_t
+ vars_env constEnv e_salsa); *)
+ let e_salsa =
+ Salsa.Analyzer.evalPartExpr e_salsa
+ (Salsa.Analyzer.valEnv2ExprEnv abstractEnv)
+ [] (* no blacklisted variables *) []
+ (* no arrays *)
in
- (* Format.eprintf "apres evalpart: %a@." MC.pp_val (salsa_expr2value_t vars_env constEnv e_salsa); *)
- (* Checking if we have all necessary information *)
+ (* Format.eprintf "apres evalpart: %a@." MC.pp_val (salsa_expr2value_t
+ vars_env constEnv e_salsa); *)
+ (* Checking if we have all necessary information *)
let free_vars = get_salsa_free_vars vars_env constEnv abstractEnv e_salsa in
if Vars.cardinal free_vars > 0 then (
- 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);
-
- (* if !debug then Log.report ~level:2 (fun fmt -> Format.fprintf fmt "Formal env was @[<v 0>%a@]@ " FormalEnv.pp formalEnv); *)
-
-
- let new_e = try salsa_expr2value_t vars_env constEnv e_salsa with Not_found -> assert false in
- new_e, None, [] , Vars.empty
- )
+ 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);
+
+ (* if !debug then Log.report ~level:2 (fun fmt -> Format.fprintf fmt
+ "Formal env was @[<v 0>%a@]@ " FormalEnv.pp formalEnv); *)
+ let new_e =
+ try salsa_expr2value_t vars_env constEnv e_salsa
+ with Not_found -> assert false
+ in
+ new_e, None, [], Vars.empty)
else (
-
if !debug then
- 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.node_id, []) (* TODO check that the empty env is ok. One may need to build or access to the current env *)
- 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
- abstract Env with computed ranges *)
- 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
- ([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 (
- 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 ?
- ====
-
- let new_e = try salsa_expr2value_t vars_env' constEnv new_e_salsa with Not_found -> assert false in
- if !debug then Log.report ~level:2 (fun fmt ->
- let old_range = Salsa.Analyzer.evalExpr e_salsa abstractEnv [] in
- match RangesInt.Value.leq old_range e_val, RangesInt.Value.leq e_val old_range with
- | true, true -> Format.fprintf fmt "No improvement on abstract value %a@ " RangesInt.pp_val e_val
- | true, false -> (
- Format.fprintf fmt "Improved!";
- Format.fprintf fmt
- " @[<v>old_expr: @[<v 0>%a@ range: %a@]@ new_expr: @[<v 0>%a@ range: %a@]@ @]@ "
- (MC.pp_val m) e
- RangesInt.pp_val (Salsa.Analyzer.evalExpr e_salsa abstractEnv [])
- (MC.pp_val m) new_e
- RangesInt.pp_val e_val
- )
- | false, true -> Format.eprintf "Error; new range is worse!@.@?"; assert false
- | false, false -> Format.eprintf "Error; new range is not comparabe with old end. This should not happen!@.@?"; assert false
- );
- new_e, Some e_val, List.rev rev_def_tmp_instrs
- with (* Not_found -> *)
- | Salsa.Epeg_types.EPEGError _ -> (
- Log.report ~level:2 (fun fmt -> Format.fprintf fmt "BECAUSE OF AN ERROR, Expression %a was not optimized@ " (MC.pp_val m) e);
- e, None, []
- )
->>>>>>> unstable
- *)
- )
-
-
-
+ 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.node_id, [])
+ (* TODO check that the empty env is ok. One may need to build or
+ access to the current env *)
+ Location.dummy_loc e.MT.value_type (Clocks.new_var true)
+ in
+
+ let vs' = VarEnv.add id { 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
+ abstract Env with computed ranges *)
+ 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
+ ([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
+ 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 ? ====
+
+ let new_e = try salsa_expr2value_t vars_env' constEnv new_e_salsa with
+ Not_found -> assert false in if !debug then Log.report ~level:2 (fun
+ fmt -> let old_range = Salsa.Analyzer.evalExpr e_salsa abstractEnv []
+ in match RangesInt.Value.leq old_range e_val, RangesInt.Value.leq e_val
+ old_range with | true, true -> Format.fprintf fmt "No improvement on
+ abstract value %a@ " RangesInt.pp_val e_val | true, false -> (
+ Format.fprintf fmt "Improved!"; Format.fprintf fmt " @[<v>old_expr:
+ @[<v 0>%a@ range: %a@]@ new_expr: @[<v 0>%a@ range: %a@]@ @]@ "
+ (MC.pp_val m) e RangesInt.pp_val (Salsa.Analyzer.evalExpr e_salsa
+ abstractEnv []) (MC.pp_val m) new_e RangesInt.pp_val e_val ) | false,
+ true -> Format.eprintf "Error; new range is worse!@.@?"; assert false |
+ false, false -> Format.eprintf "Error; new range is not comparabe with
+ old end. This should not happen!@.@?"; assert false ); new_e, Some
+ e_val, List.rev rev_def_tmp_instrs with (* Not_found -> *) |
+ Salsa.Epeg_types.EPEGError _ -> ( Log.report ~level:2 (fun fmt ->
+ Format.fprintf fmt "BECAUSE OF AN ERROR, Expression %a was not
+ optimized@ " (MC.pp_val m) e); e, None, [] ) >>>>>>> unstable *))
in
- opt_expr m vars_env ranges formalEnv e
-
-
+
+ opt_expr m vars_env ranges formalEnv e
+
(* Returns a list of assign, for each var in vars_to_print, that produce the
definition of it according to formalEnv, and driven by the ranges. *)
-let assign_vars nodename m constEnv vars_env printed_vars ranges formalEnv vars_to_print =
+let assign_vars nodename m constEnv vars_env printed_vars ranges formalEnv
+ vars_to_print =
(* We print thhe expression in the order of definition *)
-
- let ordered_vars =
+ let ordered_vars =
List.stable_sort
- (FormalEnv.get_sort_fun formalEnv)
- (Vars.elements vars_to_print)
+ (FormalEnv.get_sort_fun formalEnv)
+ (Vars.elements vars_to_print)
in
- if !debug then report ~level:4 (fun fmt -> Format.fprintf fmt
- "Printing vars in the following order: [%a]@ "
- (Utils.fprintf_list ~sep:", " Printers.pp_var) ordered_vars);
-
- List.fold_right (
- fun v (accu_instr, accu_ranges, accu_new_locals) ->
- 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:4 (fun fmt ->
+ Format.fprintf fmt "Printing vars in the following order: [%a]@ "
+ (Utils.fprintf_list ~sep:", " Printers.pp_var)
+ ordered_vars);
+
+ List.fold_right
+ (fun v (accu_instr, accu_ranges, accu_new_locals) ->
+ if !debug then
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "Printing assign for variable %s@ " v.LT.var_id);
try
- (* Obtaining unfold expression of v in formalEnv *)
- let v_def = FormalEnv.get_def formalEnv v in
- let e, r, il, new_v_locals =
- optimize_expr nodename m constEnv printed_vars vars_env ranges formalEnv v_def
- in
- let instr_desc =
- if try (get_var vars_env v.LT.var_id).is_local with Not_found -> assert false then
- MT.MLocalAssign(v, e)
- else
- MT.MStateAssign(v, e)
- 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)
- with FormalEnv.NoDefinition _ -> (
- (* It should not happen with C backend, but may happen with Lustre backend *)
- if !Options.output = "lustre" then accu_instr, ranges, Vars.empty else (Format.eprintf "@?"; assert false)
- )
- ) ordered_vars ([], ranges, Vars.empty)
+ (* Obtaining unfold expression of v in formalEnv *)
+ let v_def = FormalEnv.get_def formalEnv v in
+ let e, r, il, new_v_locals =
+ optimize_expr nodename m constEnv printed_vars vars_env ranges
+ formalEnv v_def
+ in
+ let instr_desc =
+ if
+ try (get_var vars_env v.LT.var_id).is_local
+ with Not_found -> assert false
+ then MT.MLocalAssign (v, e)
+ else MT.MStateAssign (v, e)
+ 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 )
+ with FormalEnv.NoDefinition _ ->
+ if
+ (* It should not happen with C backend, but may happen with Lustre
+ backend *)
+ !Options.output = "lustre"
+ then accu_instr, ranges, Vars.empty
+ else (
+ Format.eprintf "@?";
+ assert false))
+ ordered_vars ([], ranges, Vars.empty)
(* Main recursive function: modify the instructions list while preserving the
order of assigns for state variables. Returns a quintuple: (new_instrs,
ranges, formalEnv, printed_vars, and remaining vars to be printed) *)
-let rec rewrite_instrs nodename m constEnv vars_env m instrs ranges formalEnv printed_vars vars_to_print =
+let rec rewrite_instrs nodename m constEnv vars_env m instrs ranges formalEnv
+ printed_vars vars_to_print =
let formal_env_def = FormalEnv.def constEnv vars_env in
(* Format.eprintf "Rewrite intrs : [%a]@." MC.pp_instrs instrs; *)
let assign_vars = assign_vars nodename m constEnv vars_env in
@@ -487,378 +519,421 @@ let rec rewrite_instrs nodename m constEnv vars_env m instrs ranges formalEnv p
(* FormalEnv.pp formalEnv) *)
(* ); *)
match instrs with
- | [] ->
- (* End of instruction list: we produce the definition of each variable that
- appears in vars_to_print. Each of them should be defined in formalEnv *)
- (* if !debug then Format.eprintf "Producing definitions %a@ " Vars.pp vars_to_print; *)
- let instrs, ranges', new_expr_locals = assign_vars printed_vars ranges formalEnv vars_to_print in
- instrs,
- ranges',
- formalEnv,
- Vars.union printed_vars vars_to_print, (* We should have printed all required vars *)
- [], (* No more vars to be printed *)
- Vars.empty
-
- | hd_instr::tl_instrs ->
- (* We reformulate hd_instr, producing or not a fresh instruction, updating
- formalEnv, possibly ranges and vars_to_print *)
- begin
- let hd_instrs, ranges, formalEnv, printed_vars, vars_to_print, hd_new_locals =
- match Corelang.get_instr_desc hd_instr with
- | MT.MLocalAssign(vd,vt) when Types.is_real_type vd.LT.var_type && not (Vars.mem vd vars_to_print) ->
- (* LocalAssign are injected into formalEnv *)
- (* if !debug then Format.eprintf "Registering local assign %a@ " MC.pp_instr hd_instr; *)
- (* if !debug then Format.eprintf "%a@ " MC.pp_instr hd_instr; *)
- let formalEnv' = formal_env_def formalEnv vd vt in (* formelEnv updated with vd = vt *)
- [], (* no instr generated *)
- ranges, (* no new range computed *)
- formalEnv',
- printed_vars, (* no new printed vars *)
- vars_to_print, (* no more or less variables to print *)
- Vars.empty (* no new locals *)
-
- | MT.MLocalAssign(vd,vt) when Types.is_real_type vd.LT.var_type && Vars.mem vd vars_to_print ->
-
- (* if !debug then Format.eprintf "Registering and producing state assign %a@ " MC.pp_instr hd_instr; *)
- (* if !debug then Format.eprintf "Registering and producing state assign %a@ " MC.pp_instr hd_instr; *)
- (* if !debug then ( *)
- (* Format.eprintf "%a@ " MC.pp_instr hd_instr; *)
- (* Format.eprintf "Selected var %a: producing expression@ " Printers.pp_var vd; *)
- (* ); *)
- let formalEnv' = formal_env_def formalEnv vd vt in (* formelEnv updated with vd = vt *)
- let instrs', ranges', expr_new_locals = (* printing vd = optimized vt *)
- assign_vars printed_vars ranges formalEnv' (Vars.singleton vd)
- in
- instrs',
- ranges', (* no new range computed *)
- 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 *)
-
- | MT.MStateAssign(vd,vt) when Types.is_real_type vd.LT.var_type (* && Vars.mem vd vars_to_print *)->
-
- (* StateAssign are produced since they are required by the function. We still
- keep their definition in the formalEnv in case it can optimize later
- outputs. vd is removed from remaining vars_to_print *)
- (* if !debug then Format.eprintf "Registering and producing state assign %a@ " MC.pp_instr hd_instr; *)
- (* if !debug then ( *)
- (* Format.eprintf "%a@ " MC.pp_instr hd_instr; *)
- (* Format.eprintf "State assign %a: producing expression@ " Printers.pp_var vd; *)
- (* ); *)
- let formalEnv' = formal_env_def formalEnv vd vt in (* formelEnv updated with vd = vt *)
- let instrs', ranges', expr_new_locals = (* printing vd = optimized vt *)
- assign_vars printed_vars ranges formalEnv' (Vars.singleton vd)
- in
- instrs',
- ranges', (* no new range computed *)
- 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 *)
-
- | (MT.MLocalAssign(vd,vt) | MT.MStateAssign(vd,vt)) ->
- (* Format.eprintf "other assign %a@." MC.pp_instr hd_instr; *)
-
- (* We have to produce the instruction. But we may have to produce as
- well its dependencies *)
- let required_vars = get_expr_real_vars vt in
- let required_vars = Vars.diff required_vars printed_vars in (* remove
- already
- produced
- variables *)
- (* Format.eprintf "Required vars: %a@." Vars.pp required_vars; *)
- let required_vars = Vars.diff required_vars (Vars.of_list m.MT.mmemory) in
- let prefix_instr, ranges, new_expr_dep_locals =
- assign_vars printed_vars ranges formalEnv required_vars in
-
- let vt', _, il, expr_new_locals = optimize_expr nodename m constEnv (Vars.union required_vars printed_vars) vars_env ranges formalEnv vt in
- let new_instr =
- match Corelang.get_instr_desc hd_instr with
- | MT.MLocalAssign _ -> Corelang.update_instr_desc hd_instr (MT.MLocalAssign(vd,vt'))
- | _ -> Corelang.update_instr_desc hd_instr (MT.MStateAssign(vd,vt'))
- in
- let written_vars = Vars.add vd required_vars in
- prefix_instr@il@[new_instr],
- ranges, (* no new range computed *)
- formalEnv, (* formelEnv untouched *)
- Vars.union written_vars printed_vars, (* adding vd + dependencies to
- new printed vars *)
- Vars.diff vars_to_print written_vars, (* removed vd + dependencies from
- variables to print *)
- (Vars.union new_expr_dep_locals expr_new_locals)
- | MT.MStep(vdl,id,vtl) ->
- (* Format.eprintf "step@."; *)
-
- (* if !debug then Format.eprintf "Call to a node %a@ " MC.pp_instr hd_instr; *)
- (* Call of an external function. Input expressions have to be
- optimized, their free variables produced. A fresh range has to be
- computed for each output variable in vdl. Output of the function
- call are removed from vars to be printed *)
- let node = called_node_id m id in
- let node_id = Corelang.node_name node in
- let tin, tout = (* special care for arrow *)
- if node_id = "_arrow" then
- match vdl with
- | [v] -> let t = v.LT.var_type in
- [t; t], [t]
- | _ -> assert false (* should not happen *)
- else
- fun_types node
- in
- (* if !debug then Format.eprintf "@[<v 2>... optimizing arguments@ "; *)
- let vtl', vtl_ranges, il, args_new_locals = List.fold_right2 (
- fun e typ_e (exprl, range_l, il_l, new_locals)->
- if Types.is_real_type typ_e then
- 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
- else
- e::exprl, None::range_l, il_l, new_locals
- ) vtl tin ([], [], [], Vars.empty)
- in
- (* if !debug then Format.eprintf "... done@ @]@ "; *)
-
-
-
- (* let required_vars = *)
- (* List.fold_left2 *)
- (* (fun accu e typ_e -> *)
- (* if Types.is_real_type typ_e then *)
- (* Vars.union accu (get_expr_real_vars e) *)
- (* else (\* we do not consider non real expressions *\) *)
- (* accu *)
- (* ) *)
- (* Vars.empty *)
- (* vtl' tin *)
- (* in *)
- (* if !debug then Format.eprintf "Required vars: [%a]@ Printed vars: [%a]@ Remaining required vars: [%a]@ " *)
- (* Vars.pp required_vars *)
- (* Vars.pp printed_vars *)
- (* Vars.pp (Vars.diff required_vars printed_vars) *)
- (* ; *)
- (* let required_vars = Vars.diff required_vars printed_vars in (\* remove *)
- (* already *)
- (* produced *)
- (* variables *\) *)
- (* let written_vars = Vars.union required_vars (Vars.of_list vdl) in *)
- (* let instrs', ranges' = assign_vars (Vars.union written_vars printed_vars) ranges formalEnv required_vars in *)
-
- (* instrs' @ [Corelang.update_instr_desc hd_instr (MT.MStep(vdl,id,vtl'))], (* New instrs *) *)
-
- let written_vars = Vars.of_list vdl in
-
-
-
- il @ [Corelang.update_instr_desc hd_instr (MT.MStep(vdl,id,vtl'))], (* New instrs *)
- RangesInt.add_call ranges vdl id vtl_ranges, (* add information bounding each vdl var *)
- formalEnv,
- Vars.union written_vars printed_vars, (* adding vdl to new printed vars *)
- Vars.diff vars_to_print written_vars,
- args_new_locals
-
- | MT.MBranch(vt, branches) ->
-
- (* Required variables to compute vt are introduced.
- Then each branch is refactored specifically
- *)
-
- (* if !debug then Format.eprintf "Branching %a@ " MC.pp_instr hd_instr; *)
- 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 prefix_instr, ranges = *)
- (* assign_vars (Vars.union required_vars printed_vars) ranges formalEnv required_vars in *)
-
- let printed_vars = Vars.union printed_vars required_vars in
-
-
- let read_vars_tl = get_read_vars tl_instrs in
- (* if !debug then Format.eprintf "@[<v 2>Dealing with branches@ "; *)
- 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_write_vars = get_written_vars b_instrs in
- let b_vars_to_print = Vars.inter b_write_vars (Vars.union read_vars_tl vars_to_print) in
- let b_fe = formalEnv in (* because of side effect
- data, we copy it for
- each branch *)
- let b_instrs', b_ranges, b_formalEnv, b_printed, b_vars, b_new_locals =
- rewrite_instrs nodename m constEnv vars_env m b_instrs ranges b_fe printed_vars b_vars_to_print
- in
- (* b_vars should be empty *)
- let _ = if b_vars != [] then assert false in
-
- (* Producing the refactored branch *)
- (b_l, b_instrs') :: new_branches,
- Vars.union b_printed written_vars, (* They should coincides. We
- use union instead of
- inter to ease the
- bootstrap *)
- RangesInt.merge merged_ranges b_ranges,
- Vars.union new_locals b_new_locals
-
- ) branches ([], required_vars, ranges, new_locals)
- in
- (* if !debug then Format.eprintf "dealing with branches done@ @]@ "; *)
- prefix_instr@[Corelang.update_instr_desc hd_instr (MT.MBranch(vt', branches'))],
- 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
-
-
- | MT.MReset(_) | MT.MNoReset _ | MT.MSpec _ | MT.MComment _ ->
- (* if !debug then Format.eprintf "Untouched %a (non real)@ " MC.pp_instr hd_instr; *)
-
- (* Untouched instruction *)
- [ hd_instr ], (* unmodified instr *)
- 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 *)
-
- in
- let tl_instrs, ranges, formalEnv, printed_vars, vars_to_print, tl_new_locals =
- rewrite_instrs
- nodename
- m
- constEnv
- vars_env
- m
- tl_instrs
- ranges
- formalEnv
- printed_vars
- vars_to_print
-
- in
- hd_instrs @ tl_instrs,
- ranges,
- formalEnv,
- printed_vars,
- vars_to_print,
- (Vars.union hd_new_locals tl_new_locals)
- end
+ | [] ->
+ (* End of instruction list: we produce the definition of each variable that
+ appears in vars_to_print. Each of them should be defined in formalEnv *)
+ (* if !debug then Format.eprintf "Producing definitions %a@ " Vars.pp
+ vars_to_print; *)
+ let instrs, ranges', new_expr_locals =
+ assign_vars printed_vars ranges formalEnv vars_to_print
+ in
+ ( instrs,
+ ranges',
+ formalEnv,
+ Vars.union printed_vars vars_to_print,
+ (* We should have printed all required vars *)
+ [],
+ (* No more vars to be printed *)
+ Vars.empty )
+ | hd_instr :: tl_instrs ->
+ (* We reformulate hd_instr, producing or not a fresh instruction, updating
+ formalEnv, possibly ranges and vars_to_print *)
+ let hd_instrs, ranges, formalEnv, printed_vars, vars_to_print, hd_new_locals
+ =
+ match Corelang.get_instr_desc hd_instr with
+ | MT.MLocalAssign (vd, vt)
+ when Types.is_real_type vd.LT.var_type
+ && not (Vars.mem vd vars_to_print) ->
+ (* LocalAssign are injected into formalEnv *)
+ (* if !debug then Format.eprintf "Registering local assign %a@ "
+ MC.pp_instr hd_instr; *)
+ (* if !debug then Format.eprintf "%a@ " MC.pp_instr hd_instr; *)
+ let formalEnv' = formal_env_def formalEnv vd vt in
+ (* formelEnv updated with vd = vt *)
+ ( [],
+ (* no instr generated *)
+ ranges,
+ (* no new range computed *)
+ formalEnv',
+ printed_vars,
+ (* no new printed vars *)
+ vars_to_print,
+ (* no more or less variables to print *)
+ Vars.empty )
+ (* no new locals *)
+ | MT.MLocalAssign (vd, vt)
+ when Types.is_real_type vd.LT.var_type && Vars.mem vd vars_to_print ->
+ (* if !debug then Format.eprintf "Registering and producing state assign
+ %a@ " MC.pp_instr hd_instr; *)
+ (* if !debug then Format.eprintf "Registering and producing state assign
+ %a@ " MC.pp_instr hd_instr; *)
+ (* if !debug then ( *)
+ (* Format.eprintf "%a@ " MC.pp_instr hd_instr; *)
+ (* Format.eprintf "Selected var %a: producing expression@ "
+ Printers.pp_var vd; *)
+ (* ); *)
+ let formalEnv' = formal_env_def formalEnv vd vt in
+ (* formelEnv updated with vd = vt *)
+ let instrs', ranges', expr_new_locals =
+ (* printing vd = optimized vt *)
+ assign_vars printed_vars ranges formalEnv' (Vars.singleton vd)
+ in
+ ( instrs',
+ ranges',
+ (* no new range computed *)
+ 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 *)
+ | MT.MStateAssign (vd, vt)
+ when Types.is_real_type vd.LT.var_type
+ (* && Vars.mem vd vars_to_print *) ->
+ (* StateAssign are produced since they are required by the function. We
+ still keep their definition in the formalEnv in case it can optimize
+ later outputs. vd is removed from remaining vars_to_print *)
+ (* if !debug then Format.eprintf "Registering and producing state assign
+ %a@ " MC.pp_instr hd_instr; *)
+ (* if !debug then ( *)
+ (* Format.eprintf "%a@ " MC.pp_instr hd_instr; *)
+ (* Format.eprintf "State assign %a: producing expression@ "
+ Printers.pp_var vd; *)
+ (* ); *)
+ let formalEnv' = formal_env_def formalEnv vd vt in
+ (* formelEnv updated with vd = vt *)
+ let instrs', ranges', expr_new_locals =
+ (* printing vd = optimized vt *)
+ assign_vars printed_vars ranges formalEnv' (Vars.singleton vd)
+ in
+ ( instrs',
+ ranges',
+ (* no new range computed *)
+ 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 *)
+ | MT.MLocalAssign (vd, vt) | MT.MStateAssign (vd, vt) ->
+ (* Format.eprintf "other assign %a@." MC.pp_instr hd_instr; *)
+
+ (* We have to produce the instruction. But we may have to produce as
+ well its dependencies *)
+ let required_vars = get_expr_real_vars vt in
+ let required_vars = Vars.diff required_vars printed_vars in
+ (* remove already produced variables *)
+ (* Format.eprintf "Required vars: %a@." Vars.pp required_vars; *)
+ let required_vars =
+ Vars.diff required_vars (Vars.of_list m.MT.mmemory)
+ in
+ let prefix_instr, ranges, new_expr_dep_locals =
+ assign_vars printed_vars ranges formalEnv required_vars
+ in
+ let vt', _, il, expr_new_locals =
+ optimize_expr nodename m constEnv
+ (Vars.union required_vars printed_vars)
+ vars_env ranges formalEnv vt
+ in
+ let new_instr =
+ match Corelang.get_instr_desc hd_instr with
+ | MT.MLocalAssign _ ->
+ Corelang.update_instr_desc hd_instr (MT.MLocalAssign (vd, vt'))
+ | _ ->
+ Corelang.update_instr_desc hd_instr (MT.MStateAssign (vd, vt'))
+ in
+ let written_vars = Vars.add vd required_vars in
+ ( prefix_instr @ il @ [ new_instr ],
+ ranges,
+ (* no new range computed *)
+ formalEnv,
+ (* formelEnv untouched *)
+ Vars.union written_vars printed_vars,
+ (* adding vd + dependencies to new printed vars *)
+ Vars.diff vars_to_print written_vars,
+ (* removed vd + dependencies from variables to print *)
+ Vars.union new_expr_dep_locals expr_new_locals )
+ | MT.MStep (vdl, id, vtl) ->
+ (* Format.eprintf "step@."; *)
+
+ (* if !debug then Format.eprintf "Call to a node %a@ " MC.pp_instr
+ hd_instr; *)
+ (* Call of an external function. Input expressions have to be optimized,
+ their free variables produced. A fresh range has to be computed for
+ each output variable in vdl. Output of the function call are removed
+ from vars to be printed *)
+ let node = called_node_id m id in
+ let node_id = Corelang.node_name node in
+ let tin, tout =
+ (* special care for arrow *)
+ if node_id = "_arrow" then
+ match vdl with
+ | [ v ] ->
+ let t = v.LT.var_type in
+ [ t; t ], [ t ]
+ | _ ->
+ assert false (* should not happen *)
+ else fun_types node
+ in
+ (* if !debug then Format.eprintf "@[<v 2>... optimizing arguments@ "; *)
+ let vtl', vtl_ranges, il, args_new_locals =
+ List.fold_right2
+ (fun e typ_e (exprl, range_l, il_l, new_locals) ->
+ if Types.is_real_type typ_e then
+ 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 )
+ else e :: exprl, None :: range_l, il_l, new_locals)
+ vtl tin ([], [], [], Vars.empty)
+ in
+ (* if !debug then Format.eprintf "... done@ @]@ "; *)
+
+ (* let required_vars = *)
+ (* List.fold_left2 *)
+ (* (fun accu e typ_e -> *)
+ (* if Types.is_real_type typ_e then *)
+ (* Vars.union accu (get_expr_real_vars e) *)
+ (* else (\* we do not consider non real expressions *\) *)
+ (* accu *)
+ (* ) *)
+ (* Vars.empty *)
+ (* vtl' tin *)
+ (* in *)
+ (* if !debug then Format.eprintf "Required vars: [%a]@ Printed vars:
+ [%a]@ Remaining required vars: [%a]@ " *)
+ (* Vars.pp required_vars *)
+ (* Vars.pp printed_vars *)
+ (* Vars.pp (Vars.diff required_vars printed_vars) *)
+ (* ; *)
+ (* let required_vars = Vars.diff required_vars printed_vars in (\* remove *)
+ (* already *)
+ (* produced *)
+ (* variables *\) *)
+ (* let written_vars = Vars.union required_vars (Vars.of_list vdl) in *)
+ (* let instrs', ranges' = assign_vars (Vars.union written_vars
+ printed_vars) ranges formalEnv required_vars in *)
+
+ (* instrs' @ [Corelang.update_instr_desc hd_instr
+ (MT.MStep(vdl,id,vtl'))], (* New instrs *) *)
+ let written_vars = Vars.of_list vdl in
+
+ ( il @ [ Corelang.update_instr_desc hd_instr (MT.MStep (vdl, id, vtl')) ],
+ (* New instrs *)
+ RangesInt.add_call ranges vdl id vtl_ranges,
+ (* add information bounding each vdl var *)
+ formalEnv,
+ Vars.union written_vars printed_vars,
+ (* adding vdl to new printed vars *)
+ Vars.diff vars_to_print written_vars,
+ args_new_locals )
+ | MT.MBranch (vt, branches) ->
+ (* Required variables to compute vt are introduced. Then each branch is
+ refactored specifically *)
+
+ (* if !debug then Format.eprintf "Branching %a@ " MC.pp_instr hd_instr; *)
+ 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 prefix_instr, ranges = *)
+ (* assign_vars (Vars.union required_vars printed_vars) ranges formalEnv
+ required_vars in *)
+ let printed_vars = Vars.union printed_vars required_vars in
+
+ let read_vars_tl = get_read_vars tl_instrs in
+ (* if !debug then Format.eprintf "@[<v 2>Dealing with branches@ "; *)
+ 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_write_vars = get_written_vars b_instrs in
+ let b_vars_to_print =
+ Vars.inter b_write_vars (Vars.union read_vars_tl vars_to_print)
+ in
+ let b_fe = formalEnv in
+ (* because of side effect data, we copy it for each branch *)
+ let ( b_instrs',
+ b_ranges,
+ b_formalEnv,
+ b_printed,
+ b_vars,
+ b_new_locals ) =
+ rewrite_instrs nodename m constEnv vars_env m b_instrs ranges
+ b_fe printed_vars b_vars_to_print
+ in
+ (* b_vars should be empty *)
+ let _ = if b_vars != [] then assert false in
+
+ (* Producing the refactored branch *)
+ ( (b_l, b_instrs') :: new_branches,
+ Vars.union b_printed written_vars,
+ (* They should coincides. We use union instead of inter to ease
+ the bootstrap *)
+ RangesInt.merge merged_ranges b_ranges,
+ Vars.union new_locals b_new_locals ))
+ branches
+ ([], required_vars, ranges, new_locals)
+ in
+ (* if !debug then Format.eprintf "dealing with branches done@ @]@ "; *)
+ ( prefix_instr
+ @ [
+ Corelang.update_instr_desc hd_instr (MT.MBranch (vt', branches'));
+ ],
+ 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 )
+ | MT.MReset _ | MT.MNoReset _ | MT.MSpec _ | MT.MComment _ ->
+ (* if !debug then Format.eprintf "Untouched %a (non real)@ " MC.pp_instr
+ hd_instr; *)
+
+ (* Untouched instruction *)
+ ( [ hd_instr ],
+ (* unmodified instr *)
+ 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 *)
+ in
+ let tl_instrs, ranges, formalEnv, printed_vars, vars_to_print, tl_new_locals
+ =
+ rewrite_instrs nodename m constEnv vars_env m tl_instrs ranges formalEnv
+ printed_vars vars_to_print
+ in
+ ( hd_instrs @ tl_instrs,
+ ranges,
+ formalEnv,
+ printed_vars,
+ vars_to_print,
+ Vars.union hd_new_locals tl_new_locals )
(* TODO: deal with new variables, ie. tmp *)
-let salsaStep constEnv m s =
- let ranges = RangesInt.empty (* empty for the moment, should be build from
- machine annotations or externally provided information *) in
- let annots = List.fold_left (
- fun accu annl ->
- List.fold_left (
- fun accu (key, range) ->
- match key with
- | ["salsa"; "ranges"; var] -> (var, range)::accu
- | _ -> accu
- ) accu annl.LT.annots
- ) [] m.MT.mannot
+let salsaStep constEnv m s =
+ let ranges =
+ RangesInt.empty
+ (* empty for the moment, should be build from machine annotations or
+ externally provided information *)
in
- let ranges =
- List.fold_left (fun ranges (v, value) ->
- match value.LT.eexpr_qfexpr.LT.expr_desc with
- | LT.Expr_tuple [minv; maxv] -> (
- let get_cst e = match e.LT.expr_desc with
- | LT.Expr_const (LT.Const_real r) ->
- (* calculer la valeur c * 10^e *)
- Real.to_num r
- | _ ->
- Format.eprintf
- "Invalid salsa range: %a. It should be a pair of constant floats and %a is not a float.@."
- Printers.pp_expr value.LT.eexpr_qfexpr
- Printers.pp_expr e
- ;
- assert false
- in
- (* let minv = Salsa.Float.Domain.of_num (get_cst minv) and *)
- (* maxv = Salsa.Float.Domain.of_num (get_cst maxv) in *)
- (* if !debug then Format.eprintf "variable %s in [%s, %s]@ " v (Num.string_of_num minv) (Num.string_of_num maxv); *)
- RangesInt.enlarge ranges v (Salsa.Float.Domain.inject_nums (get_cst minv) (get_cst maxv))
- )
- | _ ->
- Format.eprintf
- "Invalid salsa range: %a. It should be a pair of floats.@."
- Printers.pp_expr value.LT.eexpr_qfexpr;
- assert false
- ) ranges annots
+ let annots =
+ List.fold_left
+ (fun accu annl ->
+ List.fold_left
+ (fun accu (key, range) ->
+ match key with
+ | [ "salsa"; "ranges"; var ] ->
+ (var, range) :: accu
+ | _ ->
+ accu)
+ accu annl.LT.annots)
+ [] m.MT.mannot
+ in
+ let ranges =
+ List.fold_left
+ (fun ranges (v, value) ->
+ match value.LT.eexpr_qfexpr.LT.expr_desc with
+ | LT.Expr_tuple [ minv; maxv ] ->
+ let get_cst e =
+ match e.LT.expr_desc with
+ | LT.Expr_const (LT.Const_real r) ->
+ (* calculer la valeur c * 10^e *)
+ Real.to_num r
+ | _ ->
+ Format.eprintf
+ "Invalid salsa range: %a. It should be a pair of constant \
+ floats and %a is not a float.@."
+ Printers.pp_expr value.LT.eexpr_qfexpr Printers.pp_expr e;
+ assert false
+ in
+ (* let minv = Salsa.Float.Domain.of_num (get_cst minv) and *)
+ (* maxv = Salsa.Float.Domain.of_num (get_cst maxv) in *)
+ (* if !debug then Format.eprintf "variable %s in [%s, %s]@ " v
+ (Num.string_of_num minv) (Num.string_of_num maxv); *)
+ RangesInt.enlarge ranges v
+ (Salsa.Float.Domain.inject_nums (get_cst minv) (get_cst maxv))
+ | _ ->
+ Format.eprintf
+ "Invalid salsa range: %a. It should be a pair of floats.@."
+ Printers.pp_expr value.LT.eexpr_qfexpr;
+ assert false)
+ ranges annots
in
let formal_env = FormalEnv.empty () in
let vars_to_print =
- Vars.real_vars
- (
- Vars.union
- (Vars.of_list m.MT.mmemory)
- (Vars.of_list s.MT.step_outputs)
- )
- in
+ Vars.real_vars
+ (Vars.union (Vars.of_list m.MT.mmemory) (Vars.of_list s.MT.step_outputs))
+ in
+
(* TODO: should be at least step output + may be memories *)
-
- let vars_env = compute_vars_env m in
- (* if !debug then Format.eprintf "@[<v 2>Registering node equations@ "; *)
- let new_instrs, _, _, printed_vars, _, new_locals =
- rewrite_instrs
- m.MT.mname
- m
- constEnv
- vars_env
- m
- s.MT.step_instrs
- ranges
+ let vars_env = compute_vars_env m in
+ (* if !debug then Format.eprintf "@[<v 2>Registering node equations@ "; *)
+ let new_instrs, _, _, printed_vars, _, new_locals =
+ rewrite_instrs m.MT.mname m constEnv vars_env m s.MT.step_instrs ranges
formal_env
- (Vars.real_vars (Vars.of_list s.MT.step_inputs (* printed_vars : real
- inputs are considered as
- already printed *)))
+ (Vars.real_vars
+ (Vars.of_list
+ s.MT.step_inputs
+ (* printed_vars : real inputs are considered as already printed *)))
vars_to_print
-
in
+
let all_local_vars = Vars.real_vars (Vars.of_list s.MT.step_locals) in
- let unused = (Vars.diff all_local_vars printed_vars) in
+ let unused = Vars.diff all_local_vars printed_vars in
let locals =
if not (Vars.is_empty unused) then (
- if !debug then report ~level:2 (fun fmt -> Format.fprintf fmt "Unused local vars: [%a]. Removing them.@ "
- Vars.pp unused);
- List.filter (fun v -> not (Vars.mem v unused)) s.MT.step_locals
- )
- else
- s.MT.step_locals
+ if !debug then
+ report ~level:2 (fun fmt ->
+ Format.fprintf fmt "Unused local vars: [%a]. Removing them.@ "
+ Vars.pp unused);
+ List.filter (fun v -> not (Vars.mem v unused)) s.MT.step_locals)
+ else s.MT.step_locals
in
- let locals = locals @ Vars.elements new_locals in
- { s with MT.step_instrs = new_instrs; MT.step_locals = locals } (* we have also to modify local variables to declare new vars *)
+ let locals = locals @ Vars.elements new_locals in
+ { s with MT.step_instrs = new_instrs; MT.step_locals = locals }
+(* we have also to modify local variables to declare new vars *)
-
-let machine_t2machine_t_optimized_by_salsa constEnv mt =
+let machine_t2machine_t_optimized_by_salsa constEnv mt =
try
- if !debug then report ~level:2 (fun fmt -> Format.fprintf fmt "@[<v 3>Optimizing machine %s@ " mt.MT.mname.LT.node_id);
- let new_step = salsaStep constEnv mt mt.MT.mstep in
+ if !debug then
+ report ~level:2 (fun fmt ->
+ Format.fprintf fmt "@[<v 3>Optimizing machine %s@ "
+ mt.MT.mname.LT.node_id);
+ let new_step = salsaStep constEnv mt mt.MT.mstep in
if !debug then report ~level:2 (fun fmt -> Format.fprintf fmt "@]@ ");
- { mt with MT.mstep = new_step }
-
-
- with FormalEnv.NoDefinition v as exp ->
- Format.eprintf "No definition for variable %a@.@?" Printers.pp_var v;
+ { mt with MT.mstep = new_step }
+ with FormalEnv.NoDefinition v as exp ->
+ Format.eprintf "No definition for variable %a@.@?" Printers.pp_var v;
raise exp
-
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
(* End: *)
-
diff --git a/src/plugins/salsa/salsaDatatypes.ml b/src/plugins/salsa/salsaDatatypes.ml
index 8180833a305127fc1bc8b8d4e19a79a8e79f190d..ecbd8b0bd266218dc1672bb36f51c2aaf215daad 100644
--- a/src/plugins/salsa/salsaDatatypes.ml
+++ b/src/plugins/salsa/salsaDatatypes.ml
@@ -5,163 +5,165 @@ module ST = Salsa.Types
let debug = ref false
-let _ = Salsa.Prelude.sliceSize := 5
-
-let pp_hash ~sep f fmt r =
+let _ = Salsa.Prelude.sliceSize := 5
+
+let pp_hash ~sep f fmt r =
Format.fprintf fmt "[@[<v>";
Hashtbl.iter (fun k v -> Format.fprintf fmt "%t%s@ " (f k v) sep) r;
- Format.fprintf fmt "]@]";
-
+ Format.fprintf fmt "]@]"
-module type VALUE =
-sig
+module type VALUE = sig
type t
- val union: t -> t -> t
- val pp: Format.formatter -> t -> unit
- val leq: t -> t -> bool
-end
-
-module Ranges =
- functor (Value: VALUE) ->
-struct
- module Value = Value
- type t = Value.t
- type r_t = (LT.ident, Value.t) Hashtbl.t
-
- let empty: r_t = Hashtbl.create 13
-
- (* Look for def of node i with inputs living in vtl_ranges, reinforce ranges
- to bound vdl: each output of node i *)
- let add_call ranges vdl id vtl_ranges = ranges (* TODO assert false. On est
- pas obligé de faire
- qqchose. On peut supposer
- que les ranges sont donnés
- pour chaque noeud *)
-
-
- let pp fmt r =
- if Hashtbl.length r = 0 then
- Format.fprintf fmt "empty"
- else
- pp_hash ~sep:";" (fun k v fmt -> Format.fprintf fmt "%s -> %a" k Value.pp v) fmt r
- let pp_val = Value.pp
-
- let add_def ranges name r =
- (* Format.eprintf "%s: declare %a@." *)
- (* x.LT.var_id *)
- (* Value.pp r ; *)
-
- let fresh = Hashtbl.copy ranges in
- Hashtbl.add fresh name r; fresh
-
- let enlarge ranges name r =
- let fresh = Hashtbl.copy ranges in
- if Hashtbl.mem fresh name then
- Hashtbl.replace fresh name (Value.union r (Hashtbl.find fresh name))
- else
- Hashtbl.add fresh name r;
- fresh
-
-
- (* Compute a join per variable *)
- let merge ranges1 ranges2 =
- (* Format.eprintf "Mergeing rangesint %a with %a@." pp ranges1 pp ranges2; *)
- let ranges = Hashtbl.copy ranges1 in
- Hashtbl.iter (fun k v ->
- if Hashtbl.mem ranges k then (
- (* Format.eprintf "%s: %a union %a = %a@." *)
- (* k *)
- (* Value.pp v *)
- (* Value.pp (Hashtbl.find ranges k) *)
- (* Value.pp (Value.union v (Hashtbl.find ranges k)); *)
- Hashtbl.replace ranges k (Value.union v (Hashtbl.find ranges k))
- )
- else
- Hashtbl.add ranges k v
- ) ranges2;
- (* Format.eprintf "Merge result %a@." pp ranges; *)
- ranges
+ val union : t -> t -> t
- let to_abstract_env ranges =
- Hashtbl.fold
- (fun id value accu -> (id,value)::accu)
- ranges
- []
+ val pp : Format.formatter -> t -> unit
+
+ val leq : t -> t -> bool
end
-module FloatIntSalsa =
-struct
- type t = ST.abstractValue
+module Ranges =
+functor
+ (Value : VALUE)
+ ->
+ struct
+ module Value = Value
- let pp fmt ((f,r):t) =
- let fs, rs = (Salsa.Float.Domain.print (f,r)) in
- Format.fprintf fmt "%s + %s" fs rs
-(* match f, r with
- | ST.I(a,b), ST.J(c,d) ->
- Format.fprintf fmt "[%f, %f] + [%s, %s]" a b (Num.string_of_num c) (Num.string_of_num d)
- | ST.I(a,b), ST.JInfty -> Format.fprintf fmt "[%f, %f] + oo" a b
- | ST.Empty, _ -> Format.fprintf fmt "???"
-
- | _ -> assert false
-*)
- let union v1 v2 = Salsa.Float.Domain.join v1 v2
-(* match v1, v2 with
- |(ST.I(x1, x2), ST.J(y1, y2)), (ST.I(x1', x2'), ST.J(y1', y2')) ->
- ST.(I(min x1 x1', max x2 x2'), J(min y1 y1', max y2 y2'))
- | _ -> Format.eprintf "%a cup %a failed@.@?" pp v1 pp v2; assert false
-*)
- let inject cst = match cst with
- | LT.Const_int(i) -> Salsa.Builder.mk_cst (Salsa.Float.Domain.inject_int i)
- | LT.Const_real r -> (* TODO: this is incorrect. We should rather
- compute the error associated to the float *)
- (* let f = float_of_string s in *)
- let n = Real.to_q r in
- Salsa.Builder.mk_cst (Salsa.Float.Domain.inject_q n)
-
- (* let r = Salsa.Prelude.r_of_f_aux r in *)
- (* Salsa.Builder.mk_cst (Float.Domain.nnew r r) *)
-
- (* let r = float_of_string s in *)
- (* if r = 0. then *)
- (* Salsa.Builder.mk_cst (ST.R(-. min_float, min_float),Float.ulp (ST.R(-. min_float, min_float))) *)
- (* else *)
- (* Salsa.Builder.mk_cst (ST.I(r*.(1.-.epsilon_float),r*.(1.+.epsilon_float)),Float.ulp (ST.I(r,r))) *)
- | _ -> assert false
+ type t = Value.t
- let leq = (* Salsa.Float.feSseq *) Salsa.Float.Domain.leq
-end
+ type r_t = (LT.ident, Value.t) Hashtbl.t
-module RangesInt = Ranges (FloatIntSalsa)
+ let empty : r_t = Hashtbl.create 13
-module Vars =
-struct
- module VarSet = Set.Make (struct type t = LT.var_decl let compare x y = compare x.LT.var_id y.LT.var_id end)
- let real_vars vs = VarSet.filter (fun v -> Types.is_real_type v.LT.var_type) vs
- let of_list = List.fold_left (fun s e -> VarSet.add e s) VarSet.empty
+ (* Look for def of node i with inputs living in vtl_ranges, reinforce ranges
+ to bound vdl: each output of node i *)
+ let add_call ranges vdl id vtl_ranges = ranges
+ (* TODO assert false. On est pas obligé de faire qqchose. On peut supposer
+ que les ranges sont donnés pour chaque noeud *)
- include VarSet
+ let pp fmt r =
+ if Hashtbl.length r = 0 then Format.fprintf fmt "empty"
+ else
+ pp_hash ~sep:";"
+ (fun k v fmt -> Format.fprintf fmt "%s -> %a" k Value.pp v)
+ fmt r
+
+ let pp_val = Value.pp
+
+ let add_def ranges name r =
+ (* Format.eprintf "%s: declare %a@." *)
+ (* x.LT.var_id *)
+ (* Value.pp r ; *)
+ let fresh = Hashtbl.copy ranges in
+ Hashtbl.add fresh name r;
+ fresh
+
+ let enlarge ranges name r =
+ let fresh = Hashtbl.copy ranges in
+ if Hashtbl.mem fresh name then
+ Hashtbl.replace fresh name (Value.union r (Hashtbl.find fresh name))
+ else Hashtbl.add fresh name r;
+ fresh
+
+ (* Compute a join per variable *)
+ let merge ranges1 ranges2 =
+ (* Format.eprintf "Mergeing rangesint %a with %a@." pp ranges1 pp ranges2; *)
+ let ranges = Hashtbl.copy ranges1 in
+ Hashtbl.iter
+ (fun k v ->
+ if Hashtbl.mem ranges k then
+ (* Format.eprintf "%s: %a union %a = %a@." *)
+ (* k *)
+ (* Value.pp v *)
+ (* Value.pp (Hashtbl.find ranges k) *)
+ (* Value.pp (Value.union v (Hashtbl.find ranges k)); *)
+ Hashtbl.replace ranges k (Value.union v (Hashtbl.find ranges k))
+ else Hashtbl.add ranges k v)
+ ranges2;
+ (* Format.eprintf "Merge result %a@." pp ranges; *)
+ ranges
- let remove_list (set:t) (v_list: elt list) : t = List.fold_right VarSet.remove v_list set
- let pp fmt vs = Utils.fprintf_list ~sep:", " Printers.pp_var fmt (VarSet.elements vs)
-end
+ let to_abstract_env ranges =
+ Hashtbl.fold (fun id value accu -> (id, value) :: accu) ranges []
+ end
+module FloatIntSalsa = struct
+ type t = ST.abstractValue
+ let pp fmt ((f, r) : t) =
+ let fs, rs = Salsa.Float.Domain.print (f, r) in
+ Format.fprintf fmt "%s + %s" fs rs
+ (* match f, r with | ST.I(a,b), ST.J(c,d) -> Format.fprintf fmt "[%f, %f] +
+ [%s, %s]" a b (Num.string_of_num c) (Num.string_of_num d) | ST.I(a,b),
+ ST.JInfty -> Format.fprintf fmt "[%f, %f] + oo" a b | ST.Empty, _ ->
+ Format.fprintf fmt "???"
+ | _ -> assert false *)
+ let union v1 v2 = Salsa.Float.Domain.join v1 v2
+ (* match v1, v2 with |(ST.I(x1, x2), ST.J(y1, y2)), (ST.I(x1', x2'), ST.J(y1',
+ y2')) -> ST.(I(min x1 x1', max x2 x2'), J(min y1 y1', max y2 y2')) | _ ->
+ Format.eprintf "%a cup %a failed@.@?" pp v1 pp v2; assert false *)
+ let inject cst =
+ match cst with
+ | LT.Const_int i ->
+ Salsa.Builder.mk_cst (Salsa.Float.Domain.inject_int i)
+ | LT.Const_real r ->
+ (* TODO: this is incorrect. We should rather compute the error associated
+ to the float *)
+ (* let f = float_of_string s in *)
+ let n = Real.to_q r in
+ Salsa.Builder.mk_cst (Salsa.Float.Domain.inject_q n)
+ (* let r = Salsa.Prelude.r_of_f_aux r in *)
+ (* Salsa.Builder.mk_cst (Float.Domain.nnew r r) *)
+
+ (* let r = float_of_string s in *)
+ (* if r = 0. then *)
+ (* Salsa.Builder.mk_cst (ST.R(-. min_float, min_float),Float.ulp (ST.R(-.
+ min_float, min_float))) *)
+ (* else *)
+ (* Salsa.Builder.mk_cst
+ (ST.I(r*.(1.-.epsilon_float),r*.(1.+.epsilon_float)),Float.ulp
+ (ST.I(r,r))) *)
+ | _ ->
+ assert false
+
+ let leq =
+ (* Salsa.Float.feSseq *)
+ Salsa.Float.Domain.leq
+end
+module RangesInt = Ranges (FloatIntSalsa)
+module Vars = struct
+ module VarSet = Set.Make (struct
+ type t = LT.var_decl
+ let compare x y = compare x.LT.var_id y.LT.var_id
+ end)
+ let real_vars vs =
+ VarSet.filter (fun v -> Types.is_real_type v.LT.var_type) vs
+
+ let of_list = List.fold_left (fun s e -> VarSet.add e s) VarSet.empty
+
+ include VarSet
+
+ let remove_list (set : t) (v_list : elt list) : t =
+ List.fold_right VarSet.remove v_list set
+
+ let pp fmt vs =
+ Utils.fprintf_list ~sep:", " Printers.pp_var fmt (VarSet.elements vs)
+end
(*************************************************************************************)
-(* Converting values back and forth *)
+(* Converting values back and forth *)
(*************************************************************************************)
-let rec value_t2salsa_expr constEnv vt =
+let rec value_t2salsa_expr constEnv vt =
let value_t2salsa_expr = value_t2salsa_expr constEnv in
- let res =
+ let res =
match vt.MT.value_desc with
(* | LT.Cst(LT.Const_tag(t) as c) -> *)
(* Format.eprintf "v2s: cst tag@."; *)
@@ -171,216 +173,260 @@ let rec value_t2salsa_expr constEnv vt =
(* ) *)
(* else ( *)
(* Format.eprintf "Const tag %s unhandled@.@?" t ; *)
- (* raise (Salsa.Prelude.Error ("Entschuldigung6, constant tag not yet implemented")) *)
- (* ) *)
- | MT.Cst(cst) -> (* Format.eprintf "v2s: cst tag 2: %a@." Printers.pp_const cst; *)FloatIntSalsa.inject cst
- | MT.Var(v) -> (* Format.eprintf "v2s: var %s@." v.LT.var_id; *)
- let sel_fun = (fun (vname, _) -> v.LT.var_id = vname) in
- if List.exists sel_fun constEnv then
- let _, cst = List.find sel_fun constEnv in
- FloatIntSalsa.inject cst
+ (* raise (Salsa.Prelude.Error ("Entschuldigung6, constant tag not yet
+ implemented")) *)
+ (* ) *)
+ | MT.Cst cst ->
+ (* Format.eprintf "v2s: cst tag 2: %a@." Printers.pp_const cst; *)
+ FloatIntSalsa.inject cst
+ | MT.Var v ->
+ (* Format.eprintf "v2s: var %s@." v.LT.var_id; *)
+ let sel_fun (vname, _) = v.LT.var_id = vname in
+ if List.exists sel_fun constEnv then
+ let _, cst = List.find sel_fun constEnv in
+ FloatIntSalsa.inject cst
else
- let id = v.LT.var_id in
- Salsa.Builder.mk_id id
- | MT.Fun(binop, [x;y]) -> let salsaX = value_t2salsa_expr x in
- let salsaY = value_t2salsa_expr y in
- let op = (
- let pred f x y = Salsa.Builder.mk_int_of_bool (f x y) in
- match binop with
- | "+" -> Salsa.Builder.mk_plus
- | "-" -> Salsa.Builder.mk_minus
- | "*" -> Salsa.Builder.mk_times
- | "/" -> Salsa.Builder.mk_div
- | "=" -> pred Salsa.Builder.mk_eq
- | "<" -> pred Salsa.Builder.mk_lt
- | ">" -> pred Salsa.Builder.mk_gt
- | "<=" -> pred Salsa.Builder.mk_lte
- | ">=" -> pred Salsa.Builder.mk_gte
- | _ -> assert false
- )
- in
- op salsaX salsaY
- | MT.Fun(unop, [x]) -> let salsaX = value_t2salsa_expr x in
- Salsa.Builder.mk_uminus salsaX
-
- | MT.Fun(f,_) -> raise (Salsa.Prelude.Error
- ("Unhandled function "^f^" in conversion to salsa expression"))
-
- | MT.Array(_)
- | MT.Access(_)
- | MT.Power(_) -> raise (Salsa.Prelude.Error ("Unhandled construct in conversion to salsa expression"))
+ let id = v.LT.var_id in
+ Salsa.Builder.mk_id id
+ | MT.Fun (binop, [ x; y ]) ->
+ let salsaX = value_t2salsa_expr x in
+ let salsaY = value_t2salsa_expr y in
+ let op =
+ let pred f x y = Salsa.Builder.mk_int_of_bool (f x y) in
+ match binop with
+ | "+" ->
+ Salsa.Builder.mk_plus
+ | "-" ->
+ Salsa.Builder.mk_minus
+ | "*" ->
+ Salsa.Builder.mk_times
+ | "/" ->
+ Salsa.Builder.mk_div
+ | "=" ->
+ pred Salsa.Builder.mk_eq
+ | "<" ->
+ pred Salsa.Builder.mk_lt
+ | ">" ->
+ pred Salsa.Builder.mk_gt
+ | "<=" ->
+ pred Salsa.Builder.mk_lte
+ | ">=" ->
+ pred Salsa.Builder.mk_gte
+ | _ ->
+ assert false
+ in
+ op salsaX salsaY
+ | MT.Fun (unop, [ x ]) ->
+ let salsaX = value_t2salsa_expr x in
+ Salsa.Builder.mk_uminus salsaX
+ | MT.Fun (f, _) ->
+ raise
+ (Salsa.Prelude.Error
+ ("Unhandled function " ^ f ^ " in conversion to salsa expression"))
+ | MT.Array _ | MT.Access _ | MT.Power _ ->
+ raise
+ (Salsa.Prelude.Error
+ "Unhandled construct in conversion to salsa expression")
in
(* if debug then *)
(* Format.eprintf "value_t2salsa_expr: %a -> %a@ " *)
(* MC.pp_val vt *)
- (* (fun fmt x -> Format.fprintf fmt "%s" (Salsa.Print.printExpression x)) res; *)
+ (* (fun fmt x -> Format.fprintf fmt "%s" (Salsa.Print.printExpression x)) res; *)
res
-type var_decl = { vdecl: LT.var_decl; is_local: bool }
-module VarEnv = Map.Make (struct type t = LT.ident let compare = compare end )
+type var_decl = { vdecl : LT.var_decl; is_local : bool }
+
+module VarEnv = Map.Make (struct
+ type t = LT.ident
+
+ let compare = compare
+end)
(* let is_local_var vars_env v = *)
(* try *)
(* (VarEnv.find v vars_env).is_local *)
-(* with Not_found -> Format.eprintf "Impossible to find var %s@.@?" v; assert false *)
+(* with Not_found -> Format.eprintf "Impossible to find var %s@.@?" v; assert
+ false *)
let get_var vars_env v =
-try
- VarEnv.find v vars_env
-with Not_found -> Format.eprintf "Impossible to find var %s in var env %a@ " v
- (Utils.fprintf_list ~sep:", " (fun fmt (id, _) -> Format.pp_print_string fmt id)) (VarEnv.bindings vars_env)
- ; assert false
+ try VarEnv.find v vars_env
+ with Not_found ->
+ Format.eprintf "Impossible to find var %s in var env %a@ " v
+ (Utils.fprintf_list ~sep:", " (fun fmt (id, _) ->
+ Format.pp_print_string fmt id))
+ (VarEnv.bindings vars_env);
+ assert false
let compute_vars_env m =
let env = VarEnv.empty in
- let env =
- List.fold_left
- (fun accu v -> VarEnv.add v.LT.var_id {vdecl = v; is_local = false; } accu)
- env
- m.MT.mmemory
+ let env =
+ List.fold_left
+ (fun accu v ->
+ VarEnv.add v.LT.var_id { vdecl = v; is_local = false } accu)
+ env m.MT.mmemory
in
- let env =
- List.fold_left (
- fun accu v -> VarEnv.add v.LT.var_id {vdecl = v; is_local = true; } accu
- )
+ let env =
+ List.fold_left
+ (fun accu v -> VarEnv.add v.LT.var_id { vdecl = v; is_local = true } accu)
env
- MC.(m.MT.mstep.MT.step_inputs@m.MT.mstep.MT.step_outputs@m.MT.mstep.MT.step_locals)
+ MC.(
+ m.MT.mstep.MT.step_inputs @ m.MT.mstep.MT.step_outputs
+ @ m.MT.mstep.MT.step_locals)
in
-env
+ env
-let rec salsa_expr2value_t vars_env cst_env e =
- (* let e = Float.evalPartExpr e [] [] in *)
+let rec salsa_expr2value_t vars_env cst_env e =
+ (* let e = Float.evalPartExpr e [] [] in *)
let salsa_expr2value_t = salsa_expr2value_t vars_env cst_env in
- let binop op e1 e2 t =
+ let binop op e1 e2 t =
let x = salsa_expr2value_t e1 in
- let y = salsa_expr2value_t e2 in
- MC.mk_val (MT.Fun (op, [x;y])) t
+ let y = salsa_expr2value_t e2 in
+ MC.mk_val (MT.Fun (op, [ x; y ])) t
in
match e with
- ST.Cst(abs_val,_) -> (* We project ranges into constants. We
- forget about errors and provide the
- mean/middle value of the interval
- *)
+ | ST.Cst (abs_val, _) ->
+ (* We project ranges into constants. We forget about errors and provide the
+ mean/middle value of the interval *)
let new_float = Salsa.Float.Domain.to_float abs_val in
- (* let new_float = Salsa.NumMartel.float_of_num c in *)
- (* let new_float = *)
- (* if f1 = f2 then *)
- (* f1 *)
- (* else *)
- (* (f1 +. f2) /. 2.0 *)
- (* in *)
- (* Log.report ~level:3 *)
- (* (fun fmt -> Format.fprintf fmt "projecting [%.45f, %.45f] -> %.45f@ " f1 f2 new_float); *)
- let cst =
- let s =
- if new_float = 0. then "0." else
- (* We have to convert it into our format: int * int * real *)
- (* string_of_float new_float *)
- let _ = Format.flush_str_formatter () in
- Format.fprintf Format.str_formatter "%.11f" new_float;
- Format.flush_str_formatter ()
- in
- Parser_lustre.signed_const Lexer_lustre.token (Lexing.from_string s)
+ (* let new_float = Salsa.NumMartel.float_of_num c in *)
+ (* let new_float = *)
+ (* if f1 = f2 then *)
+ (* f1 *)
+ (* else *)
+ (* (f1 +. f2) /. 2.0 *)
+ (* in *)
+ (* Log.report ~level:3 *)
+ (* (fun fmt -> Format.fprintf fmt "projecting [%.45f, %.45f] -> %.45f@ " f1
+ f2 new_float); *)
+ let cst =
+ let s =
+ if new_float = 0. then "0."
+ else
+ (* We have to convert it into our format: int * int * real *)
+ (* string_of_float new_float *)
+ let _ = Format.flush_str_formatter () in
+ Format.fprintf Format.str_formatter "%.11f" new_float;
+ Format.flush_str_formatter ()
in
- MC.mk_val (MT.Cst(cst)) Type_predef.type_real
- | ST.Id(id, _) ->
+ Parser_lustre.signed_const Lexer_lustre.token (Lexing.from_string s)
+ in
+ MC.mk_val (MT.Cst cst) Type_predef.type_real
+ | ST.Id (id, _) ->
(* Format.eprintf "Looking for id=%s@.@?" id; *)
- if List.mem_assoc id cst_env then (
- let cst = List.assoc id cst_env in
+ if List.mem_assoc id cst_env then
+ let cst = List.assoc id cst_env in
(* Format.eprintf "Found cst = %a@.@?" Printers.pp_const cst; *)
- MC.mk_val (MT.Cst cst) Type_predef.type_real
- )
- else
+ MC.mk_val (MT.Cst cst) Type_predef.type_real
+ else
(* if is_const salsa_label then *)
(* MC.Cst(LT.Const_tag(get_const salsa_label)) *)
- (* else *)
- let var_id = try get_var vars_env id with Not_found -> assert false in
- MC.mk_val (MT.Var(var_id.vdecl)) var_id.vdecl.LT.var_type
- | ST.Plus(x, y, _) -> binop "+" x y Type_predef.type_real
- | ST.Minus(x, y, _) -> binop "-" x y Type_predef.type_real
- | ST.Times(x, y, _) -> binop "*" x y Type_predef.type_real
- | ST.Div(x, y, _) -> binop "/" x y Type_predef.type_real
- | ST.Uminus(x,_) -> let x = salsa_expr2value_t x in
- MC.mk_val (MT.Fun("uminus",[x])) Type_predef.type_real
- | ST.IntOfBool(ST.Eq(x, y, _),_) -> binop "=" x y Type_predef.type_bool
- | ST.IntOfBool(ST.Lt(x,y,_),_) -> binop "<" x y Type_predef.type_bool
- | ST.IntOfBool(ST.Gt(x,y,_),_) -> binop ">" x y Type_predef.type_bool
- | ST.IntOfBool(ST.Lte(x,y,_),_) -> binop "<=" x y Type_predef.type_bool
- | ST.IntOfBool(ST.Gte(x,y,_),_) -> binop ">=" x y Type_predef.type_bool
- | _ -> raise (Salsa.Prelude.Error "Entschuldigung, salsaExpr2value_t case not yet implemented")
-
-
+ (* else *)
+ let var_id = try get_var vars_env id with Not_found -> assert false in
+ MC.mk_val (MT.Var var_id.vdecl) var_id.vdecl.LT.var_type
+ | ST.Plus (x, y, _) ->
+ binop "+" x y Type_predef.type_real
+ | ST.Minus (x, y, _) ->
+ binop "-" x y Type_predef.type_real
+ | ST.Times (x, y, _) ->
+ binop "*" x y Type_predef.type_real
+ | ST.Div (x, y, _) ->
+ binop "/" x y Type_predef.type_real
+ | ST.Uminus (x, _) ->
+ let x = salsa_expr2value_t x in
+ MC.mk_val (MT.Fun ("uminus", [ x ])) Type_predef.type_real
+ | ST.IntOfBool (ST.Eq (x, y, _), _) ->
+ binop "=" x y Type_predef.type_bool
+ | ST.IntOfBool (ST.Lt (x, y, _), _) ->
+ binop "<" x y Type_predef.type_bool
+ | ST.IntOfBool (ST.Gt (x, y, _), _) ->
+ binop ">" x y Type_predef.type_bool
+ | ST.IntOfBool (ST.Lte (x, y, _), _) ->
+ binop "<=" x y Type_predef.type_bool
+ | ST.IntOfBool (ST.Gte (x, y, _), _) ->
+ binop ">=" x y Type_predef.type_bool
+ | _ ->
+ raise
+ (Salsa.Prelude.Error
+ "Entschuldigung, salsaExpr2value_t case not yet implemented")
let rec get_salsa_free_vars vars_env constEnv absenv e =
let f = get_salsa_free_vars vars_env constEnv absenv in
match e with
- | ST.Id (id, _) ->
- if not (List.mem_assoc id absenv) && not (List.mem_assoc id constEnv) then
- Vars.singleton ((try VarEnv.find id vars_env with Not_found -> assert false).vdecl)
- else
- Vars.empty
- | ST.Plus(x, y, _)
- | ST.Minus(x, y, _)
- | ST.Times(x, y, _)
- | ST.Div(x, y, _)
- | ST.IntOfBool(ST.Eq(x, y, _),_)
- | ST.IntOfBool(ST.Lt(x,y,_),_)
- | ST.IntOfBool(ST.Gt(x,y,_),_)
- | ST.IntOfBool(ST.Lte(x,y,_),_)
- | ST.IntOfBool(ST.Gte(x,y,_),_)
- -> Vars.union (f x) (f y)
- | ST.Uminus(x,_) -> f x
- | ST.Cst _ -> Vars.empty
- | _ -> assert false
-
-
-module FormalEnv =
-struct
- type fe_t = (LT.ident, (int * MT.value_t)) Hashtbl.t
+ | ST.Id (id, _) ->
+ if (not (List.mem_assoc id absenv)) && not (List.mem_assoc id constEnv) then
+ Vars.singleton
+ (try VarEnv.find id vars_env with Not_found -> assert false).vdecl
+ else Vars.empty
+ | ST.Plus (x, y, _)
+ | ST.Minus (x, y, _)
+ | ST.Times (x, y, _)
+ | ST.Div (x, y, _)
+ | ST.IntOfBool (ST.Eq (x, y, _), _)
+ | ST.IntOfBool (ST.Lt (x, y, _), _)
+ | ST.IntOfBool (ST.Gt (x, y, _), _)
+ | ST.IntOfBool (ST.Lte (x, y, _), _)
+ | ST.IntOfBool (ST.Gte (x, y, _), _) ->
+ Vars.union (f x) (f y)
+ | ST.Uminus (x, _) ->
+ f x
+ | ST.Cst _ ->
+ Vars.empty
+ | _ ->
+ assert false
+
+module FormalEnv = struct
+ type fe_t = (LT.ident, int * MT.value_t) Hashtbl.t
+
let cpt = ref 0
exception NoDefinition of LT.var_decl
+
(* Returns the expression associated to v in env *)
- let get_def (env: fe_t) v =
- try
- snd (Hashtbl.find env v.LT.var_id)
+ let get_def (env : fe_t) v =
+ try snd (Hashtbl.find env v.LT.var_id)
with Not_found -> raise (NoDefinition v)
- let fold f = Hashtbl.fold (fun k (_,v) accu -> f k v accu)
-
- let to_salsa constEnv formalEnv =
- fold (fun id expr accu ->
- (id, value_t2salsa_expr constEnv expr)::accu
- ) formalEnv []
+ let fold f = Hashtbl.fold (fun k (_, v) accu -> f k v accu)
+
+ let to_salsa constEnv formalEnv =
+ fold
+ (fun id expr accu -> (id, value_t2salsa_expr constEnv expr) :: accu)
+ formalEnv []
- let def constEnv vars_env (env: fe_t) d expr =
+ let def constEnv vars_env (env : fe_t) d expr =
incr cpt;
let fresh = Hashtbl.copy env in
let expr_salsa = value_t2salsa_expr constEnv expr in
let salsa_env = to_salsa constEnv env in
let expr_salsa, _ = Salsa.Rewrite.substVars expr_salsa salsa_env 0 in
- let expr_salsa = Salsa.Analyzer.evalPartExpr expr_salsa salsa_env ([] (* no blacklisted vars *)) ([] (*no arrays *)) in
+ let expr_salsa =
+ Salsa.Analyzer.evalPartExpr expr_salsa salsa_env []
+ (* no blacklisted vars *)
+ []
+ (*no arrays *)
+ in
let expr_lustrec = salsa_expr2value_t vars_env [] expr_salsa in
- Hashtbl.add fresh d.LT.var_id (!cpt, expr_lustrec); fresh
-
- let empty (): fe_t = Hashtbl.create 13
+ Hashtbl.add fresh d.LT.var_id (!cpt, expr_lustrec);
+ fresh
- let pp m fmt env = pp_hash ~sep:";@ " (fun k (_,v) fmt -> Format.fprintf fmt "%s -> %a" k (MC.pp_val m) v) fmt env
+ let empty () : fe_t = Hashtbl.create 13
+ let pp m fmt env =
+ pp_hash ~sep:";@ "
+ (fun k (_, v) fmt -> Format.fprintf fmt "%s -> %a" k (MC.pp_val m) v)
+ fmt env
let get_sort_fun env =
- let order = Hashtbl.fold (fun k (cpt, _) accu -> (k,cpt)::accu) env [] in
- fun v1 v2 ->
- if List.mem_assoc v1.LT.var_id order && List.mem_assoc v2.LT.var_id order then
- if (List.assoc v1.LT.var_id order) <= (List.assoc v2.LT.var_id order) then
- -1
- else
- 1
- else
- assert false
+ let order = Hashtbl.fold (fun k (cpt, _) accu -> (k, cpt) :: accu) env [] in
+ fun v1 v2 ->
+ if List.mem_assoc v1.LT.var_id order && List.mem_assoc v2.LT.var_id order
+ then
+ if List.assoc v1.LT.var_id order <= List.assoc v2.LT.var_id order then
+ -1
+ else 1
+ else assert false
end
-
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
(* End: *)
diff --git a/src/plugins/salsa/salsa_plugin.ml b/src/plugins/salsa/salsa_plugin.ml
index a16909ab0fb9e8418cd77c03996ceb19a98b1a2d..0345dc6d23d60260a0012d7530331ba1b454a922 100644
--- a/src/plugins/salsa/salsa_plugin.ml
+++ b/src/plugins/salsa/salsa_plugin.ml
@@ -1,60 +1,59 @@
-open Format
+open Format
open Lustre_types
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
+(* "-salsa", Arg.Set salsa_enabled, "activate Salsa optimization <default>"; *)
+(* "-no-salsa", Arg.Clear salsa_enabled, "deactivate Salsa optimization"; *)
+
+module Plugin : PluginType.S = struct
include PluginType.Default
+
let name = "salsa"
-
- let options = [
- "-debug", Arg.Set SalsaDatatypes.debug, "debug salsa plugin";
- "-verbose", Arg.Set_int Salsa.Log.verbose_level, "salsa plugin verbose level (default is 0)";
- "-slice-depth", Arg.Set_int Salsa.Prelude.sliceSize, "salsa slice depth (default is 5)";
- "-disable", Arg.Clear salsa_enabled, "disable salsa";
+
+ let options =
+ [
+ "-debug", Arg.Set SalsaDatatypes.debug, "debug salsa plugin";
+ ( "-verbose",
+ Arg.Set_int Salsa.Log.verbose_level,
+ "salsa plugin verbose level (default is 0)" );
+ ( "-slice-depth",
+ Arg.Set_int Salsa.Prelude.sliceSize,
+ "salsa slice depth (default is 5)" );
+ "-disable", Arg.Clear salsa_enabled, "disable salsa";
]
- let activate () =
- salsa_enabled := true
-
+ let activate () = salsa_enabled := true
+
let init () =
- if !salsa_enabled then
- if !SalsaDatatypes.debug then
- Salsa.Log.debug := 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 ".. @[<v 0>salsa machines optimization@ ");
- (* 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
- let res =
- List.map
- (Machine_salsa_opt.machine_t2machine_t_optimized_by_salsa constEnv)
- machine_code
- in
- Log.report ~level:1 (fun fmt -> fprintf fmt "@]@ ");
- res
- end
- else
- machine_code
-
-
- end: PluginType.S)
+ if !salsa_enabled then if !SalsaDatatypes.debug then Salsa.Log.debug := true
+
+ let refine_machine_code prog machine_code =
+ if !salsa_enabled then (
+ Compiler_common.check_main ();
+ Log.report ~level:1 (fun fmt ->
+ fprintf fmt ".. @[<v 0>salsa machines optimization@ ");
+ (* 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
+ let res =
+ List.map
+ (Machine_salsa_opt.machine_t2machine_t_optimized_by_salsa constEnv)
+ machine_code
+ in
+ Log.report ~level:1 (fun fmt -> fprintf fmt "@]@ ");
+ res)
+ else machine_code
+end
let () =
- PluginList.registered := (module Plugin : PluginType.S) ::
- !PluginList.registered
+ PluginList.registered :=
+ (module Plugin : PluginType.S) :: !PluginList.registered
diff --git a/src/plugins/scopes/dune b/src/plugins/scopes/dune
index b110b1f31a73359140483e6ce79414622909e49b..aaed4e671d120784e20b4b5269743b9131cf5316 100644
--- a/src/plugins/scopes/dune
+++ b/src/plugins/scopes/dune
@@ -8,4 +8,5 @@
(plugin
(name scopes_plugin)
(libraries lustrec.scopes)
- (site (lustrec plugins)))
+ (site
+ (lustrec plugins)))
diff --git a/src/plugins/scopes/scopes.ml b/src/plugins/scopes/scopes.ml
index 45e4e3584e6752618795b33bb56971f0c06eb1c7..9274265c9115bea026dcb8715fb860d1932354f9 100644
--- a/src/plugins/scopes/scopes.ml
+++ b/src/plugins/scopes/scopes.ml
@@ -1,5 +1,5 @@
-open Lustre_types
-open Corelang
+open Lustre_types
+open Corelang
open Machine_code_types
open Machine_code_common
@@ -7,425 +7,447 @@ open Machine_code_common
type scope_t = (var_decl * string * string option) list * var_decl
(* Scope to string list *)
-let scope_to_sl ((sl, v) : scope_t) : string list=
- List.fold_right (
- fun (v, nodename, _) accu ->
- v.var_id :: nodename :: accu
- ) sl [v.var_id]
+let scope_to_sl ((sl, v) : scope_t) : string list =
+ List.fold_right
+ (fun (v, nodename, _) accu -> v.var_id :: nodename :: accu)
+ sl [ v.var_id ]
-
-let rec compute_scopes ?(first=true) prog root_node : scope_t list =
+let rec compute_scopes ?(first = true) prog root_node : scope_t list =
let compute_scopes = compute_scopes ~first:false in
(* Format.eprintf "Compute scope of %s@." main_node; *)
try
- let node = get_node root_node prog in
- let all_vars = node.node_inputs @ node.node_locals @ node.node_outputs in
- let local_vars = if first then
- node.node_locals
- else
- node.node_inputs @ node.node_locals in
- let local_scopes = List.map (fun x -> [], x) local_vars in
+ let node = get_node root_node prog in
+ let all_vars = node.node_inputs @ node.node_locals @ node.node_outputs in
+ let local_vars =
+ if first then node.node_locals else node.node_inputs @ node.node_locals
+ in
+ let local_scopes = List.map (fun x -> [], x) local_vars in
let sub_scopes =
let sub_nodes =
- List.fold_left
- (fun res s ->
- match s with
- | Eq ({ eq_rhs ={ expr_desc = Expr_appl (nodeid, _, _); _}; _ } as eq) ->
- (* Obtaining the var_del associated to the first var of eq_lhs *)
- (
- try
- let query v = v.var_id = List.hd eq.eq_lhs in
- let vid = List.find query all_vars in
- (nodeid, vid)::res
- with Not_found -> Format.eprintf "eq=%a@.local_vars=%a@." Printers.pp_node_eq eq (Utils.fprintf_list ~sep:"," Printers.pp_var) local_vars; assert false
- )
- | Eq _ -> res
- | _ -> assert false (* TODO deal with Automaton *)
- ) [] node.node_stmts
+ List.fold_left
+ (fun res s ->
+ match s with
+ | Eq
+ ({ eq_rhs = { expr_desc = Expr_appl (nodeid, _, _); _ }; _ } as
+ eq) -> (
+ (* Obtaining the var_del associated to the first var of eq_lhs *)
+ try
+ let query v = v.var_id = List.hd eq.eq_lhs in
+ let vid = List.find query all_vars in
+ (nodeid, vid) :: res
+ with Not_found ->
+ Format.eprintf "eq=%a@.local_vars=%a@." Printers.pp_node_eq eq
+ (Utils.fprintf_list ~sep:"," Printers.pp_var)
+ local_vars;
+ assert false)
+ | Eq _ ->
+ res
+ | _ ->
+ assert false
+ (* TODO deal with Automaton *))
+ [] node.node_stmts
in
- List.map (fun (nodeid, vid) ->
- let scopes = compute_scopes prog nodeid in
- List.map (fun (sl,v) -> (vid, nodeid, None)::sl, v) scopes (* instances are not yet known, hence the None *)
- ) sub_nodes
+ List.map
+ (fun (nodeid, vid) ->
+ let scopes = compute_scopes prog nodeid in
+ List.map (fun (sl, v) -> (vid, nodeid, None) :: sl, v) scopes
+ (* instances are not yet known, hence the None *))
+ sub_nodes
in
- local_scopes @ (List.flatten sub_scopes)
- with Not_found -> []
-
+ local_scopes @ List.flatten sub_scopes
+ with Not_found -> []
let print_scopes =
- Utils.fprintf_list ~sep:"@ "
- (fun fmt ((_, v) as s) -> Format.fprintf fmt "%a: %a"
- (Utils.fprintf_list ~sep:"." Format.pp_print_string )(scope_to_sl s)
- Types.print_ty v.var_type)
-
-
-
+ Utils.fprintf_list ~sep:"@ " (fun fmt ((_, v) as s) ->
+ Format.fprintf fmt "%a: %a"
+ (Utils.fprintf_list ~sep:"." Format.pp_print_string)
+ (scope_to_sl s) Types.print_ty v.var_type)
-(* let print_path fmt p = *)
-(* Utils.fprintf_list ~sep:"." (fun fmt (id, _) -> Format.pp_print_string fmt id) fmt p *)
+(* let print_path fmt p = *)
+(* Utils.fprintf_list ~sep:"." (fun fmt (id, _) -> Format.pp_print_string fmt
+ id) fmt p *)
let get_node_vdecl_of_name name node =
try
- List.find
- (fun v -> v.var_id = name)
- (node.node_inputs @ node.node_outputs @ node.node_locals )
- with Not_found ->
+ List.find
+ (fun v -> v.var_id = name)
+ (node.node_inputs @ node.node_outputs @ node.node_locals)
+ with Not_found ->
Format.eprintf "Cannot find variable %s in node %s@." name node.node_id;
assert false
let rec get_path prog machines node id_list accu =
let get_path = get_path prog machines in
match id_list, accu with
- | [flow], [] -> (* Special treatment of first level flow: node is here main_node *)
- let flow_var = get_node_vdecl_of_name flow node in
- [], flow_var, node.node_id
- | [id], (_, last_node, _)::_ -> (* last item, it should denote a local
- memory variable (local var, memory or input *)
- let id_vdecl =
- get_node_vdecl_of_name id (get_node last_node prog)
- in
- List.rev accu, id_vdecl, last_node
- | varid::nodename::id_list_tl, _ -> (
- let e_machine = get_machine machines node.node_id in
+ | [ flow ], [] ->
+ (* Special treatment of first level flow: node is here main_node *)
+ let flow_var = get_node_vdecl_of_name flow node in
+ [], flow_var, node.node_id
+ | [ id ], (_, last_node, _) :: _ ->
+ (* last item, it should denote a local memory variable (local var, memory or
+ input *)
+ let id_vdecl = get_node_vdecl_of_name id (get_node last_node prog) in
+ List.rev accu, id_vdecl, last_node
+ | varid :: nodename :: id_list_tl, _ -> (
+ let e_machine = get_machine machines node.node_id in
(* Format.eprintf "Looking for def %s in call %s in machine %a@." *)
(* varid nodename *)
(* Machine_code.pp_machine e_machine; *)
- let find_var = (fun v -> v.var_id = varid) in
- let instance =
- List.find
- (fun i -> match get_instr_desc i with
- | MStep(p, _, _) -> List.exists find_var p
- | _ -> false
- )
- e_machine.mstep.step_instrs
+ let find_var v = v.var_id = varid in
+ let instance =
+ List.find
+ (fun i ->
+ match get_instr_desc i with
+ | MStep (p, _, _) ->
+ List.exists find_var p
+ | _ ->
+ false)
+ e_machine.mstep.step_instrs
in
try
- let variable, instance_node, instance_id =
- match get_instr_desc instance with
- | MStep(p, o, _) ->
- (* Format.eprintf "Looking for machine %s@.@?" o; *)
- let o_fun, _ = List.assoc o e_machine.mcalls in
- if node_name o_fun = nodename then
- List.hd p, o_fun, o
- else
- assert false
- | _ -> assert false
+ let variable, instance_node, instance_id =
+ match get_instr_desc instance with
+ | MStep (p, o, _) ->
+ (* Format.eprintf "Looking for machine %s@.@?" o; *)
+ let o_fun, _ = List.assoc o e_machine.mcalls in
+ if node_name o_fun = nodename then List.hd p, o_fun, o
+ else assert false
+ | _ ->
+ assert false
in
let next_node = node_of_top instance_node in
- let accu = (variable, nodename, Some instance_id)::accu in
+ let accu = (variable, nodename, Some instance_id) :: accu in
(* Format.eprintf "Calling get path on %s@.@?" next_node.node_id; *)
get_path next_node id_list_tl accu
- with Not_found -> Format.eprintf "toto@."; assert false
- )
- | _ -> assert false
+ with Not_found ->
+ Format.eprintf "toto@.";
+ assert false)
+ | _ ->
+ assert false
-
-let check_scope all_scopes =
+let check_scope all_scopes =
let all_scopes_as_sl = List.map scope_to_sl all_scopes in
fun prog machines main_node_name sl ->
- if not (List.mem sl all_scopes_as_sl) then (
- Format.eprintf "%s is an invalid scope.@." (String.concat "." sl);
- exit 1
- )
- else (
- (* Format.eprintf "@.@.Required path: %s@." (String.concat "." sl) ; *)
- let main_node = get_node main_node_name prog in
- let path, flow, mid = get_path prog machines main_node sl [] in
- (* Format.eprintf "computed path: %a.%s@." print_path path flow.var_id; *)
- path, flow, mid
- )
-
-
-
-(* Build the two maps
- - (scope_name, variable)
- - (machine_name, list of selected variables)
- *)
+ if not (List.mem sl all_scopes_as_sl) then (
+ Format.eprintf "%s is an invalid scope.@." (String.concat "." sl);
+ exit 1)
+ else
+ (* Format.eprintf "@.@.Required path: %s@." (String.concat "." sl) ; *)
+ let main_node = get_node main_node_name prog in
+ let path, flow, mid = get_path prog machines main_node sl [] in
+ (* Format.eprintf "computed path: %a.%s@." print_path path flow.var_id; *)
+ path, flow, mid
+
+(* Build the two maps - (scope_name, variable) - (machine_name, list of selected
+ variables) *)
let check_scopes main_node_name prog machines all_scopes scopes =
let check_scope = check_scope all_scopes prog machines in
List.fold_left
(fun (accu_sl, accu_m) sl ->
let path, flow, mid = check_scope main_node_name sl in
- let accu_sl = (sl, (path, flow))::accu_sl in
+ let accu_sl = (sl, (path, flow)) :: accu_sl in
let accu_m =
let flow_id = flow.var_id in
if List.mem_assoc mid accu_m then
- (mid, flow_id::(List.assoc mid accu_m)) ::
- (List.remove_assoc mid accu_m)
- else
- (mid, [flow_id])::accu_m
+ (mid, flow_id :: List.assoc mid accu_m)
+ :: List.remove_assoc mid accu_m
+ else (mid, [ flow_id ]) :: accu_m
in
- accu_sl, accu_m
- ) ([], []) scopes
-
-
+ accu_sl, accu_m)
+ ([], []) scopes
-let scope_var_name vid = vid ^ "__scope"
+let scope_var_name vid = vid ^ "__scope"
(**********************************************************************)
-(* The following three functions are used in the main function to print
- the value of the new memories, storing scopes values *)
+(* The following three functions are used in the main function to print the
+ value of the new memories, storing scopes values *)
(**********************************************************************)
-(* TODO: recuperer le type de "flow" et appeler le print correspondant
- iterer sur path pour construire la suite des xx_mem._reg.yy_mem._reg......flow
-par ex main_mem->n8->n9->_reg.flow
-*)
+(* TODO: recuperer le type de "flow" et appeler le print correspondant iterer
+ sur path pour construire la suite des xx_mem._reg.yy_mem._reg......flow par
+ ex main_mem->n8->n9->_reg.flow *)
let extract_scopes_defs scopes =
- let rec scope_path_name (path, flow) accu =
- match path with
- | [] -> accu ^ "_reg." ^ (scope_var_name flow.var_id), flow
- | (_, _, Some instance_id)::tl -> scope_path_name (tl, flow) ( accu ^ instance_id ^ "->" )
- | _ -> assert false
+ let rec scope_path_name (path, flow) accu =
+ match path with
+ | [] ->
+ accu ^ "_reg." ^ scope_var_name flow.var_id, flow
+ | (_, _, Some instance_id) :: tl ->
+ scope_path_name (tl, flow) (accu ^ instance_id ^ "->")
+ | _ ->
+ assert false
in
- let scopes_vars =
- List.map
- (fun (sl, scope) ->
- String.concat "." sl, scope_path_name scope "main_mem.")
- scopes
+ let scopes_vars =
+ List.map
+ (fun (sl, scope) ->
+ String.concat "." sl, scope_path_name scope "main_mem.")
+ scopes
in
scopes_vars
-
+
let pp_scopes_files _basename _mname fmt scopes =
let scopes_vars = extract_scopes_defs scopes in
- List.iteri (fun idx _(*(id, (var_path, var))*) ->
+ List.iteri
+ (fun idx _ (*(id, (var_path, var))*) ->
C_backend_common.pp_file_decl fmt "out_scopes" idx)
scopes_vars;
Format.fprintf fmt "@[<v 2>if (traces) {@ ";
- List.iteri (fun idx (id, (_, var)) ->
+ List.iteri
+ (fun idx (id, (_, var)) ->
let file = C_backend_common.pp_file_open fmt "out_scopes" idx in
- Format.fprintf fmt
- "fprintf(%s, \"# scope: %s\\n\");@ "
- file id;
- Format.fprintf fmt
- "fprintf(%s, \"# node: %s\\n\");@ "
- file (Utils.desome var.var_parent_nodeid);
- Format.fprintf fmt
- "fprintf(%s, \"# variable: %s\\n\");@ "
- file var.var_id
- ) scopes_vars;
+ Format.fprintf fmt "fprintf(%s, \"# scope: %s\\n\");@ " file id;
+ Format.fprintf fmt "fprintf(%s, \"# node: %s\\n\");@ " file
+ (Utils.desome var.var_parent_nodeid);
+ Format.fprintf fmt "fprintf(%s, \"# variable: %s\\n\");@ " file var.var_id)
+ scopes_vars;
Format.fprintf fmt "@]}@ "
-
-
-let pp_scopes fmt scopes =
+
+let pp_scopes fmt scopes =
let scopes_vars = extract_scopes_defs scopes in
- List.iteri (fun idx (id, (var_path, var)) ->
- Format.fprintf fmt "@ %t;"
- (fun fmt -> C_backend_common.print_put_var fmt
- ("_scopes" ^ string_of_int (idx+1))
- id (*var*) var.var_type var_path)
- ) scopes_vars
+ List.iteri
+ (fun idx (id, (var_path, var)) ->
+ Format.fprintf fmt "@ %t;" (fun fmt ->
+ C_backend_common.print_put_var fmt
+ ("_scopes" ^ string_of_int (idx + 1))
+ id (*var*) var.var_type var_path))
+ scopes_vars
(**********************************************************************)
-
+
let update_machine main_node machine scopes =
let stateassign (vdecl_mem, vdecl_orig) =
mkinstr
- (MStateAssign (vdecl_mem, mk_val (Var vdecl_orig) vdecl_orig.var_type))
+ (MStateAssign (vdecl_mem, mk_val (Var vdecl_orig) vdecl_orig.var_type))
in
let selection =
(* We only register inputs for non root node *)
- (if machine.mname.node_id = main_node then
- []
- else
- machine.mstep.step_inputs
- )
- (* @ machine.mstep.step_outputs *)
- @ machine.mmemory
+ (if machine.mname.node_id = main_node then []
+ else machine.mstep.step_inputs)
+ (* @ machine.mstep.step_outputs *)
+ @ machine.mmemory
@ machine.mstep.step_locals
in
- let selection = List.filter (fun v -> List.exists (fun vid -> vid = v.var_id) scopes) selection in
- let new_mems = List.map (fun v ->
- (* We could copy the variable but then we need to update its type
- let new_v = copy_var_decl v in
- *)
- let new_v = { v with var_id = scope_var_name v.var_id } in
- new_v, v
- ) selection
+ let selection =
+ List.filter
+ (fun v -> List.exists (fun vid -> vid = v.var_id) scopes)
+ selection
+ in
+ let new_mems =
+ List.map
+ (fun v ->
+ (* We could copy the variable but then we need to update its type let
+ new_v = copy_var_decl v in *)
+ let new_v = { v with var_id = scope_var_name v.var_id } in
+ new_v, v)
+ selection
in
- { machine with
- mmemory = machine.mmemory @ (List.map fst new_mems);
- mstep = {
- machine.mstep with
- step_instrs = machine.mstep.step_instrs
- @ (mkinstr (MComment "Registering all flows"))::(List.map stateassign new_mems)
-
- }
+ {
+ machine with
+ mmemory = machine.mmemory @ List.map fst new_mems;
+ mstep =
+ {
+ machine.mstep with
+ step_instrs =
+ machine.mstep.step_instrs
+ @ mkinstr (MComment "Registering all flows")
+ :: List.map stateassign new_mems;
+ };
}
-
let rec is_valid_path path nodename prog machines =
let nodescopes = compute_scopes prog nodename in
let m = get_machine machines nodename in
match path with
- | [] -> assert false
- | [vid] -> let res = List.exists (fun v -> v.var_id = vid) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) in
- (* if not res then *)
- (* Format.eprintf "Variable %s cannot be found in machine %s@.Local vars are %a@." vid m.mname.node_id *)
- (* (Utils.fprintf_list ~sep:", " Printers.pp_var) (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals) *)
- (* ; *)
- res
-
- | _::nodename::path' -> (* We use the scopes computed on the prog artifact *)
- (* Format.eprintf "Path is %a@ Local scopes: @[<v>%a@ @]@." *)
- (* (Utils.fprintf_list ~sep:"." Format.pp_print_string) path *)
- (* (Utils.fprintf_list ~sep:";@ " *)
- (* (fun fmt scope -> *)
- (* Utils.fprintf_list ~sep:"." Format.pp_print_string fmt (scope_to_sl scope)) *)
- (* ) *)
- (* nodescopes; *)
- if List.mem path (List.map scope_to_sl nodescopes) then (
- (* Format.eprintf "Valid local path, checking underneath@."; *)
- is_valid_path path' nodename prog machines
- )
- else
- false
-
- (* let instok = List.exists (fun (inst', node) -> inst' = inst) m.minstances in *)
- (* if not instok then Format.eprintf "inst = %s@." inst; *)
- (* instok && *)
- (* let instnode = fst (snd (List.find (fun (inst', node) -> inst' = inst) m.minstances)) in *)
- (* is_valid_path path' (Corelang.node_of_top instnode).node_id prog machines *)
-
-
+ | [] ->
+ assert false
+ | [ vid ] ->
+ let res =
+ List.exists
+ (fun v -> v.var_id = vid)
+ (m.mmemory @ m.mstep.step_inputs @ m.mstep.step_locals)
+ in
+ (* if not res then *)
+ (* Format.eprintf "Variable %s cannot be found in machine %s@.Local vars are
+ %a@." vid m.mname.node_id *)
+ (* (Utils.fprintf_list ~sep:", " Printers.pp_var) (m.mmemory @
+ m.mstep.step_inputs @ m.mstep.step_locals) *)
+ (* ; *)
+ res
+ | _ :: nodename :: path' ->
+ (* We use the scopes computed on the prog artifact *)
+ (* Format.eprintf "Path is %a@ Local scopes: @[<v>%a@ @]@." *)
+ (* (Utils.fprintf_list ~sep:"." Format.pp_print_string) path *)
+ (* (Utils.fprintf_list ~sep:";@ " *)
+ (* (fun fmt scope -> *)
+ (* Utils.fprintf_list ~sep:"." Format.pp_print_string fmt (scope_to_sl scope)) *)
+ (* ) *)
+ (* nodescopes; *)
+ if List.mem path (List.map scope_to_sl nodescopes) then
+ (* Format.eprintf "Valid local path, checking underneath@."; *)
+ is_valid_path path' nodename prog machines
+ else false
+
+(* let instok = List.exists (fun (inst', node) -> inst' = inst) m.minstances in *)
+(* if not instok then Format.eprintf "inst = %s@." inst; *)
+(* instok && *)
+(* let instnode = fst (snd (List.find (fun (inst', node) -> inst' = inst)
+ m.minstances)) in *)
+(* is_valid_path path' (Corelang.node_of_top instnode).node_id prog machines *)
(****************************************************)
-
+
let scopes_def : string list list ref = ref []
+
let inputs = ref []
let option_show_scopes = ref false
+
let option_scopes = ref false
+
let option_all_scopes = ref false
(* let option_mems_scopes = ref false
* let option_input_scopes = ref false *)
-let scopes_map : (Lustre_types.ident list * scope_t) list ref = ref []
-
+let scopes_map : (Lustre_types.ident list * scope_t) list ref = ref []
+
let process_scopes main_node prog machines =
let all_scopes = compute_scopes prog !Options.main_node in
- let selected_scopes = if !option_all_scopes then
- List.map (fun s -> scope_to_sl s) all_scopes
- else
- !scopes_def
+ let selected_scopes =
+ if !option_all_scopes then List.map (fun s -> scope_to_sl s) all_scopes
+ else !scopes_def
in
(* Making sure all scopes are defined and were not removed by various
- optmizationq *)
- let selected_scopes =
- List.filter
- (fun sl ->
- let res = is_valid_path sl main_node prog machines in
- if not res then
- Format.eprintf "Scope %a is cancelled due to variable removal@." (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl;
- res
- )
- selected_scopes
+ optmizationq *)
+ let selected_scopes =
+ List.filter
+ (fun sl ->
+ let res = is_valid_path sl main_node prog machines in
+ if not res then
+ Format.eprintf "Scope %a is cancelled due to variable removal@."
+ (Utils.fprintf_list ~sep:"." Format.pp_print_string)
+ sl;
+ res)
+ selected_scopes
+ in
+ let scopes_map', machines_scopes =
+ check_scopes main_node prog machines all_scopes selected_scopes
in
- let scopes_map', machines_scopes = check_scopes main_node prog machines all_scopes selected_scopes in
scopes_map := scopes_map';
- (* Each machine is updated with fresh memories and declared as stateful *)
- let machines = List.map (fun m ->
- let mid = m.mname.node_id in
- if List.mem_assoc mid machines_scopes then
- let machine_scopes = List.assoc mid machines_scopes in
- update_machine main_node m machine_scopes
- else
- m) machines in
+ (* Each machine is updated with fresh memories and declared as stateful *)
+ let machines =
+ List.map
+ (fun m ->
+ let mid = m.mname.node_id in
+ if List.mem_assoc mid machines_scopes then
+ let machine_scopes = List.assoc mid machines_scopes in
+ update_machine main_node m machine_scopes
+ else m)
+ machines
+ in
machines
-let activate () =
+let activate () =
option_scopes := true;
- Options.optimization := 0; (* no optimization *)
+ Options.optimization := 0;
+ (* no optimization *)
()
-
-let register_scopes s =
+
+let register_scopes s =
activate ();
- option_all_scopes:=false;
+ option_all_scopes := false;
let scope_list = Str.split (Str.regexp ", *") s in
- let scope_list = List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list in
+ let scope_list =
+ List.map (fun scope -> Str.split (Str.regexp "\\.") scope) scope_list
+ in
scopes_def := List.rev scope_list
-let register_inputs s =
+let register_inputs s =
activate ();
let input_list = Str.split (Str.regexp "[;]") s in
- let input_list = List.map (fun s -> match Str.split (Str.regexp "=") s with | [v;e] -> v, e | _ -> raise (Invalid_argument ("Input list error: " ^ s))) input_list in
- let input_list = List.map (fun (v, e) -> v, Str.split (Str.regexp "[;]") e) input_list in
+ let input_list =
+ List.map
+ (fun s ->
+ match Str.split (Str.regexp "=") s with
+ | [ v; e ] ->
+ v, e
+ | _ ->
+ raise (Invalid_argument ("Input list error: " ^ s)))
+ input_list
+ in
+ let input_list =
+ List.map (fun (v, e) -> v, Str.split (Str.regexp "[;]") e) input_list
+ in
inputs := input_list
let register_all_scopes () =
activate ();
- option_all_scopes:= true
-
-module Plugin : (
- sig
- include PluginType.S
- val show_scopes: unit -> bool
- end) =
- 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"; *)
- ]
+ option_all_scopes := true
+
+module Plugin : sig
+ include PluginType.S
+
+ val show_scopes : unit -> bool
+end = 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"; *)
+ ]
let activate = activate
- let check_force_stateful () = is_active()
+ let check_force_stateful () = is_active ()
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 0>%a@ @]@.@?" print_scopes all_scopes;
- exit 0
- end;
- if is_active () then
- process_scopes !Options.main_node prog machine_code
- else
- machine_code
-
-
+ if show_scopes () then (
+ 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 0>%a@ @]@.@?" print_scopes all_scopes;
+ exit 0);
+ 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 "@ %a" pp_scopes !scopes_map
- end
+ if is_active () then Format.fprintf fmt "@ %a" pp_scopes !scopes_map
let c_backend_main_loop_body_prefix basename mname fmt () =
if is_active () then
- begin
- Format.fprintf fmt "@ %a" (pp_scopes_files basename mname) !scopes_map
- end
-
-
+ Format.fprintf fmt "@ %a" (pp_scopes_files basename mname) !scopes_map
end
let () =
- PluginList.registered := (module Plugin : PluginType.S) ::
- !PluginList.registered
+ PluginList.registered :=
+ (module Plugin : PluginType.S) :: !PluginList.registered
(* Local Variables: *)
(* compile-command:"make -C ../.." *)
(* End: *)
diff --git a/src/printers.ml b/src/printers.ml
index ff6d67d0dd62f9258e8d7325b812d4db0fe72dd3..09e4f8b39d05660152a742158f019d63ad7c43ad 100644
--- a/src/printers.ml
+++ b/src/printers.ml
@@ -13,59 +13,63 @@ open Lustre_types
open Utils
open Format
-let kind2_language_cst =
- [ "initial" ]
-
+let kind2_language_cst = [ "initial" ]
+
let kind2_protect id =
- if List.mem id kind2_language_cst then
- "_KIND2_PROTECT_" ^ id
- else
- id
-
-
+ if List.mem id kind2_language_cst then "_KIND2_PROTECT_" ^ id else id
+
(* Prints [v] as [pp_fun] would do, but adds a backslash at each end of line,
following the C convention for multiple lines macro *)
let pp_as_c_macro pp_fun fmt v =
let formatter_out_funs = pp_get_formatter_out_functions fmt () in
let macro_newline () =
- begin
- formatter_out_funs.out_string "\\" 0 1;
- formatter_out_funs.out_newline ()
- end in
- begin
- pp_set_formatter_out_functions fmt { formatter_out_funs with out_newline = macro_newline };
- pp_fun fmt v;
- pp_set_formatter_out_functions fmt formatter_out_funs;
- end
+ formatter_out_funs.out_string "\\" 0 1;
+ formatter_out_funs.out_newline ()
+ in
+ pp_set_formatter_out_functions fmt
+ { formatter_out_funs with out_newline = macro_newline };
+ pp_fun fmt v;
+ pp_set_formatter_out_functions fmt formatter_out_funs
let rec pp_var_struct_type_field fmt (label, tdesc) =
fprintf fmt "%a : %a;" pp_print_string label pp_var_type_dec_desc tdesc
+
and pp_var_type_dec_desc fmt tdesc =
- match tdesc with
- | Tydec_any -> fprintf fmt "<any>"
- | Tydec_int -> fprintf fmt "int"
- | Tydec_real -> fprintf fmt "real"
+ match tdesc with
+ | Tydec_any ->
+ fprintf fmt "<any>"
+ | Tydec_int ->
+ fprintf fmt "int"
+ | Tydec_real ->
+ fprintf fmt "real"
(* | Tydec_float -> fprintf fmt "float" *)
- | Tydec_bool -> fprintf fmt "bool"
- | Tydec_clock t -> fprintf fmt "%a clock" pp_var_type_dec_desc t
- | Tydec_const t -> fprintf fmt "%s" t
- | Tydec_enum id_list -> fprintf fmt "enum {%a }" (fprintf_list ~sep:", " pp_print_string) id_list
- | Tydec_struct f_list -> fprintf fmt "struct {%a }" (fprintf_list ~sep:" " pp_var_struct_type_field) f_list
- | Tydec_array (s, t) -> fprintf fmt "%a^%a" pp_var_type_dec_desc t Dimension.pp_dimension s
-
-let pp_var_type_dec fmt ty =
- pp_var_type_dec_desc fmt ty.ty_dec_desc
+ | Tydec_bool ->
+ fprintf fmt "bool"
+ | Tydec_clock t ->
+ fprintf fmt "%a clock" pp_var_type_dec_desc t
+ | Tydec_const t ->
+ fprintf fmt "%s" t
+ | Tydec_enum id_list ->
+ fprintf fmt "enum {%a }" (fprintf_list ~sep:", " pp_print_string) id_list
+ | Tydec_struct f_list ->
+ fprintf fmt "struct {%a }"
+ (fprintf_list ~sep:" " pp_var_struct_type_field)
+ f_list
+ | Tydec_array (s, t) ->
+ fprintf fmt "%a^%a" pp_var_type_dec_desc t Dimension.pp_dimension s
+
+let pp_var_type_dec fmt ty = pp_var_type_dec_desc fmt ty.ty_dec_desc
let pp_var_name fmt id =
- fprintf fmt "%s" (if !Options.kind2_print then kind2_protect id.var_id else id.var_id)
+ fprintf fmt "%s"
+ (if !Options.kind2_print then kind2_protect id.var_id else id.var_id)
let pp_var_type fmt id =
- if !Options.print_dec_types then
- pp_var_type_dec fmt id.var_dec_type
- else
- Types.print_node_ty fmt id.var_type
+ if !Options.print_dec_types then pp_var_type_dec fmt id.var_dec_type
+ else Types.print_node_ty fmt id.var_type
+
let pp_var_clock fmt id = Clocks.print_ck_suffix fmt id.var_clock
-
+
let pp_eq_lhs = fprintf_list ~sep:", " pp_print_string
let pp_var fmt id =
@@ -74,183 +78,208 @@ let pp_var fmt id =
(if !Options.kind2_print then kind2_protect id.var_id else id.var_id)
pp_var_type id
-let pp_vars fmt vars =
- fprintf_list ~sep:"; " pp_var fmt vars
-
+let pp_vars fmt vars = fprintf_list ~sep:"; " pp_var fmt vars
+
let pp_quantifiers fmt (q, vars) =
match q with
- | Forall -> fprintf fmt "forall %a" pp_vars vars
- | Exists -> fprintf fmt "exists %a" pp_vars vars
+ | Forall ->
+ fprintf fmt "forall %a" pp_vars vars
+ | Exists ->
+ fprintf fmt "exists %a" pp_vars vars
let rec pp_struct_const_field fmt (label, c) =
fprintf fmt "%a = %a;" pp_print_string label pp_const c
-and pp_const fmt c =
- match c with
- | Const_int i -> pp_print_int fmt i
- | Const_real r -> Real.pp fmt r
- (*if e = 0 then pp_print_int fmt c else if e < 0 then Format.fprintf fmt "%ie%i" c (-e) else Format.fprintf fmt "%ie-%i" c e *)
- (* | Const_float r -> pp_print_float fmt r *)
- | Const_tag t -> pp_print_string fmt t
- | Const_array ca -> fprintf fmt "[%a]" (Utils.fprintf_list ~sep:"," pp_const) ca
- | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:" " pp_struct_const_field) fl
-
- (* used only for annotations *)
- | Const_string s -> pp_print_string fmt ("\"" ^ s ^ "\"")
- | Const_modeid s -> pp_print_string fmt ("\"" ^ s ^ "\"")
+and pp_const fmt c =
+ match c with
+ | Const_int i ->
+ pp_print_int fmt i
+ | Const_real r ->
+ Real.pp fmt r
+ (*if e = 0 then pp_print_int fmt c else if e < 0 then Format.fprintf fmt
+ "%ie%i" c (-e) else Format.fprintf fmt "%ie-%i" c e *)
+ (* | Const_float r -> pp_print_float fmt r *)
+ | Const_tag t ->
+ pp_print_string fmt t
+ | Const_array ca ->
+ fprintf fmt "[%a]" (Utils.fprintf_list ~sep:"," pp_const) ca
+ | Const_struct fl ->
+ fprintf fmt "{%a }" (Utils.fprintf_list ~sep:" " pp_struct_const_field) fl
+ (* used only for annotations *)
+ | Const_string s ->
+ pp_print_string fmt ("\"" ^ s ^ "\"")
+ | Const_modeid s ->
+ pp_print_string fmt ("\"" ^ s ^ "\"")
let pp_annot_key fmt kwds =
match kwds with
- | [] -> assert false
- | [x] -> pp_print_string fmt x
- | _ -> fprintf fmt "/%a/" (fprintf_list ~sep:"/" pp_print_string) kwds
+ | [] ->
+ assert false
+ | [ x ] ->
+ pp_print_string fmt x
+ | _ ->
+ fprintf fmt "/%a/" (fprintf_list ~sep:"/" pp_print_string) kwds
let pp_kind2_when fmt (id, l) =
- if l = "true" then
- fprintf fmt "%s" id
- else if l = "false" then
- fprintf fmt "not(%s)" id
- else
- fprintf fmt "(%s=%s)" l id
-
-
+ if l = "true" then fprintf fmt "%s" id
+ else if l = "false" then fprintf fmt "not(%s)" id
+ else fprintf fmt "(%s=%s)" l id
+
let rec pp_expr fmt expr =
- (match expr.expr_annot with
- | None -> fprintf fmt "%t"
- | Some ann -> fprintf fmt "@[(%a %t)@]" pp_expr_annot ann)
- (fun fmt ->
- let pp fmt =
- match expr.expr_desc with
- | Expr_const c -> pp_const fmt c
- | Expr_ident id ->
- fprintf fmt "%s"
- (if !Options.kind2_print then kind2_protect id else id)
-
- | Expr_array a -> fprintf fmt "[%a]" pp_tuple a
- | Expr_access (a, d) -> fprintf fmt "%a[%a]" pp_expr a Dimension.pp_dimension d
- | Expr_power (a, d) -> fprintf fmt "(%a^%a)" pp_expr a Dimension.pp_dimension d
- | Expr_tuple el -> fprintf fmt "(%a)" pp_tuple el
- | Expr_ite (c, t, e) -> fprintf fmt "@[<hov 1>(if %a then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@])" pp_expr c pp_expr t pp_expr e
- | Expr_arrow (e1, e2) -> fprintf fmt "(%a -> %a)" pp_expr e1 pp_expr e2
- | Expr_fby (e1, e2) -> fprintf fmt "%a fby %a" pp_expr e1 pp_expr e2
- | Expr_pre e -> fprintf fmt "pre %a" pp_expr e
- | Expr_when (e, id, l) ->
- if !Options.kind2_print then
- fprintf fmt "%a when %a" pp_expr e pp_kind2_when (l, id)
- else
- fprintf fmt "%a when %s(%s)" pp_expr e l id
- | Expr_merge (id, hl) ->
- fprintf fmt "merge %s %a" id pp_handlers hl
- | Expr_appl (id, e, r) -> pp_app fmt id e r
+ (match expr.expr_annot with
+ | None ->
+ fprintf fmt "%t"
+ | Some ann ->
+ fprintf fmt "@[(%a %t)@]" pp_expr_annot ann) (fun fmt ->
+ let pp fmt =
+ match expr.expr_desc with
+ | Expr_const c ->
+ pp_const fmt c
+ | Expr_ident id ->
+ fprintf fmt "%s"
+ (if !Options.kind2_print then kind2_protect id else id)
+ | Expr_array a ->
+ fprintf fmt "[%a]" pp_tuple a
+ | Expr_access (a, d) ->
+ fprintf fmt "%a[%a]" pp_expr a Dimension.pp_dimension d
+ | Expr_power (a, d) ->
+ fprintf fmt "(%a^%a)" pp_expr a Dimension.pp_dimension d
+ | Expr_tuple el ->
+ fprintf fmt "(%a)" pp_tuple el
+ | Expr_ite (c, t, e) ->
+ fprintf fmt
+ "@[<hov 1>(if %a then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@])"
+ pp_expr c pp_expr t pp_expr e
+ | Expr_arrow (e1, e2) ->
+ fprintf fmt "(%a -> %a)" pp_expr e1 pp_expr e2
+ | Expr_fby (e1, e2) ->
+ fprintf fmt "%a fby %a" pp_expr e1 pp_expr e2
+ | Expr_pre e ->
+ fprintf fmt "pre %a" pp_expr e
+ | Expr_when (e, id, l) ->
+ if !Options.kind2_print then
+ fprintf fmt "%a when %a" pp_expr e pp_kind2_when (l, id)
+ else fprintf fmt "%a when %s(%s)" pp_expr e l id
+ | Expr_merge (id, hl) ->
+ fprintf fmt "merge %s %a" id pp_handlers hl
+ | Expr_appl (id, e, r) ->
+ pp_app fmt id e r
in
- if false (* extra debug *)
- then
- Format.fprintf fmt "%t: %a" pp Types.print_ty expr.expr_type
- else
- pp fmt
- )
-and pp_tuple fmt el =
- fprintf_list ~sep:"," pp_expr fmt el
+ if false (* extra debug *) then
+ Format.fprintf fmt "%t: %a" pp Types.print_ty expr.expr_type
+ else pp fmt)
-and pp_handler fmt (t, h) =
- fprintf fmt "(%s -> %a)" t pp_expr h
+and pp_tuple fmt el = fprintf_list ~sep:"," pp_expr fmt el
-and pp_handlers fmt hl =
- fprintf_list ~sep:" " pp_handler fmt hl
+and pp_handler fmt (t, h) = fprintf fmt "(%s -> %a)" t pp_expr h
+
+and pp_handlers fmt hl = fprintf_list ~sep:" " pp_handler fmt hl
and pp_app fmt id e r =
- if !Options.kind2_print &&
- not (List.mem id Basic_library.internal_funs) then
- (* We only translate calls to nodes in kind2. The other may be
- rejected by Kind2 *)
- ( (* Small local function to extract the first layer of when constructs *)
- let rec un_when_ed_expr e =
- match e.expr_desc with
- Expr_when (e,i,l) -> (Some (i,l)), e
- | Expr_tuple el -> (
- let un_when_ed_el = List.map un_when_ed_expr el in
- if List.length un_when_ed_el < 1 then
- assert false; (* tuple should have at least one element*)
- let init_when =
- fst (List.hd un_when_ed_el)
- in
- let common_when =
- List.fold_left (fun accu (new_opt,_) ->
- match accu, new_opt with
- | Some c1, Some c2 ->
- if c1 = c2 then
- Some c1
- else
- assert false (* should not be clocked *)
- | None, None -> None
- | _ -> assert false (* If this is not even, there
- should be a clocking problem*)
- ) init_when (List.tl un_when_ed_el)
- in
- match common_when with
- | None -> None, e
- | Some _ -> common_when, { e with expr_desc =
- Expr_tuple (List.map snd un_when_ed_el) }
- )
- | _ -> None, e
- in
- let when_expr, _ = un_when_ed_expr e in
- match r, when_expr with
- | None, None -> pp_call fmt id e
- | None, Some w ->
- fprintf fmt "(activate %s every (%a)) (%a)"
- id
- pp_kind2_when w
- pp_expr e
- | Some r, None ->
- fprintf fmt "(restart %s every (%a)) (%a)"
- id
- pp_expr r
- pp_expr e
- | Some r, Some w ->
- fprintf fmt "(activate %s every (%a) restart every (%a)) (%a)"
- id
- pp_kind2_when w
- pp_expr r
- pp_expr e
- )
-
- else (
+ if !Options.kind2_print && not (List.mem id Basic_library.internal_funs) then
+ (* We only translate calls to nodes in kind2. The other may be rejected by
+ Kind2 *)
+ (* Small local function to extract the first layer of when constructs *)
+ let rec un_when_ed_expr e =
+ match e.expr_desc with
+ | Expr_when (e, i, l) ->
+ Some (i, l), e
+ | Expr_tuple el -> (
+ let un_when_ed_el = List.map un_when_ed_expr el in
+ if List.length un_when_ed_el < 1 then assert false;
+ (* tuple should have at least one element*)
+ let init_when = fst (List.hd un_when_ed_el) in
+ let common_when =
+ List.fold_left
+ (fun accu (new_opt, _) ->
+ match accu, new_opt with
+ | Some c1, Some c2 ->
+ if c1 = c2 then Some c1
+ else assert false (* should not be clocked *)
+ | None, None ->
+ None
+ | _ ->
+ assert false
+ (* If this is not even, there should be a clocking problem*))
+ init_when (List.tl un_when_ed_el)
+ in
+ match common_when with
+ | None ->
+ None, e
+ | Some _ ->
+ ( common_when,
+ { e with expr_desc = Expr_tuple (List.map snd un_when_ed_el) } ))
+ | _ ->
+ None, e
+ in
+ let when_expr, _ = un_when_ed_expr e in
+ match r, when_expr with
+ | None, None ->
+ pp_call fmt id e
+ | None, Some w ->
+ fprintf fmt "(activate %s every (%a)) (%a)" id pp_kind2_when w pp_expr e
+ | Some r, None ->
+ fprintf fmt "(restart %s every (%a)) (%a)" id pp_expr r pp_expr e
+ | Some r, Some w ->
+ fprintf fmt "(activate %s every (%a) restart every (%a)) (%a)" id
+ pp_kind2_when w pp_expr r pp_expr e
+ else
match r with
- | None -> pp_call fmt id e
+ | None ->
+ pp_call fmt id e
| Some c ->
- fprintf fmt "%t every (%a)" (fun fmt -> pp_call fmt id e) pp_expr c
- )
-
+ fprintf fmt "%t every (%a)" (fun fmt -> pp_call fmt id e) pp_expr c
+
and pp_call fmt id e =
match id, e.expr_desc with
- | "+", Expr_tuple([e1;e2]) -> fprintf fmt "(%a + %a)" pp_expr e1 pp_expr e2
- | "uminus", _ -> fprintf fmt "(- %a)" pp_expr e
- | "-", Expr_tuple([e1;e2]) -> fprintf fmt "(%a - %a)" pp_expr e1 pp_expr e2
- | "*", Expr_tuple([e1;e2]) -> fprintf fmt "(%a * %a)" pp_expr e1 pp_expr e2
- | "/", Expr_tuple([e1;e2]) -> fprintf fmt "(%a / %a)" pp_expr e1 pp_expr e2
- | "mod", Expr_tuple([e1;e2]) -> fprintf fmt "(%a mod %a)" pp_expr e1 pp_expr e2
- | "&&", Expr_tuple([e1;e2]) -> fprintf fmt "(%a and %a)" pp_expr e1 pp_expr e2
- | "||", Expr_tuple([e1;e2]) -> fprintf fmt "(%a or %a)" pp_expr e1 pp_expr e2
- | "xor", Expr_tuple([e1;e2]) -> fprintf fmt "(%a xor %a)" pp_expr e1 pp_expr e2
- | "impl", Expr_tuple([e1;e2]) -> fprintf fmt "(%a => %a)" pp_expr e1 pp_expr e2
- | "<", Expr_tuple([e1;e2]) -> fprintf fmt "(%a < %a)" pp_expr e1 pp_expr e2
- | "<=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a <= %a)" pp_expr e1 pp_expr e2
- | ">", Expr_tuple([e1;e2]) -> fprintf fmt "(%a > %a)" pp_expr e1 pp_expr e2
- | ">=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a >= %a)" pp_expr e1 pp_expr e2
- | "!=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a <> %a)" pp_expr e1 pp_expr e2
- | "=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a = %a)" pp_expr e1 pp_expr e2
- | "not", _ -> fprintf fmt "(not %a)" pp_expr e
- | _, Expr_tuple _ -> fprintf fmt "%s %a" id pp_expr e
- | _ -> fprintf fmt "%s (%a)" id pp_expr e
+ | "+", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a + %a)" pp_expr e1 pp_expr e2
+ | "uminus", _ ->
+ fprintf fmt "(- %a)" pp_expr e
+ | "-", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a - %a)" pp_expr e1 pp_expr e2
+ | "*", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a * %a)" pp_expr e1 pp_expr e2
+ | "/", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a / %a)" pp_expr e1 pp_expr e2
+ | "mod", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a mod %a)" pp_expr e1 pp_expr e2
+ | "&&", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a and %a)" pp_expr e1 pp_expr e2
+ | "||", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a or %a)" pp_expr e1 pp_expr e2
+ | "xor", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a xor %a)" pp_expr e1 pp_expr e2
+ | "impl", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a => %a)" pp_expr e1 pp_expr e2
+ | "<", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a < %a)" pp_expr e1 pp_expr e2
+ | "<=", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a <= %a)" pp_expr e1 pp_expr e2
+ | ">", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a > %a)" pp_expr e1 pp_expr e2
+ | ">=", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a >= %a)" pp_expr e1 pp_expr e2
+ | "!=", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a <> %a)" pp_expr e1 pp_expr e2
+ | "=", Expr_tuple [ e1; e2 ] ->
+ fprintf fmt "(%a = %a)" pp_expr e1 pp_expr e2
+ | "not", _ ->
+ fprintf fmt "(not %a)" pp_expr e
+ | _, Expr_tuple _ ->
+ fprintf fmt "%s %a" id pp_expr e
+ | _ ->
+ fprintf fmt "%s (%a)" id pp_expr e
and pp_eexpr fmt e =
fprintf fmt "%a%t %a"
- (Utils.fprintf_list ~sep:"; " pp_quantifiers) e.eexpr_quantifiers
- (fun fmt -> match e.eexpr_quantifiers with [] -> () | _ -> fprintf fmt ";")
+ (Utils.fprintf_list ~sep:"; " pp_quantifiers)
+ e.eexpr_quantifiers
+ (fun fmt ->
+ match e.eexpr_quantifiers with [] -> () | _ -> fprintf fmt ";")
pp_expr e.eexpr_qfexpr
-and pp_sf_value fmt e =
+and pp_sf_value fmt e =
fprintf fmt "%a"
(* (Utils.fprintf_list ~sep:"; " pp_quantifiers) e.eexpr_quantifiers *)
(* (fun fmt -> match e.eexpr_quantifiers *)
@@ -261,111 +290,104 @@ and pp_sf_value fmt e =
and pp_s_function fmt expr_ann =
let pp_annot fmt (kwds, ee) =
fprintf fmt " %t : %a"
- (fun fmt -> match kwds with
- | [] -> assert false
- | [x] -> pp_print_string fmt x
- | _ -> fprintf fmt "%a" (fprintf_list ~sep:"/" pp_print_string) kwds)
+ (fun fmt ->
+ match kwds with
+ | [] ->
+ assert false
+ | [ x ] ->
+ pp_print_string fmt x
+ | _ ->
+ fprintf fmt "%a" (fprintf_list ~sep:"/" pp_print_string) kwds)
pp_sf_value ee
in
fprintf_list ~sep:"@ " pp_annot fmt expr_ann.annots
and pp_expr_annot fmt expr_ann =
let pp_annot fmt (kwds, ee) =
- fprintf fmt "(*!%a: %a; *)"
- pp_annot_key kwds
- pp_eexpr ee
+ fprintf fmt "(*!%a: %a; *)" pp_annot_key kwds pp_eexpr ee
in
fprintf_list ~sep:"@ " pp_annot fmt expr_ann.annots
-
let pp_asserts fmt asserts =
- match asserts with
- | _::_ -> (
+ match asserts with
+ | _ :: _ ->
fprintf fmt "(* Asserts definitions *)@ ";
- fprintf_list ~sep:"@ " (fun fmt assert_ ->
- let expr = assert_.assert_expr in
- fprintf fmt "assert %a;" pp_expr expr
- ) fmt asserts
- )
- | _ -> ()
-
-(*
-let pp_node_var fmt id = fprintf fmt "%s%s: %a(%a)%a" (if id.var_dec_const then "const " else "") id.var_id print_dec_ty id.var_dec_type.ty_dec_desc Types.print_ty id.var_type Clocks.print_ck_suffix id.var_clock
-*)
+ fprintf_list ~sep:"@ "
+ (fun fmt assert_ ->
+ let expr = assert_.assert_expr in
+ fprintf fmt "assert %a;" pp_expr expr)
+ fmt asserts
+ | _ ->
+ ()
+
+(* let pp_node_var fmt id = fprintf fmt "%s%s: %a(%a)%a" (if id.var_dec_const
+ then "const " else "") id.var_id print_dec_ty id.var_dec_type.ty_dec_desc
+ Types.print_ty id.var_type Clocks.print_ck_suffix id.var_clock *)
let pp_node_var fmt id =
- begin
- fprintf fmt "%s%s: %a%a"
- (if id.var_dec_const then "const " else "")
- (if !Options.kind2_print then kind2_protect id.var_id else id.var_id)
- pp_var_type id
- pp_var_clock id;
- match id.var_dec_value with
- | None -> ()
- | Some v -> fprintf fmt " = %a" pp_expr v
- end
-
-let pp_node_args = fprintf_list ~sep:";@ " pp_node_var
-
-let pp_node_eq fmt eq =
- fprintf fmt "%a = %a;"
- pp_eq_lhs eq.eq_lhs
- pp_expr eq.eq_rhs
+ fprintf fmt "%s%s: %a%a"
+ (if id.var_dec_const then "const " else "")
+ (if !Options.kind2_print then kind2_protect id.var_id else id.var_id)
+ pp_var_type id pp_var_clock id;
+ match id.var_dec_value with
+ | None ->
+ ()
+ | Some v ->
+ fprintf fmt " = %a" pp_expr v
+
+let pp_node_args = fprintf_list ~sep:";@ " pp_node_var
+
+let pp_node_eq fmt eq =
+ fprintf fmt "%a = %a;" pp_eq_lhs eq.eq_lhs pp_expr eq.eq_rhs
let pp_restart fmt restart =
fprintf fmt "%s" (if restart then "restart" else "resume")
let pp_unless fmt (_, expr, restart, st) =
- fprintf fmt "unless %a %a %s"
- pp_expr expr
- pp_restart restart
- st
+ fprintf fmt "unless %a %a %s" pp_expr expr pp_restart restart st
let pp_until fmt (_, expr, restart, st) =
- fprintf fmt "until %a %a %s"
- pp_expr expr
- pp_restart restart
- st
+ fprintf fmt "until %a %a %s" pp_expr expr pp_restart restart st
let rec pp_handler fmt handler =
fprintf fmt "state %s:@ @[<v 2> %a%t%alet@,@[<v 2> %a@ %a@ %a@]@,tel@ %a@]"
handler.hand_state
- (Utils.fprintf_list ~sep:"@ " pp_unless) handler.hand_unless
+ (Utils.fprintf_list ~sep:"@ " pp_unless)
+ handler.hand_unless
(fun fmt -> if not ([] = handler.hand_unless) then fprintf fmt "@ ")
(fun fmt locals ->
- match locals with [] -> () | _ ->
- fprintf fmt "@[<v 4>var %a@]@ "
- (Utils.fprintf_list ~sep:"@ "
- (fun fmt v -> fprintf fmt "%a;" pp_node_var v))
- locals)
+ match locals with
+ | [] ->
+ ()
+ | _ ->
+ fprintf fmt "@[<v 4>var %a@]@ "
+ (Utils.fprintf_list ~sep:"@ " (fun fmt v ->
+ fprintf fmt "%a;" pp_node_var v))
+ locals)
handler.hand_locals
- (fprintf_list ~sep:"@ " pp_expr_annot) handler.hand_annots
- pp_node_stmts handler.hand_stmts
- pp_asserts handler.hand_asserts
- (Utils.fprintf_list ~sep:"@," pp_until) handler.hand_until
+ (fprintf_list ~sep:"@ " pp_expr_annot)
+ handler.hand_annots pp_node_stmts handler.hand_stmts pp_asserts
+ handler.hand_asserts
+ (Utils.fprintf_list ~sep:"@," pp_until)
+ handler.hand_until
and pp_node_stmt fmt stmt =
- match stmt with
- | Eq eq -> pp_node_eq fmt eq
- | Aut aut -> pp_node_aut fmt aut
+ match stmt with Eq eq -> pp_node_eq fmt eq | Aut aut -> pp_node_aut fmt aut
and pp_node_stmts fmt stmts =
- pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_sep:pp_print_cut
- pp_node_stmt fmt stmts
+ pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_sep:pp_print_cut pp_node_stmt fmt
+ stmts
and pp_node_aut fmt aut =
- fprintf fmt "@[<v 0>automaton %s@,%a@]"
- aut.aut_id
- (Utils.fprintf_list ~sep:"@ " pp_handler) aut.aut_handlers
+ fprintf fmt "@[<v 0>automaton %s@,%a@]" aut.aut_id
+ (Utils.fprintf_list ~sep:"@ " pp_handler)
+ aut.aut_handlers
and pp_node_eqs fmt eqs = fprintf_list ~sep:"@ " pp_node_eq fmt eqs
let pp_typedef fmt ty =
fprintf fmt "type %s = %a;" ty.tydef_id pp_var_type_dec_desc ty.tydef_desc
-let pp_typedec fmt ty =
- fprintf fmt "type %s;" ty.tydec_id
+let pp_typedec fmt ty = fprintf fmt "type %s;" ty.tydec_id
(* let rec pp_var_type fmt ty = *)
(* fprintf fmt "%a" (match ty.tdesc with *)
@@ -378,193 +400,204 @@ let pp_typedec fmt ty =
(* | Ttuple tel -> fprintf_list ~sep:" * " pp_var_type fmt tel *)
(* ) *)
-
-
(* let pp_quantifiers fmt (q, vars) =
* match q with
* | Forall -> fprintf fmt "forall %a" pp_vars vars
- * | Exists -> fprintf fmt "exists %a" (fprintf_list ~sep:"; " pp_var) vars *)
+ * | Exists -> fprintf fmt "exists %a" (fprintf_list ~sep:"; " pp_var) vars *)
+
+(*let pp_eexpr fmt e = fprintf fmt "%a%t %a" (Utils.fprintf_list ~sep:"; "
+ pp_quantifiers) e.eexpr_quantifiers (fun fmt -> match e.eexpr_quantifiers with
+ [] -> () | _ -> fprintf fmt ";") pp_expr e.eexpr_qfexpr *)
+
+let pp_spec_eq fmt eq =
+ fprintf fmt "var %a : %a = %a;" pp_eq_lhs eq.eq_lhs Types.print_node_ty
+ eq.eq_rhs.expr_type pp_expr eq.eq_rhs
-(*let pp_eexpr fmt e =
- fprintf fmt "%a%t %a"
- (Utils.fprintf_list ~sep:"; " pp_quantifiers) e.eexpr_quantifiers
- (fun fmt -> match e.eexpr_quantifiers with [] -> () | _ -> fprintf fmt ";")
- pp_expr e.eexpr_qfexpr
- *)
-
-let pp_spec_eq fmt eq =
- fprintf fmt "var %a : %a = %a;"
- pp_eq_lhs eq.eq_lhs
- Types.print_node_ty eq.eq_rhs.expr_type
- pp_expr eq.eq_rhs
-
let pp_spec_stmt fmt stmt =
- match stmt with
- | Eq eq -> pp_spec_eq fmt eq
- | Aut _ -> assert false (* Not supported yet *)
-
-
+ match stmt with Eq eq -> pp_spec_eq fmt eq | Aut _ -> assert false
+(* Not supported yet *)
+
let pp_spec fmt spec =
(* const are prefixed with const in pp_var and with nothing for regular
variables. We adapt the call to produce the appropriate output. *)
- fprintf_list ~eol:"@, " ~sep:"@, " (fun fmt v ->
- fprintf fmt "%a = %t;"
- pp_var v
- (fun fmt -> match v.var_dec_value with None -> assert false | Some e -> pp_expr fmt e)
- ) fmt spec.consts;
-
- fprintf_list ~eol:"@, " ~sep:"@, " (fun fmt s -> pp_spec_stmt fmt s) fmt spec.stmts;
- fprintf_list ~eol:"@, " ~sep:"@, " (fun fmt r -> fprintf fmt "assume %a;" pp_eexpr r) fmt spec.assume;
- fprintf_list ~eol:"@, " ~sep:"@, " (fun fmt r -> fprintf fmt "guarantee %a;" pp_eexpr r) fmt spec.guarantees;
- fprintf_list ~eol:"@, " ~sep:"@, " (fun fmt mode ->
- fprintf fmt "mode %s (@[<v 0>%a@ %a@]);"
- mode.mode_id
- (fprintf_list ~eol:"" ~sep:"@ " (fun fmt r -> fprintf fmt "require %a;" pp_eexpr r)) mode.require
- (fprintf_list ~eol:"" ~sep:"@ " (fun fmt r -> fprintf fmt "ensure %a;" pp_eexpr r)) mode.ensure
- ) fmt spec.modes;
- fprintf_list ~eol:"@, " ~sep:"@, " (fun fmt import ->
- fprintf fmt "import %s (%a) returns (%a);"
- import.import_nodeid
- pp_expr import.inputs
- pp_expr import.outputs
- ) fmt spec.imports
-
-(* Project the contract node as a pure contract: local memories are pushed back in the contract definition. Should mainly be used to print it *)
+ fprintf_list ~eol:"@, " ~sep:"@, "
+ (fun fmt v ->
+ fprintf fmt "%a = %t;" pp_var v (fun fmt ->
+ match v.var_dec_value with
+ | None ->
+ assert false
+ | Some e ->
+ pp_expr fmt e))
+ fmt spec.consts;
+
+ fprintf_list ~eol:"@, " ~sep:"@, "
+ (fun fmt s -> pp_spec_stmt fmt s)
+ fmt spec.stmts;
+ fprintf_list ~eol:"@, " ~sep:"@, "
+ (fun fmt r -> fprintf fmt "assume %a;" pp_eexpr r)
+ fmt spec.assume;
+ fprintf_list ~eol:"@, " ~sep:"@, "
+ (fun fmt r -> fprintf fmt "guarantee %a;" pp_eexpr r)
+ fmt spec.guarantees;
+ fprintf_list ~eol:"@, " ~sep:"@, "
+ (fun fmt mode ->
+ fprintf fmt "mode %s (@[<v 0>%a@ %a@]);" mode.mode_id
+ (fprintf_list ~eol:"" ~sep:"@ " (fun fmt r ->
+ fprintf fmt "require %a;" pp_eexpr r))
+ mode.require
+ (fprintf_list ~eol:"" ~sep:"@ " (fun fmt r ->
+ fprintf fmt "ensure %a;" pp_eexpr r))
+ mode.ensure)
+ fmt spec.modes;
+ fprintf_list ~eol:"@, " ~sep:"@, "
+ (fun fmt import ->
+ fprintf fmt "import %s (%a) returns (%a);" import.import_nodeid pp_expr
+ import.inputs pp_expr import.outputs)
+ fmt spec.imports
+
+(* Project the contract node as a pure contract: local memories are pushed back
+ in the contract definition. Should mainly be used to print it *)
let node_as_contract nd =
match nd.node_spec with
- | None | Some (NodeSpec _) -> raise (Invalid_argument "Not a contract")
- | Some (Contract c) -> (
- (* While a processed contract shall have no locals, sttms nor
- consts, an unprocessed one could. So we conservatively merge
- elements, to enable printing unprocessed contracts *)
- let consts, locals = List.partition(fun v -> v.var_dec_const) nd.node_locals in
- { c with
+ | None | Some (NodeSpec _) ->
+ raise (Invalid_argument "Not a contract")
+ | Some (Contract c) ->
+ (* While a processed contract shall have no locals, sttms nor consts, an
+ unprocessed one could. So we conservatively merge elements, to enable
+ printing unprocessed contracts *)
+ let consts, locals =
+ List.partition (fun v -> v.var_dec_const) nd.node_locals
+ in
+ {
+ c with
consts = consts @ c.consts;
locals = locals @ c.locals;
stmts = nd.node_stmts @ c.stmts;
}
- )
-(* Printing top contract as comments in regular output and as contract
- in kind2 *)
-let pp_contract fmt nd =
- let c = node_as_contract nd in
+(* Printing top contract as comments in regular output and as contract in kind2 *)
+let pp_contract fmt nd =
+ let c = node_as_contract nd in
fprintf fmt "@[<v 2>%scontract %s(%a) returns (%a);@ "
(if !Options.kind2_print then "" else "(*@")
- nd.node_id
- pp_node_args nd.node_inputs
- pp_node_args nd.node_outputs;
+ nd.node_id pp_node_args nd.node_inputs pp_node_args nd.node_outputs;
fprintf fmt "@[<v 2>let@ ";
pp_spec fmt c;
- fprintf fmt "@]@ tel@ @]%s@ "
- (if !Options.kind2_print then "" else "*)")
-
+ fprintf fmt "@]@ tel@ @]%s@ " (if !Options.kind2_print then "" else "*)")
+
let pp_spec_as_comment fmt (inl, outl, spec) =
match spec with
- | Contract c -> (* should have been processed by now *)
- fprintf fmt "@[<hov 2>(*@contract@ ";
- pp_spec fmt c;
- fprintf fmt "@]*)@ "
-
- | NodeSpec name -> (* Pushing stmts in contract. We update the
- original information with the computed one in
- nd. *)
- let pp_l = fprintf_list ~sep:"," pp_var_name in
- fprintf fmt "@[<hov 2>(*@contract import %s(%a) returns (%a); @]*)@ "
- name
- pp_l inl
- pp_l outl
-
+ | Contract c ->
+ (* should have been processed by now *)
+ fprintf fmt "@[<hov 2>(*@contract@ ";
+ pp_spec fmt c;
+ fprintf fmt "@]*)@ "
+ | NodeSpec name ->
+ (* Pushing stmts in contract. We update the original information with the
+ computed one in nd. *)
+ let pp_l = fprintf_list ~sep:"," pp_var_name in
+ fprintf fmt "@[<hov 2>(*@contract import %s(%a) returns (%a); @]*)@ " name
+ pp_l inl pp_l outl
+
let pp_node_vs_function fmt nd =
fprintf fmt "%s" (if nd.node_dec_stateless then "function" else "node")
-
+
let pp_node fmt nd =
(* Prototype *)
- fprintf fmt "%a @[<hov 0>%s (@[%a)@]@ returns (@[%a)@]@]@ "
- pp_node_vs_function nd
- nd.node_id
- pp_node_args nd.node_inputs
- pp_node_args nd.node_outputs;
+ fprintf fmt "%a @[<hov 0>%s (@[%a)@]@ returns (@[%a)@]@]@ "
+ pp_node_vs_function nd nd.node_id pp_node_args nd.node_inputs pp_node_args
+ nd.node_outputs;
(* Contracts *)
fprintf fmt "%a"
- (fun fmt s -> match s with
- | Some s -> pp_spec_as_comment fmt (nd.node_inputs, nd.node_outputs, s)
- | _ -> ()) nd.node_spec
- (* (fun fmt -> match nd.node_spec with None -> () | Some _ -> fprintf fmt "@ ") *);
+ (fun fmt s ->
+ match s with
+ | Some s ->
+ pp_spec_as_comment fmt (nd.node_inputs, nd.node_outputs, s)
+ | _ ->
+ ())
+ nd.node_spec
+ (* (fun fmt -> match nd.node_spec with None -> () | Some _ -> fprintf fmt "@
+ ") *);
(* Locals *)
- fprintf fmt "%a" (fun fmt locals ->
+ fprintf fmt "%a"
+ (fun fmt locals ->
match locals with
- | [] -> ()
+ | [] ->
+ ()
| _ ->
fprintf fmt "@[<v 4>var %a@]@ "
- (fprintf_list ~sep:"@ "
- (fun fmt v -> fprintf fmt "%a;" pp_node_var v))
- locals
- ) nd.node_locals;
+ (fprintf_list ~sep:"@ " (fun fmt v -> fprintf fmt "%a;" pp_node_var v))
+ locals)
+ nd.node_locals;
(* Checks *)
fprintf fmt "%a"
(fun fmt checks ->
- match checks with
- | [] -> ()
- | _ ->
- fprintf fmt "@[<v 4>check@ %a@]@ "
- (fprintf_list ~sep:"@ "
- (fun fmt d -> fprintf fmt "%a" Dimension.pp_dimension d))
- checks
- ) nd.node_checks;
+ match checks with
+ | [] ->
+ ()
+ | _ ->
+ fprintf fmt "@[<v 4>check@ %a@]@ "
+ (fprintf_list ~sep:"@ " (fun fmt d ->
+ fprintf fmt "%a" Dimension.pp_dimension d))
+ checks)
+ nd.node_checks;
(* Body *)
fprintf fmt "@[<v 2>let@ ";
(* Annotations *)
fprintf fmt "%a" (fprintf_list ~sep:"@ " pp_expr_annot) nd.node_annot;
(* Statements *)
fprintf fmt "%a" pp_node_stmts nd.node_stmts;
- (* Asserts *)
+ (* Asserts *)
fprintf fmt "%a" pp_asserts nd.node_asserts;
- (* closing boxes body (2) and node (1) *)
+ (* closing boxes body (2) and node (1) *)
fprintf fmt "@]@ tel"
-
-(*fprintf fmt "@ /* Scheduling: %a */ @ " (fprintf_list ~sep:", " pp_print_string) (Scheduling.schedule_node nd)*)
+(*fprintf fmt "@ /* Scheduling: %a */ @ " (fprintf_list ~sep:", "
+ pp_print_string) (Scheduling.schedule_node nd)*)
let pp_node fmt nd =
match nd.node_spec, nd.node_iscontract with
- | None, false
- | Some (NodeSpec _), false ->
+ | None, false | Some (NodeSpec _), false ->
pp_node fmt nd
| Some (Contract _), false ->
pp_node fmt nd (* may happen early in the compil process *)
| Some (Contract _), true ->
pp_contract fmt nd
- | _ -> assert false
-
-let pp_imported_node fmt ind =
+ | _ ->
+ assert false
+
+let pp_imported_node fmt ind =
fprintf fmt "@[<v 0>";
(* Prototype *)
- fprintf fmt "%s @[<hov 0>%s (@[%a)@]@ returns (@[%a)@]@]@ "
+ fprintf fmt "%s @[<hov 0>%s (@[%a)@]@ returns (@[%a)@]@]@ "
(if ind.nodei_stateless then "function" else "node")
- ind.nodei_id
- pp_node_args ind.nodei_inputs
- pp_node_args ind.nodei_outputs;
+ ind.nodei_id pp_node_args ind.nodei_inputs pp_node_args ind.nodei_outputs;
(* Contracts *)
fprintf fmt "%a%t"
- (fun fmt s -> match s with Some s -> pp_spec_as_comment fmt (ind.nodei_inputs, ind.nodei_outputs, s) | _ -> ()) ind.nodei_spec
- (fun fmt -> match ind.nodei_spec with None -> () | Some _ -> fprintf fmt "@ ");
+ (fun fmt s ->
+ match s with
+ | Some s ->
+ pp_spec_as_comment fmt (ind.nodei_inputs, ind.nodei_outputs, s)
+ | _ ->
+ ())
+ ind.nodei_spec
+ (fun fmt ->
+ match ind.nodei_spec with None -> () | Some _ -> fprintf fmt "@ ");
fprintf fmt "@]@ "
-
let pp_const_decl fmt cdecl =
fprintf fmt "%s = %a;" cdecl.const_id pp_const cdecl.const_value
-let pp_const_decl_list fmt clist =
+let pp_const_decl_list fmt clist =
fprintf_list ~sep:"@ " pp_const_decl fmt clist
-
let pp_decl fmt decl =
match decl.top_decl_desc with
| Node nd ->
fprintf fmt "%a" pp_node nd
- | ImportedNode ind -> (* We do not print imported nodes *)
- fprintf fmt "(* imported %a; *)" pp_imported_node ind
+ | ImportedNode ind ->
+ (* We do not print imported nodes *)
+ fprintf fmt "(* imported %a; *)" pp_imported_node ind
| Const c ->
fprintf fmt "const %a" pp_const_decl c
| Open (local, s) ->
@@ -573,74 +606,90 @@ let pp_decl fmt decl =
fprintf fmt "include \"%s\"" s
| TypeDef tdef ->
fprintf fmt "%a" pp_typedef tdef
-
+
let pp_prog pp_decl fmt prog =
(* we first print types: the function SortProg.sort could do the job but ut
introduces a cyclic dependance *)
-
let open_decl, prog =
- List.partition (fun decl -> match decl.top_decl_desc with
- Open _ -> true | _ -> false) prog
+ List.partition
+ (fun decl -> match decl.top_decl_desc with Open _ -> true | _ -> false)
+ prog
in
let type_decl, prog =
- List.partition (fun decl -> match decl.top_decl_desc with
- TypeDef _ -> true | _ -> false) prog
+ List.partition
+ (fun decl ->
+ match decl.top_decl_desc with TypeDef _ -> true | _ -> false)
+ prog
in
- pp_print_list
- ~pp_open_box:pp_open_vbox0
- ~pp_sep:pp_print_cutcut
- pp_decl
- fmt
+ pp_print_list ~pp_open_box:pp_open_vbox0 ~pp_sep:pp_print_cutcut pp_decl fmt
(open_decl @ type_decl @ prog)
(* Gives a short overview of model content. Do not print all node content *)
let pp_short_decl fmt decl =
match decl.top_decl_desc with
- | Node nd -> fprintf fmt "%a %s@ "
- pp_node_vs_function nd
- nd.node_id
- | ImportedNode ind -> fprintf fmt "imported node %s" ind.nodei_id
- | Const c -> fprintf fmt "const %a@ " pp_const_decl c
- | Include s -> fprintf fmt "include \"%s\"" s
- | Open (local, s) -> if local then fprintf fmt "#open \"%s\"@ " s else fprintf fmt "#open <%s>@ " s
- | TypeDef tdef -> fprintf fmt "type %s;@ " tdef.tydef_id
+ | Node nd ->
+ fprintf fmt "%a %s@ " pp_node_vs_function nd nd.node_id
+ | ImportedNode ind ->
+ fprintf fmt "imported node %s" ind.nodei_id
+ | Const c ->
+ fprintf fmt "const %a@ " pp_const_decl c
+ | Include s ->
+ fprintf fmt "include \"%s\"" s
+ | Open (local, s) ->
+ if local then fprintf fmt "#open \"%s\"@ " s
+ else fprintf fmt "#open <%s>@ " s
+ | TypeDef tdef ->
+ fprintf fmt "type %s;@ " tdef.tydef_id
let pp_prog_short = pp_prog pp_short_decl
+
let pp_prog = pp_prog pp_decl
-
-let pp_lusi fmt decl =
+
+let pp_lusi fmt decl =
match decl.top_decl_desc with
- | ImportedNode ind -> fprintf fmt "%a;@ " pp_imported_node ind
- | Const c -> fprintf fmt "const %a@ " pp_const_decl c
- | Include s -> fprintf fmt "include \"%s\"" s
- | Open (local, s) -> if local then fprintf fmt "#open \"%s\"@ " s else fprintf fmt "#open <%s>@ " s
- | TypeDef tdef -> fprintf fmt "%a@ " pp_typedef tdef
- | Node _ -> assert false
-
+ | ImportedNode ind ->
+ fprintf fmt "%a;@ " pp_imported_node ind
+ | Const c ->
+ fprintf fmt "const %a@ " pp_const_decl c
+ | Include s ->
+ fprintf fmt "include \"%s\"" s
+ | Open (local, s) ->
+ if local then fprintf fmt "#open \"%s\"@ " s
+ else fprintf fmt "#open <%s>@ " s
+ | TypeDef tdef ->
+ fprintf fmt "%a@ " pp_typedef tdef
+ | Node _ ->
+ assert false
+
let pp_lusi_header fmt basename prog =
fprintf fmt "@[<v 0>";
fprintf fmt "(* Generated Lustre Interface file from %s.lus *)@ " basename;
- fprintf fmt "(* by Lustre-C compiler version %s, %a *)@ " Version.number pp_date (Unix.gmtime (Unix.time ()));
- fprintf fmt "(* Feel free to mask some of the definitions by removing them from this file. *)@ @ ";
+ fprintf fmt "(* by Lustre-C compiler version %s, %a *)@ " Version.number
+ pp_date
+ (Unix.gmtime (Unix.time ()));
+ fprintf fmt
+ "(* Feel free to mask some of the definitions by removing them from this \
+ file. *)@ @ ";
List.iter (fprintf fmt "%a@ " pp_lusi) prog;
fprintf fmt "@]@."
let pp_offset fmt offset =
match offset with
- | Index i -> fprintf fmt "[%a]" Dimension.pp_dimension i
- | Field f -> fprintf fmt ".%s" f
+ | Index i ->
+ fprintf fmt "[%a]" Dimension.pp_dimension i
+ | Field f ->
+ fprintf fmt ".%s" f
let pp_node_list fmt prog =
Format.fprintf fmt "@[<h 2>%a@]"
- (fprintf_list
- ~sep:"@ "
- (fun fmt decl ->
+ (fprintf_list ~sep:"@ " (fun fmt decl ->
match decl.top_decl_desc with
- | Node nd -> Format.fprintf fmt "%s" nd.node_id
- | _ -> ()
- ))
+ | Node nd ->
+ Format.fprintf fmt "%s" nd.node_id
+ | _ ->
+ ()))
prog
-
+
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/real.ml b/src/real.ml
index 218018b8a039064b56f5f81369e5da9ec73a9a5d..28805c735d0cde64b652ae98c36ef1cf22949625 100644
--- a/src/real.ml
+++ b/src/real.ml
@@ -1,65 +1,64 @@
(* (a, b, c) means a * 10^-b. c is the original string *)
-type t = Q.t * int * string
+type t = Q.t * int * string
let pp fmt (_, _, s) =
- Format.fprintf fmt "%s%s"
- s
- (if String.get s (-1 + String.length s) = '.' then "0" else "")
+ Format.fprintf fmt "%s%s" s
+ (if String.get s (-1 + String.length s) = '.' then "0" else "")
+
+let pp_ada fmt (c, e, _) = Format.fprintf fmt "%s.0*1.0e-%i" (Q.to_string c) e
-let pp_ada fmt (c, e, _) =
- Format.fprintf fmt "%s.0*1.0e-%i" (Q.to_string c) e
-
let create m e s = Q.of_string m, e, s
let create_q q s = q, 0, s
-
-(*
-let to_num (c, e, s) =
- let num_10 = Num.num_of_int 10 in
- Num.(c // (num_10 **/ (num_of_int e)))
- *)
-
+
+(* let to_num (c, e, s) = let num_10 = Num.num_of_int 10 in Num.(c // (num_10
+ **/ (num_of_int e))) *)
+
let rec to_q (c, e, s) =
- if e = 0 then
- c
- else
- if e > 0 then Q.div (to_q (c,e-1,s)) (Q.of_int 10)
- else (* if exp<0 then *)
- Q.mul
- (to_q (c,e+1,s))
- (Q.of_int 10)
+ if e = 0 then c
+ else if e > 0 then Q.div (to_q (c, e - 1, s)) (Q.of_int 10)
+ else (* if exp<0 then *)
+ Q.mul (to_q (c, e + 1, s)) (Q.of_int 10)
let to_num = to_q
-
+
let to_string (_, _, s) = s
-
+
(* let eq r1 r2 =
* Q.equal (to_q r1) (to_q r2) *)
-
-
+
let num_binop op r1 r2 =
let n1 = to_num r1 and n2 = to_num r2 in
op n1 n2
-
+
let arith_binop op r1 r2 =
let r = num_binop op r1 r2 in
create_q r (Q.to_string r)
-
-let add = arith_binop Q.add
+
+let add = arith_binop Q.add
+
let minus = arith_binop Q.sub
+
let times = arith_binop Q.mul
-let div = arith_binop Q.div
+
+let div = arith_binop Q.div
let uminus (c, e, s) = Q.neg c, e, "-" ^ s
-let lt = num_binop (Q.(<))
-let le = num_binop (Q.(<=))
-let gt = num_binop (Q.(>))
-let ge = num_binop (Q.(>=))
-let diseq = num_binop (Q.(<>))
-let eq = num_binop (Q.(=))
+let lt = num_binop Q.( < )
+
+let le = num_binop Q.( <= )
+
+let gt = num_binop Q.( > )
+
+let ge = num_binop Q.( >= )
+
+let diseq = num_binop Q.( <> )
+
+let eq = num_binop Q.( = )
let zero = Q.zero, 0, "0.0"
let is_zero r = Q.equal (to_num r) Q.zero
+
let is_one r = Q.equal (to_num r) Q.one
diff --git a/src/real.mli b/src/real.mli
index 5fe806b03dba5823825cf6efeb61dd42b40a4d8a..62a88c8ea23f540500ef5bba96c0a5bef184b53d 100644
--- a/src/real.mli
+++ b/src/real.mli
@@ -1,28 +1,44 @@
type t
-val pp: Format.formatter -> t -> unit
-val pp_ada: Format.formatter -> t -> unit
-val create: string -> int -> string -> t
+
+val pp : Format.formatter -> t -> unit
+
+val pp_ada : Format.formatter -> t -> unit
+
+val create : string -> int -> string -> t
+
(*val create_num: Num.num -> string -> t*)
-val create_q: Q.t -> string -> t
-
-val add: t -> t -> t
-val minus: t -> t -> t
-val times: t -> t -> t
-val div: t -> t -> t
-val uminus: t -> t
-
-val lt: t -> t -> bool
-val le: t -> t -> bool
-val gt: t -> t -> bool
-val ge: t -> t -> bool
-val eq: t -> t -> bool
-val diseq: t -> t -> bool
-
+val create_q : Q.t -> string -> t
+
+val add : t -> t -> t
+
+val minus : t -> t -> t
+
+val times : t -> t -> t
+
+val div : t -> t -> t
+
+val uminus : t -> t
+
+val lt : t -> t -> bool
+
+val le : t -> t -> bool
+
+val gt : t -> t -> bool
+
+val ge : t -> t -> bool
+
+val eq : t -> t -> bool
+
+val diseq : t -> t -> bool
+
(*val to_num: t -> Num.num*)
-val to_q: t -> Q.t
-val to_string: t -> string
+val to_q : t -> Q.t
+
+val to_string : t -> string
+
(* val eq: t -> t -> bool *)
-val zero: t
+val zero : t
+
+val is_zero : t -> bool
-val is_zero: t -> bool
-val is_one: t -> bool
+val is_one : t -> bool
diff --git a/src/scheduling.ml b/src/scheduling.ml
index 71551780697f8cc8e2671b16605fec4c4e7aad2f..ef862735d363988e32aa12e927d8d2538354b194 100644
--- a/src/scheduling.ml
+++ b/src/scheduling.ml
@@ -15,76 +15,59 @@ open Corelang
open Causality
open Scheduling_type
-(* Topological sort with a priority for variables belonging in the same equation lhs.
- For variables still unrelated, standard compare is used to choose the minimal element.
- This priority is used since it helps a lot in factorizing generated code.
- Moreover, the dependency graph is browsed in a depth-first manner whenever possible,
- to improve the behavior of optimization algorithms applied in forthcoming compilation steps.
- In the following functions:
- - [eq_equiv] is the equivalence relation between vars of the same equation lhs
- - [g] the (imperative) graph to be topologically sorted
- - [pending] is the set of unsorted root variables so far, equivalent to the last sorted var
- - [frontier] is the set of unsorted root variables so far, not belonging in [pending]
- - [sort] is the resulting topological order
-*)
+(* Topological sort with a priority for variables belonging in the same equation
+ lhs. For variables still unrelated, standard compare is used to choose the
+ minimal element. This priority is used since it helps a lot in factorizing
+ generated code. Moreover, the dependency graph is browsed in a depth-first
+ manner whenever possible, to improve the behavior of optimization algorithms
+ applied in forthcoming compilation steps. In the following functions: -
+ [eq_equiv] is the equivalence relation between vars of the same equation lhs
+ - [g] the (imperative) graph to be topologically sorted - [pending] is the
+ set of unsorted root variables so far, equivalent to the last sorted var -
+ [frontier] is the set of unsorted root variables so far, not belonging in
+ [pending] - [sort] is the resulting topological order *)
-(* Checks whether the currently scheduled variable [choice]
- is an output of a call, possibly among others *)
+(* Checks whether the currently scheduled variable [choice] is an output of a
+ call, possibly among others *)
let is_call_output choice g =
- List.exists ExprDep.is_instance_var (IdentDepGraph.succ g choice)
+ List.exists ExprDep.is_instance_var (IdentDepGraph.succ g choice)
-(* Adds successors of [v] in graph [g] in [pending] or [frontier] sets, wrt [eq_equiv],
- then removes [v] from [g]
-*)
+(* Adds successors of [v] in graph [g] in [pending] or [frontier] sets, wrt
+ [eq_equiv], then removes [v] from [g] *)
let add_successors eq_equiv g v pending frontier =
let succs_v = IdentDepGraph.succ g v in
- begin
- IdentDepGraph.remove_vertex g v;
- List.iter
- (fun v' ->
- if is_graph_root v' g then
- (if eq_equiv v v' then
- pending := ISet.add v' !pending
- else
- frontier := ISet.add v' !frontier)
- ) succs_v;
- end
+ IdentDepGraph.remove_vertex g v;
+ List.iter
+ (fun v' ->
+ if is_graph_root v' g then
+ if eq_equiv v v' then pending := ISet.add v' !pending
+ else frontier := ISet.add v' !frontier)
+ succs_v
-(* Chooses the next var to be sorted, taking priority into account.
- Modifies [pending] and [frontier] accordingly.
-*)
+(* Chooses the next var to be sorted, taking priority into account. Modifies
+ [pending] and [frontier] accordingly. *)
let next_element eq_equiv g sort call pending frontier =
- begin
- if ISet.is_empty !pending
- then
- begin
- let choice = ISet.min_elt !frontier in
- (*Format.eprintf "-1-> %s@." choice;*)
- frontier := ISet.remove choice !frontier;
- let (p, f) = ISet.partition (eq_equiv choice) !frontier in
- pending := p;
- frontier := f;
- call := is_call_output choice g;
- add_successors eq_equiv g choice pending frontier;
- if not (ExprDep.is_ghost_var choice)
- then sort := [choice] :: !sort
- end
- else
- begin
- let choice = ISet.min_elt !pending in
- (*Format.eprintf "-2-> %s@." choice;*)
- pending := ISet.remove choice !pending;
- add_successors eq_equiv g choice pending frontier;
- if not (ExprDep.is_ghost_var choice)
- then sort := (if !call
- then (choice :: List.hd !sort) :: List.tl !sort
- else [choice] :: !sort)
- end
- end
+ if ISet.is_empty !pending then (
+ let choice = ISet.min_elt !frontier in
+ (*Format.eprintf "-1-> %s@." choice;*)
+ frontier := ISet.remove choice !frontier;
+ let p, f = ISet.partition (eq_equiv choice) !frontier in
+ pending := p;
+ frontier := f;
+ call := is_call_output choice g;
+ add_successors eq_equiv g choice pending frontier;
+ if not (ExprDep.is_ghost_var choice) then sort := [ choice ] :: !sort)
+ else
+ let choice = ISet.min_elt !pending in
+ (*Format.eprintf "-2-> %s@." choice;*)
+ pending := ISet.remove choice !pending;
+ add_successors eq_equiv g choice pending frontier;
+ if not (ExprDep.is_ghost_var choice) then
+ sort :=
+ if !call then (choice :: List.hd !sort) :: List.tl !sort
+ else [ choice ] :: !sort
-
-(* Topological sort of dependency graph [g], with priority.
- *)
+(* Topological sort of dependency graph [g], with priority. *)
let topological_sort eq_equiv g =
let roots = graph_roots g in
assert (roots <> []);
@@ -92,45 +75,43 @@ let topological_sort eq_equiv g =
let frontier = ref (List.fold_right ISet.add roots ISet.empty) in
let pending = ref ISet.empty in
let sorted = ref [] in
- begin
- while not (ISet.is_empty !frontier && ISet.is_empty !pending)
- do
- (*Format.eprintf "frontier = {%a}, pending = {%a}@."
- (fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !frontier
- (fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !pending;*)
- next_element eq_equiv g sorted call pending frontier;
- done;
- IdentDepGraph.clear g;
- !sorted
- end
+ while not (ISet.is_empty !frontier && ISet.is_empty !pending) do
+ (*Format.eprintf "frontier = {%a}, pending = {%a}@." (fun fmt -> ISet.iter
+ (fun e -> Format.pp_print_string fmt e)) !frontier (fun fmt -> ISet.iter
+ (fun e -> Format.pp_print_string fmt e)) !pending;*)
+ next_element eq_equiv g sorted call pending frontier
+ done;
+ IdentDepGraph.clear g;
+ !sorted
-(* Filters out normalization variables and renames instance variables to keep things readable,
- in a case of a dependency error *)
+(* Filters out normalization variables and renames instance variables to keep
+ things readable, in a case of a dependency error *)
let filter_original n vl =
- List.fold_right (fun v res ->
- if ExprDep.is_instance_var v then Format.sprintf "node %s" (ExprDep.undo_instance_var v) :: res else
- let vdecl = get_node_var v n in
- if vdecl.var_orig then v :: res else res) vl []
+ List.fold_right
+ (fun v res ->
+ if ExprDep.is_instance_var v then
+ Format.sprintf "node %s" (ExprDep.undo_instance_var v) :: res
+ else
+ let vdecl = get_node_var v n in
+ if vdecl.var_orig then v :: res else res)
+ vl []
-let eq_equiv eq_equiv_hash =
- fun v1 v2 ->
- try
- Hashtbl.find eq_equiv_hash v1 = Hashtbl.find eq_equiv_hash v2
+let eq_equiv eq_equiv_hash v1 v2 =
+ try Hashtbl.find eq_equiv_hash v1 = Hashtbl.find eq_equiv_hash v2
with Not_found -> false
let schedule_node n =
(* let node_vars = get_node_vars n in *)
- Log.report ~level:5 (fun fmt -> Format.fprintf fmt "scheduling node %s@ " n.node_id);
+ Log.report ~level:5 (fun fmt ->
+ Format.fprintf fmt "scheduling node %s@ " n.node_id);
let eq_equiv = eq_equiv (ExprDep.node_eq_equiv n) in
let node, g = global_dependency n in
-
- (* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs
- compute: coi predecessors of outputs
- warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output)
- DONE !
- *)
+ (* TODO X: extend the graph with inputs (adapt the causality analysis to deal
+ with inputs compute: coi predecessors of outputs warning (no modification)
+ when memories are non used (do not impact output) or when inputs are not
+ used (do not impact output) DONE ! *)
let dep_graph = IdentDepGraph.copy g in
let schedule = topological_sort eq_equiv g in
let unused_vars = Liveness.compute_unused_variables n dep_graph in
@@ -143,84 +124,73 @@ let schedule_node n =
let compute_node_reuse_table report =
let disjoint = Disjunction.clock_disjoint_map (get_node_vars report.node) in
- let reuse = Liveness.compute_reuse_policy report.node report.schedule disjoint report.dep_graph in
-(*
- if !Options.print_reuse
- then
- begin
- Log.report ~level:0
- (fun fmt ->
- Format.fprintf fmt
- "OPT:%B@." (try (Hashtbl.iter (fun s1 v2 -> if s1 = v2.var_id then raise Not_found) reuse; false) with Not_found -> true)
- );
- Log.report ~level:0
- (fun fmt ->
- Format.fprintf fmt
- "OPT:clock disjoint map for node %s: %a"
- n'.node_id
- Disjunction.pp_disjoint_map disjoint
- );
- Log.report ~level:0
- (fun fmt ->
- Format.fprintf fmt
- "OPT:reuse policy for node %s: %a"
- n'.node_id
- Liveness.pp_reuse_policy reuse
- );
- end;
-*)
- reuse
-
+ let reuse =
+ Liveness.compute_reuse_policy report.node report.schedule disjoint
+ report.dep_graph
+ in
+ (* if !Options.print_reuse then begin Log.report ~level:0 (fun fmt ->
+ Format.fprintf fmt "OPT:%B@." (try (Hashtbl.iter (fun s1 v2 -> if s1 =
+ v2.var_id then raise Not_found) reuse; false) with Not_found -> true) );
+ Log.report ~level:0 (fun fmt -> Format.fprintf fmt "OPT:clock disjoint map
+ for node %s: %a" n'.node_id Disjunction.pp_disjoint_map disjoint );
+ Log.report ~level:0 (fun fmt -> Format.fprintf fmt "OPT:reuse policy for
+ node %s: %a" n'.node_id Liveness.pp_reuse_policy reuse ); end; *)
+ reuse
let schedule_prog prog =
- List.fold_right (
- fun top_decl (accu_prog, sch_map) ->
+ List.fold_right
+ (fun top_decl (accu_prog, sch_map) ->
match top_decl.top_decl_desc with
| Node nd ->
let report = schedule_node nd in
- {top_decl with top_decl_desc = Node report.node}::accu_prog,
- IMap.add nd.node_id report sch_map
- | _ -> top_decl::accu_prog, sch_map
- )
- prog
- ([],IMap.empty)
+ ( { top_decl with top_decl_desc = Node report.node } :: accu_prog,
+ IMap.add nd.node_id report sch_map )
+ | _ ->
+ top_decl :: accu_prog, sch_map)
+ prog ([], IMap.empty)
+let compute_prog_reuse_table report = IMap.map compute_node_reuse_table report
-let compute_prog_reuse_table report =
- IMap.map compute_node_reuse_table report
-
-(* removes inlined local variables from schedule report,
- which are now useless *)
+(* removes inlined local variables from schedule report, which are now useless *)
let remove_node_inlined_locals locals report =
let is_inlined v = IMap.exists (fun l _ -> v = l) locals in
let schedule' =
- List.fold_right (fun heads q -> let heads' = List.filter (fun v -> not (is_inlined v)) heads
- in if heads' = [] then q else heads'::q)
- report.schedule [] in
- begin
- IMap.iter (fun v _ -> Hashtbl.remove report.fanin_table v) locals;
- IMap.iter (fun v _ -> let iv = ExprDep.mk_instance_var v
- in Liveness.replace_in_dep_graph v iv report.dep_graph) locals;
- { report with schedule = schedule' }
- end
+ List.fold_right
+ (fun heads q ->
+ let heads' = List.filter (fun v -> not (is_inlined v)) heads in
+ if heads' = [] then q else heads' :: q)
+ report.schedule []
+ in
+ IMap.iter (fun v _ -> Hashtbl.remove report.fanin_table v) locals;
+ IMap.iter
+ (fun v _ ->
+ let iv = ExprDep.mk_instance_var v in
+ Liveness.replace_in_dep_graph v iv report.dep_graph)
+ locals;
+ { report with schedule = schedule' }
let remove_prog_inlined_locals removed reuse =
IMap.mapi (fun id -> remove_node_inlined_locals (IMap.find id removed)) reuse
let pp_eq_schedule fmt vl =
match vl with
- | [] -> assert false
- | [v] -> Format.fprintf fmt "%s" v
- | _ -> Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) vl
-
+ | [] ->
+ assert false
+ | [ v ] ->
+ Format.fprintf fmt "%s" v
+ | _ ->
+ Format.fprintf fmt "(%a)"
+ (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v))
+ vl
+
let pp_schedule fmt node_schs =
- IMap.iter
- (fun nd report ->
- Format.(fprintf fmt "%s schedule: %a@ "
- nd
- (pp_print_list ~pp_sep:pp_print_semicolon pp_eq_schedule)
- report.schedule))
- node_schs
+ IMap.iter
+ (fun nd report ->
+ Format.(
+ fprintf fmt "%s schedule: %a@ " nd
+ (pp_print_list ~pp_sep:pp_print_semicolon pp_eq_schedule)
+ report.schedule))
+ node_schs
let pp_fanin_table fmt node_schs =
IMap.iter
@@ -231,74 +201,77 @@ let pp_fanin_table fmt node_schs =
let pp_dep_graph fmt node_schs =
IMap.iter
(fun nd report ->
- Format.fprintf fmt "%s dependency graph: %a@ " nd pp_dep_graph report.dep_graph)
+ Format.fprintf fmt "%s dependency graph: %a@ " nd pp_dep_graph
+ report.dep_graph)
node_schs
let pp_warning_unused fmt node_schs =
IMap.iter
(fun nd report ->
- let unused = report.unused_vars in
- if not (ISet.is_empty unused)
- then
- let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd -> nd | _ -> assert false in
- ISet.iter
- (fun u ->
- let vu = get_node_var u nd in
- if vu.var_orig
- then Format.fprintf fmt " Warning: variable '%s' seems unused@, %a@,@," u Location.pp_loc vu.var_loc)
- unused
- )
+ let unused = report.unused_vars in
+ if not (ISet.is_empty unused) then
+ let nd =
+ match (Corelang.node_from_name nd).top_decl_desc with
+ | Node nd ->
+ nd
+ | _ ->
+ assert false
+ in
+ ISet.iter
+ (fun u ->
+ let vu = get_node_var u nd in
+ if vu.var_orig then
+ Format.fprintf fmt
+ " Warning: variable '%s' seems unused@, %a@,@," u
+ Location.pp_loc vu.var_loc)
+ unused)
node_schs
-
(* Sort eqs according to schedule *)
-(* Sort the set of equations of node [nd] according
- to the computed schedule [sch]
-*)
+(* Sort the set of equations of node [nd] according to the computed schedule
+ [sch] *)
let sort_equations_from_schedule eqs sch =
Log.report ~level:10 (fun fmt ->
Format.fprintf fmt "schedule: %a@ "
- (Format.pp_print_list
- ~pp_sep:Format.pp_print_semicolon pp_eq_schedule) sch);
+ (Format.pp_print_list ~pp_sep:Format.pp_print_semicolon pp_eq_schedule)
+ sch);
let split_eqs = Splitting.tuple_split_eq_list eqs in
(* Flatten schedule *)
- let sch = List.fold_right (fun vl res -> (List.map (fun v -> [v]) vl)@res) sch [] in
+ let sch =
+ List.fold_right (fun vl res -> List.map (fun v -> [ v ]) vl @ res) sch []
+ in
let eqs_rev, remainder =
List.fold_left
(fun (accu, node_eqs_remainder) vl ->
(* For each variable in vl, there should exists the equations in accu *)
- if List.for_all (fun v -> List.exists (fun eq -> List.mem v eq.eq_lhs) accu) vl
- then
- (accu, node_eqs_remainder)
- else
- let eq_v, remainder = find_eq vl node_eqs_remainder in
- eq_v::accu, remainder
- )
- ([], split_eqs)
- sch
+ if
+ List.for_all
+ (fun v -> List.exists (fun eq -> List.mem v eq.eq_lhs) accu)
+ vl
+ then accu, node_eqs_remainder
+ else
+ let eq_v, remainder = find_eq vl node_eqs_remainder in
+ eq_v :: accu, remainder)
+ ([], split_eqs) sch
in
- begin
- let eqs = List.rev eqs_rev in
- let unused =
- if List.length remainder > 0 then (
- Log.report ~level:3 (fun fmt -> Format.fprintf fmt
- "[Warning] Equations not used are@ %a@ Full equation set is:@ %a@ "
- Printers.pp_node_eqs remainder
- Printers.pp_node_eqs eqs
- );
- let vars = List.fold_left (fun accu eq -> eq.eq_lhs @ accu) [] remainder in
- Log.report ~level:1 (fun fmt -> Format.fprintf fmt
- "[Warning] Unused variables: %a@ "
- (fprintf_list ~sep:", " Format.pp_print_string)
- vars
- );
- vars
- )
- else
- []
- in
- eqs, unused
- end
+ let eqs = List.rev eqs_rev in
+ let unused =
+ if List.length remainder > 0 then (
+ Log.report ~level:3 (fun fmt ->
+ Format.fprintf fmt
+ "[Warning] Equations not used are@ %a@ Full equation set is:@ %a@ "
+ Printers.pp_node_eqs remainder Printers.pp_node_eqs eqs);
+ let vars =
+ List.fold_left (fun accu eq -> eq.eq_lhs @ accu) [] remainder
+ in
+ Log.report ~level:1 (fun fmt ->
+ Format.fprintf fmt "[Warning] Unused variables: %a@ "
+ (fprintf_list ~sep:", " Format.pp_print_string)
+ vars);
+ vars)
+ else []
+ in
+ eqs, unused
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/scheduling_type.ml b/src/scheduling_type.ml
index 5e73925e90555ade825c3372710d494582ad7221..a0a8ca041f44c22d5c8bda019da0b983c916cc3b 100644
--- a/src/scheduling_type.ml
+++ b/src/scheduling_type.ml
@@ -1,8 +1,7 @@
open Utils
open Lustre_types
-type schedule_report =
-{
+type schedule_report = {
(* the scheduled node *)
node : node_desc;
(* a schedule computed wrt the dependency graph *)
@@ -12,8 +11,7 @@ type schedule_report =
(* the table mapping each local var to its in-degree *)
fanin_table : (ident, int) Hashtbl.t;
(* the dependency graph *)
- dep_graph : IdentDepGraph.t;
- (* the table mapping each assignment to a reusable variable *)
- (*reuse_table : (ident, var_decl) Hashtbl.t*)
+ dep_graph : IdentDepGraph.t;
+ (* the table mapping each assignment to a reusable variable *)
+ (*reuse_table : (ident, var_decl) Hashtbl.t*)
}
-
diff --git a/src/sortProg.ml b/src/sortProg.ml
index 56b5f1d2584aaafc8cf467d2892427ad7d5d2803..f46e793ae442439b267761c4cc9b71b412742ad3 100644
--- a/src/sortProg.ml
+++ b/src/sortProg.ml
@@ -11,58 +11,62 @@
open Lustre_types
open Utils
-
+
let get_node nid prog =
- List.find (fun t -> match t.top_decl_desc with Node n -> n.node_id = nid | _ -> false) prog
+ List.find
+ (fun t ->
+ match t.top_decl_desc with Node n -> n.node_id = nid | _ -> false)
+ prog
-let check_external_defs x not_nodes = true (* TODO, check whether a node, a function or an include defines this node *)
+let check_external_defs x not_nodes = true
+(* TODO, check whether a node, a function or an include defines this node *)
let sort prog =
- let not_nodes, nodes =
- List.partition (fun top -> match top.top_decl_desc with Node _ -> false | _ -> true) prog
+ let not_nodes, nodes =
+ List.partition
+ (fun top -> match top.top_decl_desc with Node _ -> false | _ -> true)
+ prog
in
- let sorted =
+ let sorted =
try
let g = Causality.NodeDep.dependence_graph nodes in
Causality.CycleDetection.check_cycles g;
-
- (
- TopologicalDepGraph.fold
- (fun x accu ->
- try
- (get_node x nodes)::accu
- with Not_found ->
- (* check whether it is an imported node, a function or in the includes *)
- if check_external_defs x not_nodes then
- accu
- else
- (Format.eprintf "Impossible to find node %s@.@?" x; failwith x)
- )
- g []
- )
- with (Causality.Error err) as exc ->
- Causality.pp_error Format.err_formatter err;
- raise exc
+
+ TopologicalDepGraph.fold
+ (fun x accu ->
+ try get_node x nodes :: accu
+ with Not_found ->
+ (* check whether it is an imported node, a function or in the
+ includes *)
+ if check_external_defs x not_nodes then accu
+ else (
+ Format.eprintf "Impossible to find node %s@.@?" x;
+ failwith x))
+ g []
+ with Causality.Error err as exc ->
+ Causality.pp_error Format.err_formatter err;
+ raise exc
in
-
- Log.report ~level:3
- (fun fmt -> Format.fprintf fmt "@ @[<v 2>.. ordered list of declarations:@ %a@]@ "
- (Utils.fprintf_list ~sep:"@ " Printers.pp_short_decl) sorted);
- not_nodes@sorted
+ Log.report ~level:3 (fun fmt ->
+ Format.fprintf fmt "@ @[<v 2>.. ordered list of declarations:@ %a@]@ "
+ (Utils.fprintf_list ~sep:"@ " Printers.pp_short_decl)
+ sorted);
+ not_nodes @ sorted
let sort_node_locals nd =
- { nd with node_locals = Causality.VarClockDep.sort nd.node_locals}
-
+ { nd with node_locals = Causality.VarClockDep.sort nd.node_locals }
+
let sort_nodes_locals prog =
List.map
(fun top ->
match top.top_decl_desc with
- | Node nd -> {top with top_decl_desc = Node (sort_node_locals nd)}
- | _ -> top
- )
+ | Node nd ->
+ { top with top_decl_desc = Node (sort_node_locals nd) }
+ | _ ->
+ top)
prog
-
+
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/spec.ml b/src/spec.ml
index 7df6af1e75af806af55ab004ae0ccb618e533ed4..29bc6a0b18ca6eeeb7bbffa4b983603aeca4b813 100644
--- a/src/spec.ml
+++ b/src/spec.ml
@@ -1,18 +1,18 @@
open Lustre_types
-(* TODO:
- - verifier que les spec sont quantifiers free ou sinon mettre un warning
- - rajouter les expressions requires => ensures dans le node
- - sauver le nom des variables locales qui encodent ces specs.
-*)
+(* TODO: - verifier que les spec sont quantifiers free ou sinon mettre un
+ warning - rajouter les expressions requires => ensures dans le node - sauver
+ le nom des variables locales qui encodent ces specs. *)
-let enforce_spec_node nd =
-(* TODO: add asserts for quantifier free normalized eexpr *)
+let enforce_spec_node nd =
+ (* TODO: add asserts for quantifier free normalized eexpr *)
nd
-
-let enforce_spec_prog prog =
- List.map (
- fun top -> match top.top_decl_desc with
- | Node nd -> {top with top_decl_desc = Node (enforce_spec_node nd) }
- | _ -> top
- ) prog
+let enforce_spec_prog prog =
+ List.map
+ (fun top ->
+ match top.top_decl_desc with
+ | Node nd ->
+ { top with top_decl_desc = Node (enforce_spec_node nd) }
+ | _ ->
+ top)
+ prog
diff --git a/src/spec_common.ml b/src/spec_common.ml
index 407cc5e0ac3e1c7671f1487e6cf07882b9162c1f..399cb31b71dfe88004b5a8803ba32c555dc97b25 100644
--- a/src/spec_common.ml
+++ b/src/spec_common.ml
@@ -1,74 +1,76 @@
open Spec_types
(* a small reduction engine *)
-let is_true = function
- | True -> true
- | _ -> false
+let is_true = function True -> true | _ -> false
-let is_false = function
- | False -> true
- | _ -> false
+let is_false = function False -> true | _ -> false
-let expr_eq: type a b. (a, left_v) expression_t -> (a, b) expression_t -> bool =
- fun a b ->
+let expr_eq : type a b. (a, left_v) expression_t -> (a, b) expression_t -> bool
+ =
+ fun a b ->
match a, b with
- | Var x, Var y -> x = y
- | Memory r1, Memory r2 -> r1 = r2
- | _ -> false
-
-let rec red: type a. a formula_t -> a formula_t = function
+ | Var x, Var y ->
+ x = y
+ | Memory r1, Memory r2 ->
+ r1 = r2
+ | _ ->
+ false
+
+let rec red : type a. a formula_t -> a formula_t = function
| Equal (a, b) when expr_eq a b ->
True
-
- | And l ->
- let l' = List.filter_map (fun a ->
- let a' = red a in
- if is_true a' then None else Some a') l in
- begin match l' with
- | [] -> True
- | [a] -> a
- | l' when List.exists is_false l' -> False
- | _ -> And l'
- end
-
- | Or l ->
- let l' = List.filter_map (fun a ->
- let a' = red a in
- if is_false a' then None else Some a') l in
- begin match l' with
- | [] -> assert false
- | [a] -> a
- | l' when List.exists is_true l' -> True
- | _ -> Or l'
- end
-
+ | And l -> (
+ let l' =
+ List.filter_map
+ (fun a ->
+ let a' = red a in
+ if is_true a' then None else Some a')
+ l
+ in
+ match l' with
+ | [] ->
+ True
+ | [ a ] ->
+ a
+ | l' when List.exists is_false l' ->
+ False
+ | _ ->
+ And l')
+ | Or l -> (
+ let l' =
+ List.filter_map
+ (fun a ->
+ let a' = red a in
+ if is_false a' then None else Some a')
+ l
+ in
+ match l' with
+ | [] ->
+ assert false
+ | [ a ] ->
+ a
+ | l' when List.exists is_true l' ->
+ True
+ | _ ->
+ Or l')
| Imply (a, b) ->
let a' = red a in
let b' = red b in
if a' = b' || is_false a' || is_true b' then True
else if is_true a' && is_false b' then False
else Imply (a', b')
-
- | Exists (x, p) ->
+ | Exists (x, p) -> (
let p' = red p in
- if is_true p' then True else begin match x with
- | [] -> p'
- | x -> Exists (x, p')
- end
-
- | Forall (x, p) ->
+ if is_true p' then True else match x with [] -> p' | x -> Exists (x, p'))
+ | Forall (x, p) -> (
let p' = red p in
- if is_true p' then True else begin match x with
- | [] -> p'
- | x -> Forall (x, p')
- end
-
+ if is_true p' then True else match x with [] -> p' | x -> Forall (x, p'))
| Ternary (x, a, b) ->
let a' = red a in
let b' = red b in
Ternary (x, a', b')
-
- | f -> f
+ | f ->
+ f
(* smart constructors *)
(* let mk_condition x l =
@@ -78,38 +80,40 @@ let rec red: type a. a formula_t -> a formula_t = function
let vals vs = List.map (fun v -> Val v) vs
-let mk_pred_call pred =
- Predicate pred
+let mk_pred_call pred = Predicate pred
(* let mk_clocked_on id =
* mk_pred_call (Clocked_on id) *)
-let mk_transition ?(mems=Utils.ISet.empty) ?r ?i ?inst id inputs locals outputs =
+let mk_transition ?(mems = Utils.ISet.empty) ?r ?i ?inst id inputs locals
+ outputs =
let tr =
mk_pred_call
- (Transition (id, inst, i, vals inputs, vals locals, vals outputs,
- (match r with Some _ -> true | None -> false), mems)) in
- (match r, inst with
- | Some r, Some inst ->
- ExistsMem (id, mk_pred_call (Reset (id, inst, r)), tr)
- | _ ->
- tr)
-
-let mk_memory_pack ?i ?inst id =
- mk_pred_call (MemoryPack (id, inst, i))
-
-let mk_state_variable_pack x =
- StateVarPack (StateVar x)
-
-let mk_state_assign_tr x v =
- Equal (Memory (StateVar x), Val v)
-
-let mk_conditional_tr v t f =
- Ternary (Val v, t, f)
+ (Transition
+ ( id,
+ inst,
+ i,
+ vals inputs,
+ vals locals,
+ vals outputs,
+ (match r with Some _ -> true | None -> false),
+ mems ))
+ in
+ match r, inst with
+ | Some r, Some inst ->
+ ExistsMem (id, mk_pred_call (Reset (id, inst, r)), tr)
+ | _ ->
+ tr
+
+let mk_memory_pack ?i ?inst id = mk_pred_call (MemoryPack (id, inst, i))
+
+let mk_state_variable_pack x = StateVarPack (StateVar x)
+
+let mk_state_assign_tr x v = Equal (Memory (StateVar x), Val v)
+
+let mk_conditional_tr v t f = Ternary (Val v, t, f)
let mk_branch_tr x hl =
And (List.map (fun (t, spec) -> Imply (Equal (Var x, Tag t), spec)) hl)
-let mk_assign_tr x v =
- Equal (Var x, Val v)
-
+let mk_assign_tr x v = Equal (Var x, Val v)
diff --git a/src/spec_types.ml b/src/spec_types.ml
index 40da5168a7d8b5b83bb1126a583ffa95c47869a4..e8ed01ad6ce243b4c013a3d392dce4840621bf11 100644
--- a/src/spec_types.ml
+++ b/src/spec_types.ml
@@ -1,36 +1,44 @@
open Lustre_types
-type register_t =
- | ResetFlag
- | StateVar of var_decl
+type register_t = ResetFlag | StateVar of var_decl
type left_v
+
type right_v
type ('a, _) expression_t =
- | Val: 'a -> ('a, right_v) expression_t
- | Tag: ident -> ('a, right_v) expression_t
- | Var: var_decl -> ('a, left_v) expression_t
- | Memory: register_t -> ('a, left_v) expression_t
+ | Val : 'a -> ('a, right_v) expression_t
+ | Tag : ident -> ('a, right_v) expression_t
+ | Var : var_decl -> ('a, left_v) expression_t
+ | Memory : register_t -> ('a, left_v) expression_t
(** TODO: why moving this elsewhere makes the exhaustiveness check fail? *)
-let type_of_l_value: type a. (a, left_v) expression_t -> Types.type_expr =
+let type_of_l_value : type a. (a, left_v) expression_t -> Types.type_expr =
function
- | Var v -> v.var_type
- | Memory ResetFlag -> Type_predef.type_bool
- | Memory (StateVar v) -> v.var_type
+ | Var v ->
+ v.var_type
+ | Memory ResetFlag ->
+ Type_predef.type_bool
+ | Memory (StateVar v) ->
+ v.var_type
type ('a, 'b) expressions_t = ('a, 'b) expression_t list
type 'a predicate_t =
- | Transition: ident (* node name *)
- * ident option (* instance *)
- * int option (* transition index *)
- * ('a, 'b) expressions_t (* inputs *)
- * ('a, 'b) expressions_t (* locals *)
- * ('a, 'b) expressions_t (* outputs *)
- * bool (* reset *)
- * Utils.ISet.t (* memory footprint *)
+ | Transition :
+ ident (* node name *)
+ * ident option
+ (* instance *)
+ * int option
+ (* transition index *)
+ * ('a, 'b) expressions_t
+ (* inputs *)
+ * ('a, 'b) expressions_t
+ (* locals *)
+ * ('a, 'b) expressions_t
+ (* outputs *)
+ * bool (* reset *)
+ * Utils.ISet.t (* memory footprint *)
-> 'a predicate_t
| Reset of ident * ident * 'a
| MemoryPack of ident * ident option * int option
@@ -40,14 +48,16 @@ type 'a predicate_t =
type 'a formula_t =
| True
| False
- | Equal: ('a, left_v) expression_t * ('a, 'b) expression_t -> 'a formula_t
+ | Equal : ('a, left_v) expression_t * ('a, 'b) expression_t -> 'a formula_t
| And of 'a formula_t list
| Or of 'a formula_t list
| Imply of 'a formula_t * 'a formula_t
| Exists of var_decl list * 'a formula_t
| Forall of var_decl list * 'a formula_t
- | Ternary: ('a, 'b) expression_t * 'a formula_t * 'a formula_t -> 'a formula_t
- | Predicate: 'a predicate_t -> 'a formula_t
+ | Ternary :
+ ('a, 'b) expression_t * 'a formula_t * 'a formula_t
+ -> 'a formula_t
+ | Predicate : 'a predicate_t -> 'a formula_t
| StateVarPack of register_t
| ExistsMem of ident * 'a formula_t * 'a formula_t
@@ -58,18 +68,17 @@ type 'a formula_t =
* } *)
type 'a memory_pack_t = {
- mpname: node_desc;
- mpindex: int option;
- mpformula: 'a formula_t;
+ mpname : node_desc;
+ mpindex : int option;
+ mpformula : 'a formula_t;
}
type 'a transition_t = {
- tname: node_desc;
- tindex: int option;
- tinputs: var_decl list;
- tlocals: var_decl list;
- toutputs: var_decl list;
- tformula: 'a formula_t;
- tfootprint: Utils.ISet.t;
+ tname : node_desc;
+ tindex : int option;
+ tinputs : var_decl list;
+ tlocals : var_decl list;
+ toutputs : var_decl list;
+ tformula : 'a formula_t;
+ tfootprint : Utils.ISet.t;
}
-
diff --git a/src/splitting.ml b/src/splitting.ml
index 1a868c8ee35eb2c8333d692ea7c3875f546e358b..7b41af1f38aad319180c7276745a2372b0e0c432 100644
--- a/src/splitting.ml
+++ b/src/splitting.ml
@@ -13,76 +13,106 @@ open Utils
open Corelang
open Lustre_types
-
-let rec tuple_split_expr expr =
+let rec tuple_split_expr expr =
match expr.expr_desc with
- | Expr_const _
- | Expr_ident _ -> [expr]
- | Expr_tuple elist -> elist
+ | Expr_const _ | Expr_ident _ ->
+ [ expr ]
+ | Expr_tuple elist ->
+ elist
| Expr_appl (id, args, r) ->
- if Basic_library.is_homomorphic_fun id
- then
+ if Basic_library.is_homomorphic_fun id then
let args_list = List.map tuple_split_expr (expr_list_of_expr args) in
List.map
- (fun arg -> {expr with expr_tag = Utils.new_tag (); expr_desc = Expr_appl (id, expr_of_expr_list args.expr_loc arg, r) })
- (transpose_list args_list)
- else
- [expr]
+ (fun arg ->
+ {
+ expr with
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_appl (id, expr_of_expr_list args.expr_loc arg, r);
+ })
+ (transpose_list args_list)
+ else [ expr ]
| Expr_array el ->
let args_list = List.map tuple_split_expr el in
List.map
- (fun arg -> {expr with expr_tag = Utils.new_tag (); expr_desc = Expr_array arg })
+ (fun arg ->
+ { expr with expr_tag = Utils.new_tag (); expr_desc = Expr_array arg })
(transpose_list args_list)
| Expr_access (e1, d) ->
List.map
- (fun e1 -> { expr with expr_tag = Utils.new_tag (); expr_desc = Expr_access (e1, d) })
+ (fun e1 ->
+ {
+ expr with
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_access (e1, d);
+ })
(tuple_split_expr e1)
- | Expr_power (e1, d) ->
+ | Expr_power (e1, d) ->
List.map
- (fun e1 -> { expr with expr_tag = Utils.new_tag (); expr_desc = Expr_power (e1, d) })
+ (fun e1 ->
+ {
+ expr with
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_power (e1, d);
+ })
(tuple_split_expr e1)
- | Expr_arrow (e1,e2) ->
+ | Expr_arrow (e1, e2) ->
List.map2
- (fun e1 e2 -> { expr with expr_tag = Utils.new_tag (); expr_desc = Expr_arrow (e1, e2) })
- (tuple_split_expr e1)
- (tuple_split_expr e2)
+ (fun e1 e2 ->
+ {
+ expr with
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_arrow (e1, e2);
+ })
+ (tuple_split_expr e1) (tuple_split_expr e2)
| Expr_pre e ->
List.map
- (fun e -> { expr with expr_tag = Utils.new_tag (); expr_desc = Expr_pre e })
+ (fun e ->
+ { expr with expr_tag = Utils.new_tag (); expr_desc = Expr_pre e })
(tuple_split_expr e)
| Expr_fby (v, e) ->
List.map
- (fun e -> { expr with expr_tag = Utils.new_tag (); expr_desc = Expr_fby (v, e) })
+ (fun e ->
+ { expr with expr_tag = Utils.new_tag (); expr_desc = Expr_fby (v, e) })
(tuple_split_expr e)
| Expr_when (e, c, l) ->
List.map
- (fun e -> { expr with expr_tag = Utils.new_tag (); expr_desc = Expr_when (e, c, l) })
+ (fun e ->
+ {
+ expr with
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_when (e, c, l);
+ })
(tuple_split_expr e)
| Expr_ite (c, t, e) ->
List.map2
- (fun t e -> { expr with expr_tag = Utils.new_tag (); expr_desc = Expr_ite (c, t, e) })
- (tuple_split_expr t)
- (tuple_split_expr e)
- | Expr_merge (c,hl) ->
- let tl, hl = List.split (List.map (fun (t, h) -> (t, tuple_split_expr h)) hl) in
+ (fun t e ->
+ {
+ expr with
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_ite (c, t, e);
+ })
+ (tuple_split_expr t) (tuple_split_expr e)
+ | Expr_merge (c, hl) ->
+ let tl, hl =
+ List.split (List.map (fun (t, h) -> t, tuple_split_expr h) hl)
+ in
List.map
- (fun hl -> {expr with expr_tag = Utils.new_tag (); expr_desc = Expr_merge (c, List.combine tl hl) })
+ (fun hl ->
+ {
+ expr with
+ expr_tag = Utils.new_tag ();
+ expr_desc = Expr_merge (c, List.combine tl hl);
+ })
(transpose_list hl)
let tuple_split_eq eq =
let split_rhs = tuple_split_expr eq.eq_rhs in
- if List.length split_rhs = 1
- then
- [eq]
+ if List.length split_rhs = 1 then [ eq ]
else
- List.map2
- (fun lhs rhs -> mkeq eq.eq_loc ([lhs], rhs))
- eq.eq_lhs
- split_rhs
+ List.map2 (fun lhs rhs -> mkeq eq.eq_loc ([ lhs ], rhs)) eq.eq_lhs split_rhs
let tuple_split_eq_list eqs =
- List.fold_right (fun eq -> (@) (tuple_split_eq eq)) eqs []
-
+ List.fold_right (fun eq -> ( @ ) (tuple_split_eq eq)) eqs []
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/tools/importer/main_lustre_importer.ml b/src/tools/importer/main_lustre_importer.ml
index 2037ed5d15b78c6ef99de4160962ef00ebb091cf..d4181bc3d4c0d81f83acbfe8e22336b96875a810 100644
--- a/src/tools/importer/main_lustre_importer.ml
+++ b/src/tools/importer/main_lustre_importer.ml
@@ -1,68 +1,58 @@
(* An application that loads json provided input and produces Lustre
-Usage:
-lustrei -vhdl myvhdl.json
-lustrei -scade myscademodel.json
- will produce a lustre file that can be compiled and analyzed
+ Usage: lustrei -vhdl myvhdl.json lustrei -scade myscademodel.json will
+ produce a lustre file that can be compiled and analyzed
-VHDL is handled in a double way: as a backend and as an import language
-In a first step, lustrei -vhdl -print myvhdl.json shall print the VHDL model in stdout
-
- *)
-(*
-open Vhdl_ast
-open Vhdl_test
- *)
+ VHDL is handled in a double way: as a backend and as an import language In a
+ first step, lustrei -vhdl -print myvhdl.json shall print the VHDL model in
+ stdout *)
+(* open Vhdl_ast open Vhdl_test *)
open Yojson.Safe
open Vhdl_deriving_yojson
open Vhdl_json_lib
let () =
-(*
- (* Load model with Yojson *)
- let json = xx in
-
- (* Create VHDL values *)
- let vhdl : vhdl_design_t = xxxx json in
+ (* (* Load model with Yojson *) let json = xx in
- (* Printing result *)
- Format.printf "Loaded VHDL:@.%a@." pp_vhdl_design vhdl
- *)
+ (* Create VHDL values *) let vhdl : vhdl_design_t = xxxx json in
+ (* Printing result *) Format.printf "Loaded VHDL:@.%a@." pp_vhdl_design
+ vhdl *)
let vhdl_json = from_file Sys.argv.(1) in
Format.printf "Original file:\n%s\n\n" (pretty_to_string vhdl_json);
- (*let vhdl = design1 in
- Format.printf "Loaded VHDL:@.%a@." pp_vhdl_design vhdl;*)
-
- let vhdl1_json = vhdl_json |>
- prune_str "TOKEN" |>
- prune_str "IDENTIFIER" |>
- prune_str "SUBTYPE_INDICATION" |>
- prune_null_assoc |>
- to_list_content_str "DESIGN_UNIT" |>
- to_list_content_str "INTERFACE_VARIABLE_DECLARATION" |>
- flatten_ivd |>
- flatten_numeric_literal |>
- to_list_str "ENTITY_DECLARATION" |>
- to_list_str "ARCHITECTURE_BODY" |>
- to_list_str "PACKAGE_DECLARATION" in
+ (*let vhdl = design1 in Format.printf "Loaded VHDL:@.%a@." pp_vhdl_design
+ vhdl;*)
+ let vhdl1_json =
+ vhdl_json |> prune_str "TOKEN" |> prune_str "IDENTIFIER"
+ |> prune_str "SUBTYPE_INDICATION"
+ |> prune_null_assoc
+ |> to_list_content_str "DESIGN_UNIT"
+ |> to_list_content_str "INTERFACE_VARIABLE_DECLARATION"
+ |> flatten_ivd |> flatten_numeric_literal
+ |> to_list_str "ENTITY_DECLARATION"
+ |> to_list_str "ARCHITECTURE_BODY"
+ |> to_list_str "PACKAGE_DECLARATION"
+ in
Format.printf "Preprocessed json:\n";
Format.printf "%s\n\n" (pretty_to_string vhdl1_json);
-(* List.iter (Format.printf "%s\n") (print_depth vhdl1_json 7 ""); *)
-
- to_file (Sys.argv.(1)^".out.json") vhdl1_json;
-(*
- let typ = {name = "type"; definition = (Some (Range (Some "toto", 7, 0)))} in
- Format.printf "\nModel to string\n%s\n\n" (pretty_to_string (vhdl_subtype_indication_t_to_yojson typ));
+ (* List.iter (Format.printf "%s\n") (print_depth vhdl1_json 7 ""); *)
+ to_file (Sys.argv.(1) ^ ".out.json") vhdl1_json;
- let elem = "[\"SUBTYPE_DECLARATION\", {\"name\": \"byte\", \"typ\": { \"name\": \"bit_vector\", \"definition\": [ \"RANGE_WITH_DIRECTION\", \"downto\", 7, 0 ]}}]" in
- match vhdl_definition_t_of_yojson (from_string elem) with
- Ok x -> Format.printf "\nString to string\n%s\n\n" (pretty_to_string (vhdl_definition_t_to_yojson x));
- | Error e -> Format.printf "Error: %s\n" e;
-*)
+ (* let typ = {name = "type"; definition = (Some (Range (Some "toto", 7, 0)))}
+ in Format.printf "\nModel to string\n%s\n\n" (pretty_to_string
+ (vhdl_subtype_indication_t_to_yojson typ));
+ let elem = "[\"SUBTYPE_DECLARATION\", {\"name\": \"byte\", \"typ\": {
+ \"name\": \"bit_vector\", \"definition\": [ \"RANGE_WITH_DIRECTION\",
+ \"downto\", 7, 0 ]}}]" in match vhdl_definition_t_of_yojson (from_string
+ elem) with Ok x -> Format.printf "\nString to string\n%s\n\n"
+ (pretty_to_string (vhdl_definition_t_to_yojson x)); | Error e ->
+ Format.printf "Error: %s\n" e; *)
match vhdl_file_t_of_yojson vhdl1_json with
- Ok x -> Format.printf "Parsed VHDL: \n%s\n" (pretty_to_string (vhdl_file_t_to_yojson x))
- | Error e -> Format.printf "Error: %s\n" e;
+ | Ok x ->
+ Format.printf "Parsed VHDL: \n%s\n"
+ (pretty_to_string (vhdl_file_t_to_yojson x))
+ | Error e ->
+ Format.printf "Error: %s\n" e
diff --git a/src/tools/importer/vhdl_deriving_yojson.ml b/src/tools/importer/vhdl_deriving_yojson.ml
index 812365aa84a5401f20c4f90f06e80fc06bebfbab..56f919b789e439af894c048bb7133f367b5dcc1b 100644
--- a/src/tools/importer/vhdl_deriving_yojson.ml
+++ b/src/tools/importer/vhdl_deriving_yojson.ml
@@ -1,4 +1,14 @@
-let base_types = ["integer"; "character"; "bit"; "real"; "natural"; "positive"; "std_logic"; "std_logic_vector" ]
+let base_types =
+ [
+ "integer";
+ "character";
+ "bit";
+ "real";
+ "natural";
+ "positive";
+ "std_logic";
+ "std_logic_vector";
+ ]
type vhdl_type_t =
| Base of string
@@ -7,283 +17,322 @@ type vhdl_type_t =
| Array of int * int * vhdl_type_t
| Enumerated of string list
| Void
-[@@deriving yojson];;
-
-(************************************************************************************)
-(* Constants *)
-(************************************************************************************)
-
-(* Std_logic values :
- 'U': uninitialized. This signal hasn't been set yet.
- 'X': unknown. Impossible to determine this value/result.
- '0': logic 0
- '1': logic 1
- 'Z': High Impedance
- 'W': Weak signal, can't tell if it should be 0 or 1.
- 'L': Weak signal that should probably go to 0
- 'H': Weak signal that should probably go to 1
- '-': Don't care. *)
-let std_logic_cst = ["U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ]
-let literal_base = ["B"; "O"; "X"; "UB"; "UO"; "UX"; "SB"; "SO"; "SX"; "D"] (* Prefix of CstLiteral *)
+[@@deriving yojson]
+
+(************************************************************************************)
+(* Constants *)
+(************************************************************************************)
+
+(* Std_logic values : 'U': uninitialized. This signal hasn't been set yet. 'X':
+ unknown. Impossible to determine this value/result. '0': logic 0 '1': logic 1
+ 'Z': High Impedance 'W': Weak signal, can't tell if it should be 0 or 1. 'L':
+ Weak signal that should probably go to 0 'H': Weak signal that should
+ probably go to 1 '-': Don't care. *)
+let std_logic_cst = [ "U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ]
+
+let literal_base = [ "B"; "O"; "X"; "UB"; "UO"; "UX"; "SB"; "SO"; "SX"; "D" ]
+(* Prefix of CstLiteral *)
(* TODO: do we need more constructors ? *)
-type cst_val_t =
- CstInt of int
+type cst_val_t =
+ | CstInt of int
| CstStdLogic of string
| CstLiteral of string [@name "CST_LITERAL"]
-[@@deriving yojson {strict = false}];;
+[@@deriving yojson { strict = false }]
-type vhdl_subtype_indication_t =
- {
- name : string;
- definition: vhdl_type_t option [@default Some (Void)];
- }
-[@@deriving yojson {strict = false}];;
+type vhdl_subtype_indication_t = {
+ name : string;
+ definition : vhdl_type_t option; [@default Some Void]
+}
+[@@deriving yojson { strict = false }]
-(* TODO ? Shall we merge definition / declaration *)
+(* TODO ? Shall we merge definition / declaration *)
type vhdl_definition_t =
- | Type of {name : string ; definition: vhdl_type_t} [@name "TYPE_DECLARATION"]
- | Subtype of {name : string ; typ : vhdl_subtype_indication_t} [@name "SUBTYPE_DECLARATION"]
-[@@deriving yojson {strict = false}];;
-
+ | Type of { name : string; definition : vhdl_type_t }
+ [@name "TYPE_DECLARATION"]
+ | Subtype of { name : string; typ : vhdl_subtype_indication_t }
+ [@name "SUBTYPE_DECLARATION"]
+[@@deriving yojson { strict = false }]
+
type vhdl_declaration_t =
- | VarDecl of { names : string list; typ : vhdl_subtype_indication_t; init_val : cst_val_t option [@default Some (CstInt (0))] } [@name "VARIABLE_DECLARATION"]
- | CstDecl of { names : string list; typ : vhdl_subtype_indication_t; init_val : cst_val_t } [@name "CONSTANT_DECLARATION"]
- | SigDecl of { names : string list; typ : vhdl_subtype_indication_t; init_val : cst_val_t option [@default Some (CstInt (0))] } [@name "SIGNAL_DECLARATION"]
-[@@deriving yojson {strict = false}];;
+ | VarDecl of {
+ names : string list;
+ typ : vhdl_subtype_indication_t;
+ init_val : cst_val_t option; [@default Some (CstInt 0)]
+ } [@name "VARIABLE_DECLARATION"]
+ | CstDecl of {
+ names : string list;
+ typ : vhdl_subtype_indication_t;
+ init_val : cst_val_t;
+ } [@name "CONSTANT_DECLARATION"]
+ | SigDecl of {
+ names : string list;
+ typ : vhdl_subtype_indication_t;
+ init_val : cst_val_t option; [@default Some (CstInt 0)]
+ } [@name "SIGNAL_DECLARATION"]
+[@@deriving yojson { strict = false }]
-(************************************************************************************)
-(* Attributes for types, arrays, signals and strings *)
-(************************************************************************************)
+(************************************************************************************)
+(* Attributes for types, arrays, signals and strings *)
+(************************************************************************************)
type 'basetype vhdl_type_attributes_t =
- | TAttNoArg of { id: string }
- | TAttIntArg of { id: string; arg: int }
- | TAttValArg of { id: string; arg: 'basetype }
- | TAttStringArg of { id: string; arg: string }
-[@@deriving yojson {strict = false}];;
-
-let typ_att_noarg = ["base"; "left"; "right"; "high"; "low"]
-let typ_att_intarg = ["pos"; "val"; "succ"; "pred"; "leftof"; "rightof"]
-let typ_att_valarg = ["image"]
-let typ_att_stringarg = ["value"]
-
-type vhdl_array_attributes_t = AAttInt of { id: string; arg: int; } | AAttAscending
-[@@deriving yojson {strict = false}];;
-
-let array_att_intarg = ["left"; "right"; "high"; "low"; "range"; "reverse_range"; "length"]
+ | TAttNoArg of { id : string }
+ | TAttIntArg of { id : string; arg : int }
+ | TAttValArg of { id : string; arg : 'basetype }
+ | TAttStringArg of { id : string; arg : string }
+[@@deriving yojson { strict = false }]
+
+let typ_att_noarg = [ "base"; "left"; "right"; "high"; "low" ]
+
+let typ_att_intarg = [ "pos"; "val"; "succ"; "pred"; "leftof"; "rightof" ]
+
+let typ_att_valarg = [ "image" ]
+
+let typ_att_stringarg = [ "value" ]
+
+type vhdl_array_attributes_t =
+ | AAttInt of { id : string; arg : int }
+ | AAttAscending
+[@@deriving yojson { strict = false }]
+
+let array_att_intarg =
+ [ "left"; "right"; "high"; "low"; "range"; "reverse_range"; "length" ]
type vhdl_signal_attributes_t = SigAtt of string
-[@@deriving yojson {strict = false}];;
+[@@deriving yojson { strict = false }]
type vhdl_string_attributes_t = StringAtt of string
-[@@deriving yojson {strict = false}];;
+[@@deriving yojson { strict = false }]
-(************************************************************************************)
-(* Expressions / Statements *)
-(************************************************************************************)
+(************************************************************************************)
+(* Expressions / Statements *)
+(************************************************************************************)
type suffix_selection_t = Idx of int | Range of int * int
-[@@deriving yojson {strict = false}];;
+[@@deriving yojson { strict = false }]
type vhdl_expr_t =
| Call of vhdl_name_t [@name "CALL"]
| Cst of cst_val_t [@name "CONSTANT_VALUE"]
- | Op of { id: string [@default ""]; args: vhdl_expr_t list [@default []]} [@name "EXPRESSION"]
+ | Op of { id : string; [@default ""] args : vhdl_expr_t list [@default []] }
+ [@name "EXPRESSION"]
| IsNull [@name "IsNull"]
- | Time of { value: int; phy_unit: string [@default ""]}
- | Sig of { name: string; att: vhdl_signal_attributes_t option }
+ | Time of { value : int; phy_unit : string [@default ""] }
+ | Sig of { name : string; att : vhdl_signal_attributes_t option }
| SuffixMod of { expr : vhdl_expr_t; selection : suffix_selection_t }
-[@@deriving yojson {strict = false}]
-and
-vhdl_name_t =
+[@@deriving yojson { strict = false }]
+
+and vhdl_name_t =
| Simple of string [@name "SIMPLE_NAME"]
| Selected of vhdl_name_t list [@name "SELECTED_NAME"]
- | Index of { id: vhdl_name_t; exprs: vhdl_expr_t list } [@name "INDEXED_NAME"]
- | Slice of { id: vhdl_name_t; range: vhdl_type_t } [@name "SLICE_NAME"]
- | Attribute of { id: vhdl_name_t; designator: vhdl_name_t; expr: vhdl_expr_t [@default IsNull]} [@name "ATTRIBUTE_NAME"]
- | Function of { id: vhdl_name_t; assoc_list: vhdl_assoc_element_t list } [@name "FUNCTION_CALL"]
+ | Index of { id : vhdl_name_t; exprs : vhdl_expr_t list }
+ [@name "INDEXED_NAME"]
+ | Slice of { id : vhdl_name_t; range : vhdl_type_t } [@name "SLICE_NAME"]
+ | Attribute of {
+ id : vhdl_name_t;
+ designator : vhdl_name_t;
+ expr : vhdl_expr_t; [@default IsNull]
+ } [@name "ATTRIBUTE_NAME"]
+ | Function of { id : vhdl_name_t; assoc_list : vhdl_assoc_element_t list }
+ [@name "FUNCTION_CALL"]
| NoName
-[@@deriving yojson {strict = false}]
-and vhdl_assoc_element_t =
- {
- formal_name: vhdl_name_t option [@default Some NoName];
- formal_arg: vhdl_name_t option [@default Some NoName];
- actual_name: vhdl_name_t option [@default Some NoName];
- actual_designator: vhdl_name_t option [@default Some NoName];
- actual_expr: vhdl_expr_t option [@default Some IsNull];
- }
-[@@deriving yojson {strict = false}];;
-
-let arith_funs = ["+";"-";"*";"/";"mod"; "rem";"abs";"**";"&"]
-let bool_funs = ["and"; "or"; "nand"; "nor"; "xor"; "not"]
-let rel_funs = ["<";">";"<=";">=";"/=";"=";"?=";"?/=";"?<";"?<=";"?>";"?>=";"??"]
-let shift_funs = ["sll";"srl";"sla";"sra";"rol";"ror"]
-
-type vhdl_sequential_stmt_t =
- | VarAssign of { lhs: vhdl_name_t; rhs: vhdl_expr_t }
- | SigSeqAssign of { label: string [@default ""]; lhs: vhdl_name_t; rhs: vhdl_expr_t list} [@name "SIGNAL_ASSIGNMENT_STATEMENT"]
- | If of { label: string [@default ""]; if_cases: vhdl_if_case_t list;
- default: vhdl_sequential_stmt_t list [@default []]; } [@name "IF_STATEMENT"]
- | Case of { guard: vhdl_expr_t; branches: vhdl_case_item_t list } [@name "CASE_STATEMENT_TREE"]
- | Exit of { label: string [@default ""]; loop_label: string option [@default Some ""]; condition: vhdl_expr_t option [@default Some IsNull]} [@name "EXIT_STATEMENT"]
- | Assert of { label: string [@default ""]; cond: vhdl_expr_t; report: vhdl_expr_t [@default IsNull]; severity: vhdl_expr_t [@default IsNull]} [@name "ASSERTION_STATEMENT"]
+[@@deriving yojson { strict = false }]
+
+and vhdl_assoc_element_t = {
+ formal_name : vhdl_name_t option; [@default Some NoName]
+ formal_arg : vhdl_name_t option; [@default Some NoName]
+ actual_name : vhdl_name_t option; [@default Some NoName]
+ actual_designator : vhdl_name_t option; [@default Some NoName]
+ actual_expr : vhdl_expr_t option; [@default Some IsNull]
+}
+[@@deriving yojson { strict = false }]
+
+let arith_funs = [ "+"; "-"; "*"; "/"; "mod"; "rem"; "abs"; "**"; "&" ]
+
+let bool_funs = [ "and"; "or"; "nand"; "nor"; "xor"; "not" ]
+
+let rel_funs =
+ [
+ "<"; ">"; "<="; ">="; "/="; "="; "?="; "?/="; "?<"; "?<="; "?>"; "?>="; "??";
+ ]
+
+let shift_funs = [ "sll"; "srl"; "sla"; "sra"; "rol"; "ror" ]
+
+type vhdl_sequential_stmt_t =
+ | VarAssign of { lhs : vhdl_name_t; rhs : vhdl_expr_t }
+ | SigSeqAssign of {
+ label : string; [@default ""]
+ lhs : vhdl_name_t;
+ rhs : vhdl_expr_t list;
+ } [@name "SIGNAL_ASSIGNMENT_STATEMENT"]
+ | If of {
+ label : string; [@default ""]
+ if_cases : vhdl_if_case_t list;
+ default : vhdl_sequential_stmt_t list; [@default []]
+ } [@name "IF_STATEMENT"]
+ | Case of { guard : vhdl_expr_t; branches : vhdl_case_item_t list }
+ [@name "CASE_STATEMENT_TREE"]
+ | Exit of {
+ label : string; [@default ""]
+ loop_label : string option; [@default Some ""]
+ condition : vhdl_expr_t option; [@default Some IsNull]
+ } [@name "EXIT_STATEMENT"]
+ | Assert of {
+ label : string; [@default ""]
+ cond : vhdl_expr_t;
+ report : vhdl_expr_t; [@default IsNull]
+ severity : vhdl_expr_t; [@default IsNull]
+ } [@name "ASSERTION_STATEMENT"]
| Wait [@name "WAIT_STATEMENT"]
- | Null of { label: string [@default ""]} [@name "NULL_STATEMENT"]
-and vhdl_if_case_t =
- {
- if_cond: vhdl_expr_t;
- if_block: vhdl_sequential_stmt_t list;
- }
-and vhdl_case_item_t =
- {
- when_cond: vhdl_expr_t list;
- when_stmt: vhdl_sequential_stmt_t list;
- }
-[@@deriving yojson {strict = false}];;
-
-type signal_condition_t =
- {
- expr: vhdl_expr_t list; (* when expression *)
- cond: vhdl_expr_t [@default IsNull]; (* optional else case expression.
- If None, could be a latch *)
- }
-[@@deriving yojson {strict = false}];;
-
-type signal_selection_t =
- {
- expr : vhdl_expr_t;
- when_sel: vhdl_expr_t list [@default []];
- }
-[@@deriving yojson {strict = false}];;
-
-type conditional_signal_t =
- {
- postponed: bool [@default false];
- label: string option [@default Some ""];
- lhs: vhdl_name_t; (* assigned signal = target*)
- rhs: signal_condition_t list; (* expression *)
- cond: vhdl_expr_t [@default IsNull];
- delay: vhdl_expr_t [@default IsNull];
- }
-[@@deriving yojson {strict = false}];;
-
-type process_t =
- {
- id: string option [@default Some ""];
- declarations: vhdl_declaration_t list option [@key "PROCESS_DECLARATIVE_PART"] [@default Some []];
- active_sigs: vhdl_name_t list [@default []];
- body: vhdl_sequential_stmt_t list [@key "PROCESS_STATEMENT_PART"] [@default []]
- }
-[@@deriving yojson {strict = false}];;
-
-type selected_signal_t =
- {
- postponed: bool [@default false];
- label: string option [@default Some ""];
- lhs: vhdl_name_t; (* assigned signal = target *)
- sel: vhdl_expr_t;
- branches: signal_selection_t list [@default []];
- delay: vhdl_expr_t option;
- }
-[@@deriving yojson {strict = false}];;
-
+ | Null of { label : string [@default ""] } [@name "NULL_STATEMENT"]
+
+and vhdl_if_case_t = {
+ if_cond : vhdl_expr_t;
+ if_block : vhdl_sequential_stmt_t list;
+}
+
+and vhdl_case_item_t = {
+ when_cond : vhdl_expr_t list;
+ when_stmt : vhdl_sequential_stmt_t list;
+}
+[@@deriving yojson { strict = false }]
+
+type signal_condition_t = {
+ expr : vhdl_expr_t list;
+ (* when expression *)
+ cond : vhdl_expr_t; [@default IsNull]
+ (* optional else case expression. If None, could be a latch *)
+}
+[@@deriving yojson { strict = false }]
+
+type signal_selection_t = {
+ expr : vhdl_expr_t;
+ when_sel : vhdl_expr_t list; [@default []]
+}
+[@@deriving yojson { strict = false }]
+
+type conditional_signal_t = {
+ postponed : bool; [@default false]
+ label : string option; [@default Some ""]
+ lhs : vhdl_name_t;
+ (* assigned signal = target*)
+ rhs : signal_condition_t list;
+ (* expression *)
+ cond : vhdl_expr_t; [@default IsNull]
+ delay : vhdl_expr_t; [@default IsNull]
+}
+[@@deriving yojson { strict = false }]
+
+type process_t = {
+ id : string option; [@default Some ""]
+ declarations : vhdl_declaration_t list option;
+ [@key "PROCESS_DECLARATIVE_PART"] [@default Some []]
+ active_sigs : vhdl_name_t list; [@default []]
+ body : vhdl_sequential_stmt_t list;
+ [@key "PROCESS_STATEMENT_PART"] [@default []]
+}
+[@@deriving yojson { strict = false }]
+
+type selected_signal_t = {
+ postponed : bool; [@default false]
+ label : string option; [@default Some ""]
+ lhs : vhdl_name_t;
+ (* assigned signal = target *)
+ sel : vhdl_expr_t;
+ branches : signal_selection_t list; [@default []]
+ delay : vhdl_expr_t option;
+}
+[@@deriving yojson { strict = false }]
+
type vhdl_concurrent_stmt_t =
| SigAssign of conditional_signal_t [@name "CONDITIONAL_SIGNAL_ASSIGNMENT"]
| Process of process_t [@name "PROCESS_STATEMENT"]
| SelectedSig of selected_signal_t [@name "SELECTED_SIGNAL_ASSIGNMENT"]
-[@@deriving yojson {strict = false}];;
- (*
-type vhdl_statement_t =
-
- (* | DeclarationStmt of declaration_stmt_t *)
- | ConcurrentStmt of vhdl_concurrent_stmt_t
- | SequentialStmt of vhdl_sequential_stmt_t
- *)
-
-(************************************************************************************)
-(* Entities *)
-(************************************************************************************)
-
+[@@deriving yojson { strict = false }]
+
+(* type vhdl_statement_t =
+
+ (* | DeclarationStmt of declaration_stmt_t *) | ConcurrentStmt of
+ vhdl_concurrent_stmt_t | SequentialStmt of vhdl_sequential_stmt_t *)
+
+(************************************************************************************)
+(* Entities *)
+(************************************************************************************)
+
(* TODO? Seems to appear optionally in entities *)
-type vhdl_generic_t = unit
-[@@deriving yojson {strict = false}];;
-
-type vhdl_port_kind_t =
- InPort [@name "in"]
- | OutPort [@name "out"]
- | InoutPort [@name "inout"]
+type vhdl_generic_t = unit [@@deriving yojson { strict = false }]
+
+type vhdl_port_kind_t =
+ | InPort [@name "in"]
+ | OutPort [@name "out"]
+ | InoutPort [@name "inout"]
| BufferPort [@name "buffer"]
-[@@deriving yojson];;
-
-type vhdl_port_t =
- {
- names: string list [@default []];
- kind: vhdl_port_kind_t;
- typ : string;
-(* typ: vhdl_type_t; *)
- }
-[@@deriving yojson {strict = false}];;
-
-type vhdl_entity_t =
- {
- name: string [@default ""];
- generics: vhdl_generic_t list option [@key "GENERIC_CLAUSE"] [@default Some []];
- ports: vhdl_port_t list [@key "PORT_CLAUSE"] [@default []];
- }
-[@@deriving yojson {strict = false}];;
-
-(************************************************************************************)
-(* Packages / Library loading *)
-(************************************************************************************)
-
+[@@deriving yojson]
+
+type vhdl_port_t = {
+ names : string list; [@default []]
+ kind : vhdl_port_kind_t;
+ typ : string; (* typ: vhdl_type_t; *)
+}
+[@@deriving yojson { strict = false }]
+
+type vhdl_entity_t = {
+ name : string; [@default ""]
+ generics : vhdl_generic_t list option;
+ [@key "GENERIC_CLAUSE"] [@default Some []]
+ ports : vhdl_port_t list; [@key "PORT_CLAUSE"] [@default []]
+}
+[@@deriving yojson { strict = false }]
+
+(************************************************************************************)
+(* Packages / Library loading *)
+(************************************************************************************)
+
(* Optional. Describes shared definitions *)
-type vhdl_package_t =
- {
- name: string [@default ""];
- shared_defs: vhdl_definition_t list [@default []];
- }
-[@@deriving yojson {strict = false}];;
-
-type vhdl_load_t =
- Library of string list [@name "LIBRARY_CLAUSE"] [@default ""]
+type vhdl_package_t = {
+ name : string; [@default ""]
+ shared_defs : vhdl_definition_t list; [@default []]
+}
+[@@deriving yojson { strict = false }]
+
+type vhdl_load_t =
+ | Library of string list [@name "LIBRARY_CLAUSE"] [@default ""]
| Use of string list [@name "USE_CLAUSE"] [@default []]
-[@@deriving yojson];;
-
-(************************************************************************************)
-(* Architecture / VHDL Design *)
-(************************************************************************************)
-
-type vhdl_architecture_t =
- {
- name: string [@default ""];
- entity: string [@default ""];
- declarations: vhdl_declaration_t list option [@key "ARCHITECTURE_DECLARATIVE_PART"] [@default Some []];
- body: vhdl_concurrent_stmt_t list option [@key "ARCHITECTURE_STATEMENT_PART"] [@default Some []];
- }
-[@@deriving yojson {strict = false}];;
-
+[@@deriving yojson]
+
+(************************************************************************************)
+(* Architecture / VHDL Design *)
+(************************************************************************************)
+
+type vhdl_architecture_t = {
+ name : string; [@default ""]
+ entity : string; [@default ""]
+ declarations : vhdl_declaration_t list option;
+ [@key "ARCHITECTURE_DECLARATIVE_PART"] [@default Some []]
+ body : vhdl_concurrent_stmt_t list option;
+ [@key "ARCHITECTURE_STATEMENT_PART"] [@default Some []]
+}
+[@@deriving yojson { strict = false }]
+
(* TODO. Configuration is optional *)
-type vhdl_configuration_t = unit
-[@@deriving yojson {strict = false}];;
-
-type vhdl_design_t =
- {
- packages: vhdl_package_t list [@key "PACKAGE_DECLARATION"] [@default []];
- libraries: vhdl_load_t list option [@key "CONTEXT_CLAUSE"] [@default Some []];
- entities: vhdl_entity_t list [@key "ENTITY_DECLARATION"] [@default []];
- architectures: vhdl_architecture_t list [@key "ARCHITECTURE_BODY"] [@default []];
- configuration: vhdl_configuration_t option [@key "CONFIGURATION_DECLARATION"] [@default Some ()];
- }
-[@@deriving yojson {strict = false}];;
-
-type vhdl_design_file_t =
- {
- design_unit: vhdl_design_t list [@key "DESIGN_UNIT"] [@default []];
- }
-[@@deriving yojson {strict = false}];;
-
-type vhdl_file_t =
- {
- design_file: vhdl_design_file_t [@key "DESIGN_FILE"];
- }
-[@@deriving yojson];;
+type vhdl_configuration_t = unit [@@deriving yojson { strict = false }]
+
+type vhdl_design_t = {
+ packages : vhdl_package_t list; [@key "PACKAGE_DECLARATION"] [@default []]
+ libraries : vhdl_load_t list option;
+ [@key "CONTEXT_CLAUSE"] [@default Some []]
+ entities : vhdl_entity_t list; [@key "ENTITY_DECLARATION"] [@default []]
+ architectures : vhdl_architecture_t list;
+ [@key "ARCHITECTURE_BODY"] [@default []]
+ configuration : vhdl_configuration_t option;
+ [@key "CONFIGURATION_DECLARATION"] [@default Some ()]
+}
+[@@deriving yojson { strict = false }]
+
+type vhdl_design_file_t = {
+ design_unit : vhdl_design_t list; [@key "DESIGN_UNIT"] [@default []]
+}
+[@@deriving yojson { strict = false }]
+
+type vhdl_file_t = { design_file : vhdl_design_file_t [@key "DESIGN_FILE"] }
+[@@deriving yojson]
diff --git a/src/tools/importer/vhdl_json_lib.ml b/src/tools/importer/vhdl_json_lib.ml
index 50dc68b88bfe4386e75a9ee294071d98ae678fa1..336a4ba5fff4381dd5a24e9085bfdd5af16c0ced 100644
--- a/src/tools/importer/vhdl_json_lib.ml
+++ b/src/tools/importer/vhdl_json_lib.ml
@@ -2,227 +2,225 @@ open Yojson.Safe.Util
let rec assoc_map_except_str l f str =
match l with
- | (s,x)::y ->
- if (String.equal s str) then
- assoc_map_except_str y f str
- else
- (s,f str x)::assoc_map_except_str y f str
- | [] -> []
+ | (s, x) :: y ->
+ if String.equal s str then assoc_map_except_str y f str
+ else (s, f str x) :: assoc_map_except_str y f str
+ | [] ->
+ []
let rec map_2_args f l arg1 =
- match l with
- | hd::tl -> (f arg1 hd)::(map_2_args f tl arg1)
- | [] -> []
+ match l with hd :: tl -> f arg1 hd :: map_2_args f tl arg1 | [] -> []
-(*
-Remove `Assoc nodes with tag 'str' in json j
-*)
+(* Remove `Assoc nodes with tag 'str' in json j *)
let rec prune_str str json =
match json with
- | `Assoc ((t,hd)::tl) ->
- if (String.equal str t) then
- `Assoc (assoc_map_except_str tl prune_str str)
- else
- `Assoc ((t, prune_str str hd)::(assoc_map_except_str tl prune_str str))
- | `List (hd::tl) -> `List ((prune_str str hd)::(map_2_args prune_str tl str))
- | `String (s) -> if (String.equal str s) then `String ("") else `String (s)
- | x -> x
+ | `Assoc ((t, hd) :: tl) ->
+ if String.equal str t then `Assoc (assoc_map_except_str tl prune_str str)
+ else `Assoc ((t, prune_str str hd) :: assoc_map_except_str tl prune_str str)
+ | `List (hd :: tl) ->
+ `List (prune_str str hd :: map_2_args prune_str tl str)
+ | `String s ->
+ if String.equal str s then `String "" else `String s
+ | x ->
+ x
(*******************)
let rec name_pair_list_to_string l =
match l with
- | (t, `String(x))::tl ->
- if (String.equal t "name") then
- (x::name_pair_list_to_string tl)
- else
- (name_pair_list_to_string tl)
- | _ -> []
+ | (t, `String x) :: tl ->
+ if String.equal t "name" then x :: name_pair_list_to_string tl
+ else name_pair_list_to_string tl
+ | _ ->
+ []
let assoc_filter_string l =
- match l with
- | `Assoc (x) -> name_pair_list_to_string x
- | _ -> []
+ match l with `Assoc x -> name_pair_list_to_string x | _ -> []
(********************)
let rec pairlist_remove str l f =
match l with
- | (t,j)::tl ->
- if (String.equal t str) then
- (f j)::(pairlist_remove str tl f)
- else
- `Assoc ((t, f j)::[])::(pairlist_remove str tl f)
- | [] -> []
+ | (t, j) :: tl ->
+ if String.equal t str then f j :: pairlist_remove str tl f
+ else `Assoc [ t, f j ] :: pairlist_remove str tl f
+ | [] ->
+ []
(******************)
-let rec assoc_elem_fst pair_list =
- match pair_list with
- | (t, _)::tl -> t::(assoc_elem_fst tl)
- | [] -> []
-
-let rec assoc_elem_snd pair_list =
- match pair_list with
- | (_, j)::tl -> j::(assoc_elem_snd tl)
- | [] -> []
-
-let rec assoc_elem_filter pair_list str =
- match pair_list with
- | (t,j)::tl -> if (String.equal t str) then
- (t,j)::(assoc_elem_filter tl str)
- else assoc_elem_filter tl str
- | [] -> []
-
-let rec assoc_elem_filternot pair_list str =
- match pair_list with
- | (t,j)::tl -> if (not (String.equal t str)) then
- (t,j)::(assoc_elem_filternot tl str)
- else assoc_elem_filternot tl str
- | [] -> []
-
-let rec assoc_elem_filter_snd pair_list str =
- match pair_list with
- | (t,j)::tl -> if (String.equal t str) then
- j::(assoc_elem_filter_snd tl str)
- else assoc_elem_filter_snd tl str
- | [] -> []
+let rec assoc_elem_fst pair_list =
+ match pair_list with (t, _) :: tl -> t :: assoc_elem_fst tl | [] -> []
+
+let rec assoc_elem_snd pair_list =
+ match pair_list with (_, j) :: tl -> j :: assoc_elem_snd tl | [] -> []
+
+let rec assoc_elem_filter pair_list str =
+ match pair_list with
+ | (t, j) :: tl ->
+ if String.equal t str then (t, j) :: assoc_elem_filter tl str
+ else assoc_elem_filter tl str
+ | [] ->
+ []
+
+let rec assoc_elem_filternot pair_list str =
+ match pair_list with
+ | (t, j) :: tl ->
+ if not (String.equal t str) then (t, j) :: assoc_elem_filternot tl str
+ else assoc_elem_filternot tl str
+ | [] ->
+ []
+
+let rec assoc_elem_filter_snd pair_list str =
+ match pair_list with
+ | (t, j) :: tl ->
+ if String.equal t str then j :: assoc_elem_filter_snd tl str
+ else assoc_elem_filter_snd tl str
+ | [] ->
+ []
let assoc_elem_filternot_snd pair_list str =
- match pair_list with
- | (t,j)::tl -> if (not (String.equal t str)) then
- j::(assoc_elem_filter_snd tl str)
- else assoc_elem_filter_snd tl str
- | [] -> []
-
-let rec pairlist_snd_as_list pair_list str =
- match pair_list with
- | (t,j)::tl -> if (String.equal t str) then
- (t,`List (j::[]))::(pairlist_snd_as_list tl str)
- else (t,j)::(pairlist_snd_as_list tl str)
- | [] -> []
+ match pair_list with
+ | (t, j) :: tl ->
+ if not (String.equal t str) then j :: assoc_elem_filter_snd tl str
+ else assoc_elem_filter_snd tl str
+ | [] ->
+ []
+
+let rec pairlist_snd_as_list pair_list str =
+ match pair_list with
+ | (t, j) :: tl ->
+ if String.equal t str then (t, `List [ j ]) :: pairlist_snd_as_list tl str
+ else (t, j) :: pairlist_snd_as_list tl str
+ | [] ->
+ []
let all_members str json =
- match json with
- | `Assoc (l) -> assoc_elem_filter_snd l str
- | _ -> []
+ match json with `Assoc l -> assoc_elem_filter_snd l str | _ -> []
let retain_other_members str json =
- match json with
- | `Assoc (l) -> `Assoc (assoc_elem_filter l str)
- | _ -> `Null
+ match json with `Assoc l -> `Assoc (assoc_elem_filter l str) | _ -> `Null
-(*
-DESIGN_UNIT as lists
-*)
+(* DESIGN_UNIT as lists *)
let vhdl_json_designunits_content_as_list json =
- let designunits_contents = json |> member "DESIGN_FILE" |> all_members "DESIGN_UNIT" in
+ let designunits_contents =
+ json |> member "DESIGN_FILE" |> all_members "DESIGN_UNIT"
+ in
`List designunits_contents
let vhdl_json_designfile_content_excluding json =
- json |> member "DESIGN_FILE" |> retain_other_members "DESIGN_UNIT"
+ json |> member "DESIGN_FILE" |> retain_other_members "DESIGN_UNIT"
let vhdl_json_list_designunits json =
let designunits_list = vhdl_json_designunits_content_as_list json in
- `Assoc (("DESIGN_FILE", (`Assoc (("DESIGN_UNIT", designunits_list)::[])))::[])
+ `Assoc [ "DESIGN_FILE", `Assoc [ "DESIGN_UNIT", designunits_list ] ]
let rec pairlist_contains_str str l =
match l with
- | (t, _)::tl -> if (String.equal t str) then true else pairlist_contains_str str tl
- | [] -> false
+ | (t, _) :: tl ->
+ if String.equal t str then true else pairlist_contains_str str tl
+ | [] ->
+ false
-(*
-ITEM element content as list
-*)
+(* ITEM element content as list *)
let assoc_elem_as_list str json =
- match json with
- | `Assoc (l) -> `Assoc (pairlist_snd_as_list l str)
- | x -> x
+ match json with `Assoc l -> `Assoc (pairlist_snd_as_list l str) | x -> x
let rec map_list map_f l f =
- match l with
- | hd::tl -> (map_f (f hd) f)::(map_list map_f tl f)
- | [] -> []
+ match l with hd :: tl -> map_f (f hd) f :: map_list map_f tl f | [] -> []
let rec map_pairlist map_f l f =
match l with
- | (t,j)::tl -> (t, map_f (f j) f)::(map_pairlist map_f tl f)
- | [] -> []
+ | (t, j) :: tl ->
+ (t, map_f (f j) f) :: map_pairlist map_f tl f
+ | [] ->
+ []
let rec map_snd f l =
- match l with
- | (t,j)::tl -> (t,f j)::(map_snd f tl)
- | [] -> []
+ match l with (t, j) :: tl -> (t, f j) :: map_snd f tl | [] -> []
let rec map_all json f =
match json with
- | `Assoc ((t,j)::tl) ->
- `Assoc ((t,(map_all (f j) f))::(map_pairlist map_all tl f))
- | `List (hd::tl) ->
- `List ((map_all (f hd) f)::(map_list map_all tl f))
- | x -> x
+ | `Assoc ((t, j) :: tl) ->
+ `Assoc ((t, map_all (f j) f) :: map_pairlist map_all tl f)
+ | `List (hd :: tl) ->
+ `List (map_all (f hd) f :: map_list map_all tl f)
+ | x ->
+ x
let numeric_literal_simpl json =
match json with
- | `Assoc (("NUMERIC_LITERAL", `Assoc (("TOKEN", `Assoc (("text", `String(x))::[]))::[]))::[]) -> `String (x)
- | x -> x
+ | `Assoc
+ [
+ ("NUMERIC_LITERAL", `Assoc [ ("TOKEN", `Assoc [ ("text", `String x) ]) ]);
+ ] ->
+ `String x
+ | x ->
+ x
-let flatten_numeric_literal json =
- map_all json (numeric_literal_simpl)
+let flatten_numeric_literal json = map_all json numeric_literal_simpl
-let to_list_str str json =
- map_all json (assoc_elem_as_list str)
+let to_list_str str json = map_all json (assoc_elem_as_list str)
let rec to_list_content_str str json =
match json with
- | `Assoc (l) -> if (pairlist_contains_str str l) then
- `Assoc (
- (str, to_list_content_str str (`List (assoc_elem_filter_snd l str)))
- ::(assoc_elem_filternot (map_snd (to_list_content_str str) l) str)
- )
- else
- `Assoc (map_snd (to_list_content_str str) l)
- | `List (hd::tl) -> `List ((to_list_content_str str hd)::(List.map (to_list_content_str str) tl))
- | x -> x
+ | `Assoc l ->
+ if pairlist_contains_str str l then
+ `Assoc
+ ((str, to_list_content_str str (`List (assoc_elem_filter_snd l str)))
+ :: assoc_elem_filternot (map_snd (to_list_content_str str) l) str)
+ else `Assoc (map_snd (to_list_content_str str) l)
+ | `List (hd :: tl) ->
+ `List (to_list_content_str str hd :: List.map (to_list_content_str str) tl)
+ | x ->
+ x
let rec prune_null_assoc json =
match json with
- | `Assoc ((_, `Assoc([]))::tl) -> prune_null_assoc (`Assoc tl)
- | `Assoc ((_, `Null)::tl) -> prune_null_assoc (`Assoc tl)
- | `Assoc ((t, j)::tl) -> `Assoc ((t, (prune_null_assoc j))::(map_snd prune_null_assoc tl))
- | `List (`Null::[]) -> `Null
- | `List (l) -> `List (List.map prune_null_assoc l)
- | x -> x
-
-(*
-Value printers
-*)
+ | `Assoc ((_, `Assoc []) :: tl) ->
+ prune_null_assoc (`Assoc tl)
+ | `Assoc ((_, `Null) :: tl) ->
+ prune_null_assoc (`Assoc tl)
+ | `Assoc ((t, j) :: tl) ->
+ `Assoc ((t, prune_null_assoc j) :: map_snd prune_null_assoc tl)
+ | `List [ `Null ] ->
+ `Null
+ | `List l ->
+ `List (List.map prune_null_assoc l)
+ | x ->
+ x
+
+(* Value printers *)
let rec print_depth json depth indent =
- if (depth > 0) then
+ if depth > 0 then
match json with
- | `Assoc ((t,j)::tl) ->
- (indent^t)::(List.append (print_depth j (depth-1) (indent^" "))
- (print_depth (`Assoc (tl)) depth indent))
- | `List (hd::tl) ->
- List.append (print_depth hd depth indent)
- (print_depth (`List (tl)) depth indent)
- | `String (s) -> (indent^s)::[]
- | _ -> []
- else
- []
+ | `Assoc ((t, j) :: tl) ->
+ (indent ^ t)
+ ::
+ List.append
+ (print_depth j (depth - 1) (indent ^ " "))
+ (print_depth (`Assoc tl) depth indent)
+ | `List (hd :: tl) ->
+ List.append
+ (print_depth hd depth indent)
+ (print_depth (`List tl) depth indent)
+ | `String s ->
+ [ indent ^ s ]
+ | _ ->
+ []
+ else []
let rec flatten_ivd json =
match json with
- | `Assoc ((t, `List (l))::[]) -> if (String.equal t "INTERFACE_VARIABLE_DECLARATION") then
- `List (List.map flatten_ivd l) else `Assoc ((t, flatten_ivd (`List(l)))::[])
- | `Assoc (l) -> `Assoc (map_snd flatten_ivd l)
- | `List (hd::tl) -> `List((flatten_ivd hd)::(List.map flatten_ivd tl))
- | x -> x
-
-(*
-let do_stuff json =
- match json with
- | `Assoc ((t,j)::tl) ->
- | `List (hd::tl) ->
- | `String (s) ->
- | _ -> x
-*)
+ | `Assoc [ (t, `List l) ] ->
+ if String.equal t "INTERFACE_VARIABLE_DECLARATION" then
+ `List (List.map flatten_ivd l)
+ else `Assoc [ t, flatten_ivd (`List l) ]
+ | `Assoc l ->
+ `Assoc (map_snd flatten_ivd l)
+ | `List (hd :: tl) ->
+ `List (flatten_ivd hd :: List.map flatten_ivd tl)
+ | x ->
+ x
+
+(* let do_stuff json = match json with | `Assoc ((t,j)::tl) -> | `List (hd::tl)
+ -> | `String (s) -> | _ -> x *)
diff --git a/src/tools/seal/dune b/src/tools/seal/dune
index 2f77ac7d07d4c64d60d252115a9567b138a12b28..f12da9c97700b39e7d91f1b0413cc2930e233803 100644
--- a/src/tools/seal/dune
+++ b/src/tools/seal/dune
@@ -9,5 +9,6 @@
(plugin
(name seal_verifier)
(libraries lustrec.seal_verifier)
- (site (lustrec verifiers))
+ (site
+ (lustrec verifiers))
(optional))
diff --git a/src/tools/seal/seal_export.ml b/src/tools/seal/seal_export.ml
index 5715478dd33be7a137ffced018688dd8a094a1a9..ad8d152012a0b25cbb40847987ad071a7c0a30c7 100644
--- a/src/tools/seal/seal_export.ml
+++ b/src/tools/seal/seal_export.ml
@@ -1,8 +1,4 @@
-(* Multiple export channels for switched systems:
-- lustre
-- matlab
-- text
- *)
+(* Multiple export channels for switched systems: - lustre - matlab - text *)
open Lustre_types
open Machine_code_types
open Seal_utils
@@ -11,105 +7,108 @@ let verbose = true
let process_sw vars f_e sw =
let process_branch g_opt up =
- let el = List.map (fun (v,e) -> v, f_e e) up in
- (* Sorting list of elements, according to vars, safety check to
- ensure that no variable is forgotten. *)
- let el, forgotten = List.fold_right (fun v (res, remaining) ->
- let vid = v.var_id in
- if List.mem_assoc vid remaining then
- ((List.assoc vid remaining)::res),
- (List.remove_assoc vid remaining)
- else (
- Format.eprintf
- "Looking for variable %s in remaining expressions: [%a]@."
- vid
- (Utils.fprintf_list ~sep:";@ "
- (fun fmt (id,e) ->
- Format.fprintf fmt
- "(%s -> %a)"
- id
- Printers.pp_expr e))
- remaining;
- assert false (* Missing variable v in list *)
- )
- ) vars ([], el)
+ let el = List.map (fun (v, e) -> v, f_e e) up in
+ (* Sorting list of elements, according to vars, safety check to ensure that
+ no variable is forgotten. *)
+ let el, forgotten =
+ List.fold_right
+ (fun v (res, remaining) ->
+ let vid = v.var_id in
+ if List.mem_assoc vid remaining then
+ List.assoc vid remaining :: res, List.remove_assoc vid remaining
+ else (
+ Format.eprintf
+ "Looking for variable %s in remaining expressions: [%a]@." vid
+ (Utils.fprintf_list ~sep:";@ " (fun fmt (id, e) ->
+ Format.fprintf fmt "(%s -> %a)" id Printers.pp_expr e))
+ remaining;
+ assert false (* Missing variable v in list *)))
+ vars ([], el)
in
assert (forgotten = []);
let loc = (List.hd el).expr_loc in
let new_e = Corelang.mkexpr loc (Expr_tuple el) in
match g_opt with
- None -> None, new_e, loc
+ | None ->
+ None, new_e, loc
| Some g ->
- let g = f_e g in
- let ee = Corelang.mkeexpr loc g in
- let new_e = if verbose then
- {new_e with
- expr_annot =
- Some ({annots = [["seal";"guards"],ee];
- annot_loc = loc})} else new_e
- in
- Some g, new_e, loc
+ let g = f_e g in
+ let ee = Corelang.mkeexpr loc g in
+ let new_e =
+ if verbose then
+ {
+ new_e with
+ expr_annot =
+ Some { annots = [ [ "seal"; "guards" ], ee ]; annot_loc = loc };
+ }
+ else new_e
+ in
+ Some g, new_e, loc
in
- let rec process_sw f_e sw =
+ let rec process_sw f_e sw =
match sw with
- | [] -> assert false
- | [g_opt,up] -> ((* last case, no need to guard it *)
+ | [] ->
+ assert false
+ | [ (g_opt, up) ] ->
+ (* last case, no need to guard it *)
let _, up_e, _ = process_branch g_opt up in
up_e
- )
- | (g_opt,up)::tl ->
- let g_opt, up_e, loc = process_branch g_opt up in
- match g_opt with
- | None -> (
- Format.eprintf "SEAL issue: process_sw with %a"
- (pp_sys Printers.pp_expr) sw
- ;
- assert false (* How could this happen anyway ? *)
- )
- | Some g ->
- let tl_e = process_sw f_e tl in
- Corelang.mkexpr loc (Expr_ite (g, up_e, tl_e))
+ | (g_opt, up) :: tl -> (
+ let g_opt, up_e, loc = process_branch g_opt up in
+ match g_opt with
+ | None ->
+ Format.eprintf "SEAL issue: process_sw with %a"
+ (pp_sys Printers.pp_expr) sw;
+ assert false (* How could this happen anyway ? *)
+ | Some g ->
+ let tl_e = process_sw f_e tl in
+ Corelang.mkexpr loc (Expr_ite (g, up_e, tl_e)))
in
process_sw f_e sw
-
let sw_to_lustre m sw_init sw_step init_out update_out =
let orig_nd = m.mname in
let copy_nd = orig_nd (*Corelang.copy_node orig_nd *) in
- let vl = (* vl are memories *)
+ let vl =
+ (* vl are memories *)
match sw_init with
- | [] -> [] (* the system is stateless. Returning an empty list
- shall do the job *)
-
- | (_, up)::_ ->
- List.map (fun (v,_) -> v) up
+ | [] ->
+ [] (* the system is stateless. Returning an empty list shall do the job *)
+ | (_, up) :: _ ->
+ List.map (fun (v, _) -> v) up
in
let loc = Location.dummy_loc in
let mem_eq =
- if m.mmemory = [] then
- []
+ if m.mmemory = [] then []
else
let e_init = process_sw m.mmemory (fun x -> x) sw_init in
let e_step = process_sw m.mmemory (Corelang.add_pre_expr vl) sw_step in
- [Eq
- { eq_loc = loc;
- eq_lhs = vl;
- eq_rhs = Corelang.mkexpr loc (Expr_arrow(e_init, e_step))
- }]
+ [
+ Eq
+ {
+ eq_loc = loc;
+ eq_lhs = vl;
+ eq_rhs = Corelang.mkexpr loc (Expr_arrow (e_init, e_step));
+ };
+ ]
in
let output_eq =
let e_init_out = process_sw copy_nd.node_outputs (fun x -> x) init_out in
- let e_update_out = process_sw copy_nd.node_outputs (Corelang.add_pre_expr vl) update_out in
- [
+ let e_update_out =
+ process_sw copy_nd.node_outputs (Corelang.add_pre_expr vl) update_out
+ in
+ [
Eq
- { eq_loc = loc;
- eq_lhs = List.map (fun v -> v.var_id) copy_nd.node_outputs;
- eq_rhs = Corelang.mkexpr loc (Expr_arrow(e_init_out, e_update_out))
+ {
+ eq_loc = loc;
+ eq_lhs = List.map (fun v -> v.var_id) copy_nd.node_outputs;
+ eq_rhs = Corelang.mkexpr loc (Expr_arrow (e_init_out, e_update_out));
};
]
in
let new_nd =
- { copy_nd with
+ {
+ copy_nd with
node_id = copy_nd.node_id ^ "_seal";
node_locals = m.mmemory;
node_stmts = mem_eq @ output_eq;
@@ -117,30 +116,31 @@ let sw_to_lustre m sw_init sw_step init_out update_out =
in
new_nd, orig_nd
-
let funsw_to_lustre m update_out =
let orig_nd = m.mname in
let copy_nd = orig_nd (*Corelang.copy_node orig_nd *) in
let output_eq =
- let e_update_out = process_sw copy_nd.node_outputs (fun x -> x) update_out in
- [
+ let e_update_out =
+ process_sw copy_nd.node_outputs (fun x -> x) update_out
+ in
+ [
Eq
- { eq_loc = Location.dummy_loc;
- eq_lhs = List.map (fun v -> v.var_id) copy_nd.node_outputs;
- eq_rhs = e_update_out
+ {
+ eq_loc = Location.dummy_loc;
+ eq_lhs = List.map (fun v -> v.var_id) copy_nd.node_outputs;
+ eq_rhs = e_update_out;
};
]
in
let new_nd =
- { copy_nd with
+ {
+ copy_nd with
node_id = copy_nd.node_id ^ "_seal";
node_locals = [];
node_stmts = output_eq;
}
in
new_nd, orig_nd
-
-
let to_lustre basename prog new_node orig_node =
let loc = Location.dummy_loc in
@@ -156,18 +156,22 @@ let to_lustre basename prog new_node orig_node =
in
let out = open_out output_file in
let fmt = Format.formatter_of_out_channel out in
- Format.fprintf fmt "%a@." Printers.pp_prog [new_top];
+ Format.fprintf fmt "%a@." Printers.pp_prog [ new_top ];
(* Verif output *)
- let output_file_verif = !Options.dest_dir ^ "/" ^ basename ^ "_seal_verif.lus" in
+ let output_file_verif =
+ !Options.dest_dir ^ "/" ^ basename ^ "_seal_verif.lus"
+ in
let out_verif = open_out output_file_verif in
let fmt_verif = Format.formatter_of_out_channel out_verif in
let check_nd = Lustre_utils.check_eq new_node orig_node in
let check_top =
- Corelang.mktop_decl Location.dummy_loc output_file_verif false (Node check_nd)
+ Corelang.mktop_decl Location.dummy_loc output_file_verif false
+ (Node check_nd)
in
- Format.fprintf fmt_verif "%a@." Printers.pp_prog (prog@[new_top;check_top])
-
+ Format.fprintf fmt_verif "%a@." Printers.pp_prog
+ (prog @ [ new_top; check_top ])
+
let node_to_lustre basename prog m sw_init sw_step init_out update_out =
let new_node, orig_nd = sw_to_lustre m sw_init sw_step init_out update_out in
to_lustre basename prog new_node orig_nd
@@ -175,4 +179,3 @@ let node_to_lustre basename prog m sw_init sw_step init_out update_out =
let fun_to_lustre basename prog m update_out =
let new_node, orig_nd = funsw_to_lustre m update_out in
to_lustre basename prog new_node orig_nd
-
diff --git a/src/tools/seal/seal_extract.ml b/src/tools/seal/seal_extract.ml
index 1a03b411140ed500de81a8eb2efebd055cb88248..d85a9e4fb08e5c0d3bd652c08d9c91907a295195 100644
--- a/src/tools/seal/seal_extract.ml
+++ b/src/tools/seal/seal_extract.ml
@@ -1,15 +1,13 @@
open Lustre_types
open Utils
-open Seal_utils
-open Zustre_data (* Access to Z3 context *)
-
-
+open Seal_utils
+open Zustre_data
+(* Access to Z3 context *)
+
(* Switched system extraction: expression are memoized *)
(*let expr_mem = Hashtbl.create 13*)
-
-let add_init defs vid =
- Hashtbl.add defs vid [[], IsInit]
+let add_init defs vid = Hashtbl.add defs vid [ [], IsInit ]
(**************************************************************)
(* Convert from Lustre expressions to Z3 expressions and back *)
@@ -19,676 +17,653 @@ let add_init defs vid =
let is_init_name = "__is_init"
let const_defs = Hashtbl.create 13
+
let is_const id = Hashtbl.mem const_defs id
-let is_enum_const id = Hashtbl.mem Zustre_data.const_tags id
+
+let is_enum_const id = Hashtbl.mem Zustre_data.const_tags id
+
let get_const id = Hashtbl.find const_defs id
-
-(* expressions are only basic constructs here, no more ite, tuples,
- arrows, fby, ... *)
+
+(* expressions are only basic constructs here, no more ite, tuples, arrows, fby,
+ ... *)
(* Set of hash to support memoization *)
-let expr_hash: (expr * Utils.tag) list ref = ref []
-let ze_hash: (Z3.Expr.expr, Utils.tag) Hashtbl.t = Hashtbl.create 13
-let e_hash: (Utils.tag, Z3.Expr.expr) Hashtbl.t = Hashtbl.create 13
-let pp_hash pp_key pp_v fmt h = Hashtbl.iter (fun key v -> Format.fprintf fmt "%a -> %a@ " pp_key key pp_v v) h
-let pp_e_map fmt = List.iter (fun (e,t) -> Format.fprintf fmt "%i -> %a@ " t Printers.pp_expr e) !expr_hash
-let pp_ze_hash fmt = pp_hash
- (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e))
- Format.pp_print_int
- fmt
- ze_hash
-let pp_e_hash fmt = pp_hash
- Format.pp_print_int
- (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e))
- fmt
- e_hash
+let expr_hash : (expr * Utils.tag) list ref = ref []
+
+let ze_hash : (Z3.Expr.expr, Utils.tag) Hashtbl.t = Hashtbl.create 13
+
+let e_hash : (Utils.tag, Z3.Expr.expr) Hashtbl.t = Hashtbl.create 13
+
+let pp_hash pp_key pp_v fmt h =
+ Hashtbl.iter
+ (fun key v -> Format.fprintf fmt "%a -> %a@ " pp_key key pp_v v)
+ h
+
+let pp_e_map fmt =
+ List.iter
+ (fun (e, t) -> Format.fprintf fmt "%i -> %a@ " t Printers.pp_expr e)
+ !expr_hash
+
+let pp_ze_hash fmt =
+ pp_hash
+ (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e))
+ Format.pp_print_int fmt ze_hash
+
+let pp_e_hash fmt =
+ pp_hash Format.pp_print_int
+ (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e))
+ fmt e_hash
+
let mem_expr e =
(* Format.eprintf "Searching for %a in map: @[<v 0>%t@]"
* Printers.pp_expr e
* pp_e_map; *)
- let res = List.exists (fun (e',_) -> Corelang.is_eq_expr e e') !expr_hash in
+ let res = List.exists (fun (e', _) -> Corelang.is_eq_expr e e') !expr_hash in
(* Format.eprintf "found?%b@." res; *)
res
-
-let mem_zexpr ze =
- Hashtbl.mem ze_hash ze
+
+let mem_zexpr ze = Hashtbl.mem ze_hash ze
+
let get_zexpr e =
- let _, uid = List.find (fun (e',_) -> Corelang.is_eq_expr e e') !expr_hash in
+ let _, uid = List.find (fun (e', _) -> Corelang.is_eq_expr e e') !expr_hash in
(* Format.eprintf "found expr=%a id=%i@." Printers.pp_expr eref eref.expr_tag; *)
Hashtbl.find e_hash uid
+
let get_expr ze =
let uid = Hashtbl.find ze_hash ze in
- let e,_ = List.find (fun (_, t) -> t = uid) !expr_hash in
+ let e, _ = List.find (fun (_, t) -> t = uid) !expr_hash in
e
-
-let neg_ze z3e = Z3.Boolean.mk_not !ctx z3e
-let is_init_z3e =
- Z3.Expr.mk_const_s !ctx is_init_name Zustre_common.bool_sort
-let get_zid (ze:Z3.Expr.expr) : Utils.tag =
+let neg_ze z3e = Z3.Boolean.mk_not !ctx z3e
+
+let is_init_z3e = Z3.Expr.mk_const_s !ctx is_init_name Zustre_common.bool_sort
+
+let get_zid (ze : Z3.Expr.expr) : Utils.tag =
try
- if Z3.Expr.equal ze is_init_z3e then -1 else
- if Z3.Expr.equal ze (neg_ze is_init_z3e) then -2 else
- Hashtbl.find ze_hash ze
- with _ -> (Format.eprintf "Looking for ze %s in Hash %a"
- (Z3.Expr.to_string ze)
- (fun fmt hash -> Hashtbl.iter (fun ze uid -> Format.fprintf fmt "%s -> %i@ " (Z3.Expr.to_string ze) uid) hash ) ze_hash;
- assert false)
+ if Z3.Expr.equal ze is_init_z3e then -1
+ else if Z3.Expr.equal ze (neg_ze is_init_z3e) then -2
+ else Hashtbl.find ze_hash ze
+ with _ ->
+ Format.eprintf "Looking for ze %s in Hash %a" (Z3.Expr.to_string ze)
+ (fun fmt hash ->
+ Hashtbl.iter
+ (fun ze uid ->
+ Format.fprintf fmt "%s -> %i@ " (Z3.Expr.to_string ze) uid)
+ hash)
+ ze_hash;
+ assert false
+
let add_expr =
let cpt = ref 0 in
fun e ze ->
- incr cpt;
- let uid = !cpt in
- expr_hash := (e, uid)::!expr_hash;
- Hashtbl.add e_hash uid ze;
- Hashtbl.add ze_hash ze uid
+ incr cpt;
+ let uid = !cpt in
+ expr_hash := (e, uid) :: !expr_hash;
+ Hashtbl.add e_hash uid ze;
+ Hashtbl.add ze_hash ze uid
-
let expr_to_z3_expr, zexpr_to_expr =
(* List to store converted expression. *)
(* let hash = ref [] in
* let comp_expr e (e', _) = Corelang.is_eq_expr e e' in
* let comp_zexpr ze (_, ze') = Z3.Expr.equal ze ze' in *)
-
let rec e2ze e =
- (* Format.eprintf "e2ze %a: %a@." Printers.pp_expr e Types.print_ty e.expr_type; *)
- if mem_expr e then (
- get_zexpr e
- )
- else (
+ (* Format.eprintf "e2ze %a: %a@." Printers.pp_expr e Types.print_ty
+ e.expr_type; *)
+ if mem_expr e then get_zexpr e
+ else
let res =
match e.expr_desc with
| Expr_const c ->
- let z3e = Zustre_common.horn_const_to_expr c in
- add_expr e z3e;
- z3e
- | Expr_ident id -> (
+ let z3e = Zustre_common.horn_const_to_expr c in
+ add_expr e z3e;
+ z3e
+ | Expr_ident id ->
if is_const id then (
let c = get_const id in
let z3e = Zustre_common.horn_const_to_expr c in
add_expr e z3e;
- z3e
- )
+ z3e)
else if is_enum_const id then (
let z3e = Zustre_common.horn_tag_to_expr id in
add_expr e z3e;
- z3e
- )
- else (
+ z3e)
+ else
let fdecl_id = Zustre_common.get_fdecl id in
let z3e = Z3.Expr.mk_const_f !ctx fdecl_id in
add_expr e z3e;
z3e
- )
- )
- | Expr_appl (id,args, None) (* no reset *) ->
- let el = Corelang.expr_list_of_expr args in
-
- let eltyp = List.map (fun e -> e.expr_type) el in
- let elv = List.map e2ze el in
- let z3e = Zustre_common.horn_basic_app id elv (eltyp, e.expr_type) in
- add_expr e z3e;
- z3e
- | Expr_tuple [e] ->
- let z3e = e2ze e in
- add_expr e z3e;
- z3e
- | _ -> ( match e.expr_desc with Expr_tuple _ -> Format.eprintf "tuple e2ze(%a)@.@?" Printers.pp_expr e
- | _ -> Format.eprintf "e2ze(%a)@.@?" Printers.pp_expr e)
- ; assert false
+ | Expr_appl (id, args, None) (* no reset *) ->
+ let el = Corelang.expr_list_of_expr args in
+
+ let eltyp = List.map (fun e -> e.expr_type) el in
+ let elv = List.map e2ze el in
+ let z3e = Zustre_common.horn_basic_app id elv (eltyp, e.expr_type) in
+ add_expr e z3e;
+ z3e
+ | Expr_tuple [ e ] ->
+ let z3e = e2ze e in
+ add_expr e z3e;
+ z3e
+ | _ ->
+ (match e.expr_desc with
+ | Expr_tuple _ ->
+ Format.eprintf "tuple e2ze(%a)@.@?" Printers.pp_expr e
+ | _ ->
+ Format.eprintf "e2ze(%a)@.@?" Printers.pp_expr e);
+ assert false
in
res
- )
in
let rec ze2e ze =
let ze_name ze =
let fd = Z3.Expr.get_func_decl ze in
Z3.Symbol.to_string (Z3.FuncDecl.get_name fd)
in
- if mem_zexpr ze then
- None, Some (get_expr ze)
+ if mem_zexpr ze then None, Some (get_expr ze)
else
let open Corelang in
let fd = Z3.Expr.get_func_decl ze in
let zel = Z3.Expr.get_args ze in
match Z3.Symbol.to_string (Z3.FuncDecl.get_name fd), zel with
- (* | var, [] -> (* should be in env *) get_e *)
+ (* | var, [] -> (* should be in env *) get_e *)
(* Extracting IsInit status *)
- | "not", [ze] when ze_name ze = is_init_name ->
- Some false, None
- | name, [] when name = is_init_name -> Some true, None
+ | "not", [ ze ] when ze_name ze = is_init_name ->
+ Some false, None
+ | name, [] when name = is_init_name ->
+ Some true, None
(* Other constructs are converted to a lustre expression *)
| op, _ -> (
-
-
if Z3.Expr.is_numeral ze then
let e =
if Z3.Arithmetic.is_real ze then
let s = Z3.Arithmetic.Real.numeral_to_string ze in
(* Use to return a Num.ratio. Now Q.t *)
let ratio = Z3.Arithmetic.Real.get_ratio ze in
- (*let num = Num.num_of_ratio ratio in
- let real = Real.create_num num s in*)
+ (* let num = Num.num_of_ratio ratio in let real = Real.create_num
+ num s in*)
let real = Real.create_q ratio s in
- mkexpr
- Location.dummy_loc
- (Expr_const
- (Const_real real))
+ mkexpr Location.dummy_loc (Expr_const (Const_real real))
else if Z3.Arithmetic.is_int ze then
- mkexpr
- Location.dummy_loc
+ mkexpr Location.dummy_loc
(Expr_const
- (Const_int
- (Z.to_int (Z3.Arithmetic.Integer.get_big_int ze))))
+ (Const_int (Z.to_int (Z3.Arithmetic.Integer.get_big_int ze))))
else if Z3.Expr.is_const ze then
match Z3.Expr.to_string ze with
- | "true" -> mkexpr Location.dummy_loc
- (Expr_const (Const_tag (tag_true)))
+ | "true" ->
+ mkexpr Location.dummy_loc (Expr_const (Const_tag tag_true))
| "false" ->
- mkexpr Location.dummy_loc
- (Expr_const (Const_tag (tag_false)))
- | _ -> assert false
- else
- (
- Format.eprintf "Const err: %s %b@." (Z3.Expr.to_string ze) (Z3.Expr.is_const ze);
- assert false (* a numeral but no int nor real *)
- )
+ mkexpr Location.dummy_loc (Expr_const (Const_tag tag_false))
+ | _ ->
+ assert false
+ else (
+ Format.eprintf "Const err: %s %b@." (Z3.Expr.to_string ze)
+ (Z3.Expr.is_const ze);
+ assert false (* a numeral but no int nor real *))
in
None, Some e
else
match op with
- | "not" | "=" | "-" | "*" | "/"
- | ">=" | "<=" | ">" | "<"
- ->
- let args = List.map (fun ze -> Utils.desome (snd (ze2e ze))) zel in
- None, Some (mkpredef_call Location.dummy_loc op args)
- | "+" -> ( (* Special treatment of + for 2+ args *)
+ | "not" | "=" | "-" | "*" | "/" | ">=" | "<=" | ">" | "<" ->
let args = List.map (fun ze -> Utils.desome (snd (ze2e ze))) zel in
- let e = match args with
- [] -> assert false
- | [hd] -> hd
- | e1::e2::tl ->
- let first_binary_and = mkpredef_call Location.dummy_loc op [e1;e2] in
- if tl = [] then first_binary_and else
- List.fold_left (fun e e_new ->
- mkpredef_call Location.dummy_loc op [e;e_new]
- ) first_binary_and tl
-
+ None, Some (mkpredef_call Location.dummy_loc op args)
+ | "+" ->
+ (* Special treatment of + for 2+ args *)
+ let args = List.map (fun ze -> Utils.desome (snd (ze2e ze))) zel in
+ let e =
+ match args with
+ | [] ->
+ assert false
+ | [ hd ] ->
+ hd
+ | e1 :: e2 :: tl ->
+ let first_binary_and =
+ mkpredef_call Location.dummy_loc op [ e1; e2 ]
+ in
+ if tl = [] then first_binary_and
+ else
+ List.fold_left
+ (fun e e_new ->
+ mkpredef_call Location.dummy_loc op [ e; e_new ])
+ first_binary_and tl
in
- None, Some e
- )
+
+ None, Some e
| "and" | "or" -> (
(* Special case since it can contain is_init pred *)
let args = List.map (fun ze -> ze2e ze) zel in
- let op = if op = "and" then "&&" else if op = "or" then "||" else assert false in
+ let op =
+ if op = "and" then "&&"
+ else if op = "or" then "||"
+ else assert false
+ in
match args with
- | [] -> assert false
- | [hd] -> hd
- | hd::tl ->
- List.fold_left
- (fun (is_init_opt1, expr_opt1) (is_init_opt2, expr_opt2) ->
- (match is_init_opt1, is_init_opt2 with
- None, x | x, None -> x
- | Some _, Some _ -> assert false),
- (match expr_opt1, expr_opt2 with
- | None, x | x, None -> x
+ | [] ->
+ assert false
+ | [ hd ] ->
+ hd
+ | hd :: tl ->
+ List.fold_left
+ (fun (is_init_opt1, expr_opt1) (is_init_opt2, expr_opt2) ->
+ ( (match is_init_opt1, is_init_opt2 with
+ | None, x | x, None ->
+ x
+ | Some _, Some _ ->
+ assert false),
+ match expr_opt1, expr_opt2 with
+ | None, x | x, None ->
+ x
| Some e1, Some e2 ->
- Some (mkpredef_call Location.dummy_loc op [e1; e2])
- ))
- hd tl
- )
- | op ->
- let args = List.map (fun ze -> (snd (ze2e ze))) zel in
- Format.eprintf "deal with op %s (nb args: %i). Expr is %s@." op (List.length args) (Z3.Expr.to_string ze); assert false
- )
+ Some (mkpredef_call Location.dummy_loc op [ e1; e2 ]) ))
+ hd tl)
+ | op ->
+ let args = List.map (fun ze -> snd (ze2e ze)) zel in
+ Format.eprintf "deal with op %s (nb args: %i). Expr is %s@." op
+ (List.length args) (Z3.Expr.to_string ze);
+ assert false)
in
- (fun e -> e2ze e), (fun ze -> ze2e ze)
+ (fun e -> e2ze e), fun ze -> ze2e ze
-
let zexpr_to_guard_list ze =
let init_opt, expr_opt = zexpr_to_expr ze in
- (match init_opt with
- | None -> []
- |Some b -> [IsInit, b]
- ) @ (match expr_opt with
- | None -> []
- | Some e -> [Expr e, true]
- )
-
-
+ (match init_opt with None -> [] | Some b -> [ IsInit, b ])
+ @ match expr_opt with None -> [] | Some e -> [ Expr e, true ]
+
let simplify_neg_guard l =
- List.map (fun (g,posneg) ->
+ List.map
+ (fun (g, posneg) ->
match g with
- | IsInit -> g, posneg
+ | IsInit ->
+ g, posneg
| Expr g ->
- if posneg then
- Expr (Corelang.push_negations g),
- true
- else
- (* Pushing the negation in the expression *)
- Expr(Corelang.push_negations ~neg:true g),
- true
- ) l
+ if posneg then Expr (Corelang.push_negations g), true
+ else
+ (* Pushing the negation in the expression *)
+ Expr (Corelang.push_negations ~neg:true g), true)
+ l
-(* TODO:
-individuellement demander si g1 => g2. Si c'est le cas, on peut ne garder que g1 dans la liste
-*)
+(* TODO: individuellement demander si g1 => g2. Si c'est le cas, on peut ne
+ garder que g1 dans la liste *)
(*****************************************************************)
(* Checking sat(isfiability) of an expression and simplifying it *)
(* All (free) variables have to be declared in the Z3 context *)
(*****************************************************************)
-(*
-let goal_simplify zl =
- let goal = Z3.Goal.mk_goal !ctx false false false in
- Z3.Goal.add goal zl;
- let goal' = Z3.Goal.simplify goal None in
- (* Format.eprintf "Goal before: %s@.Goal after : %s@.Sat? %s@."
- * (Z3.Goal.to_string goal)
- * (Z3.Goal.to_string goal')
- * (Z3.Solver.string_of_status status_res)
- * ; *)
- let ze = Z3.Goal.as_expr goal' in
- (* Format.eprintf "as an expr: %s@." (Z3.Expr.to_string ze); *)
- zexpr_to_guard_list ze
- *)
-
+(* let goal_simplify zl = let goal = Z3.Goal.mk_goal !ctx false false false in
+ Z3.Goal.add goal zl; let goal' = Z3.Goal.simplify goal None in (*
+ Format.eprintf "Goal before: %s@.Goal after : %s@.Sat? %s@." *
+ (Z3.Goal.to_string goal) * (Z3.Goal.to_string goal') *
+ (Z3.Solver.string_of_status status_res) * ; *) let ze = Z3.Goal.as_expr goal'
+ in (* Format.eprintf "as an expr: %s@." (Z3.Expr.to_string ze); *)
+ zexpr_to_guard_list ze *)
+
let implies =
- let ze_implies_hash : ((Utils.tag * Utils.tag), bool) Hashtbl.t = Hashtbl.create 13 in
+ let ze_implies_hash : (Utils.tag * Utils.tag, bool) Hashtbl.t =
+ Hashtbl.create 13
+ in
fun ze1 ze2 ->
- let ze1_uid = get_zid ze1 in
- let ze2_uid = get_zid ze2 in
- if Hashtbl.mem ze_implies_hash (ze1_uid, ze2_uid) then
- Hashtbl.find ze_implies_hash (ze1_uid, ze2_uid)
- else
- begin
- if !seal_debug then (
- report ~level:6 (fun fmt -> Format.fprintf fmt "Checking implication: %s => %s?@ "
- (Z3.Expr.to_string ze1) (Z3.Expr.to_string ze2)
- ));
+ let ze1_uid = get_zid ze1 in
+ let ze2_uid = get_zid ze2 in
+ if Hashtbl.mem ze_implies_hash (ze1_uid, ze2_uid) then
+ Hashtbl.find ze_implies_hash (ze1_uid, ze2_uid)
+ else (
+ if !seal_debug then
+ report ~level:6 (fun fmt ->
+ Format.fprintf fmt "Checking implication: %s => %s?@ "
+ (Z3.Expr.to_string ze1) (Z3.Expr.to_string ze2));
let solver = Z3.Solver.mk_simple_solver !ctx in
let tgt = Z3.Boolean.mk_not !ctx (Z3.Boolean.mk_implies !ctx ze1 ze2) in
let res =
try
- let status_res = Z3.Solver.check solver [tgt] in
+ let status_res = Z3.Solver.check solver [ tgt ] in
match status_res with
- | Z3.Solver.UNSATISFIABLE -> if !seal_debug then
- report ~level:6 (fun fmt -> Format.fprintf fmt "Valid!@ ");
- true
- | _ -> if !seal_debug then report ~level:6 (fun fmt -> Format.fprintf fmt "not proved valid@ ");
- false
- with Zustre_common.UnknownFunction(_, msg) -> (
+ | Z3.Solver.UNSATISFIABLE ->
+ if !seal_debug then
+ report ~level:6 (fun fmt -> Format.fprintf fmt "Valid!@ ");
+ true
+ | _ ->
+ if !seal_debug then
+ report ~level:6 (fun fmt ->
+ Format.fprintf fmt "not proved valid@ ");
+ false
+ with Zustre_common.UnknownFunction (_, msg) ->
report ~level:1 msg;
false
- )
in
- Hashtbl.add ze_implies_hash (ze1_uid,ze2_uid) res ;
- res
- end
-
+ Hashtbl.add ze_implies_hash (ze1_uid, ze2_uid) res;
+ res)
+
let rec simplify zl =
match zl with
- | [] | [_] -> zl
- | hd::tl -> (
- (* Forall e in tl, checking whether hd => e or e => hd, to keep hd
- in the first case and e in the second one *)
+ | [] | [ _ ] ->
+ zl
+ | hd :: tl ->
+ (* Forall e in tl, checking whether hd => e or e => hd, to keep hd in the
+ first case and e in the second one *)
let tl = simplify tl in
let keep_hd, tl =
- List.fold_left (fun (keep_hd, accu) e ->
- if implies hd e then
- true, accu (* throwing away e *)
- else if implies e hd then
- false, e::accu (* throwing away hd *)
- else
- keep_hd, e::accu (* keeping both *)
- ) (true,[]) tl
+ List.fold_left
+ (fun (keep_hd, accu) e ->
+ if implies hd e then true, accu (* throwing away e *)
+ else if implies e hd then false, e :: accu (* throwing away hd *)
+ else keep_hd, e :: accu (* keeping both *))
+ (true, []) tl
in
(* Format.eprintf "keep_hd?%b hd=%s, tl=[%a]@."
* keep_hd
* (Z3.Expr.to_string hd)
* (Utils.fprintf_list ~sep:"; " (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e))) tl
* ; *)
- if keep_hd then
- hd::tl
- else
- tl
- )
-
-let check_sat ?(just_check=false) (l: elem_boolexpr guard) : bool * (elem_boolexpr guard) =
+ if keep_hd then hd :: tl else tl
+
+let check_sat ?(just_check = false) (l : elem_boolexpr guard) :
+ bool * elem_boolexpr guard =
(* Syntactic simplification *)
- if false then
- Format.eprintf "Before simplify: %a@." (pp_guard_list pp_elem) l;
+ if false then Format.eprintf "Before simplify: %a@." (pp_guard_list pp_elem) l;
let l = simplify_neg_guard l in
if false then (
- Format.eprintf "After simplify: %a@." (pp_guard_list pp_elem) l;
- Format.eprintf "@[<v 2>Z3 check sat: [%a]@ " (pp_guard_list pp_elem)l;
- );
-
+ Format.eprintf "After simplify: %a@." (pp_guard_list pp_elem) l;
+ Format.eprintf "@[<v 2>Z3 check sat: [%a]@ " (pp_guard_list pp_elem) l);
+
let solver = Z3.Solver.mk_simple_solver !ctx in
- try (
+ try
let zl =
- List.map (fun (e, posneg) ->
+ List.map
+ (fun (e, posneg) ->
let ze =
- match e with
- | IsInit -> is_init_z3e
- | Expr e -> expr_to_z3_expr e
+ match e with IsInit -> is_init_z3e | Expr e -> expr_to_z3_expr e
in
- if posneg then
- ze
- else
- neg_ze ze
- ) l
+ if posneg then ze else neg_ze ze)
+ l
in
- if false then Format.eprintf "Z3 exprs1: [%a]@ " (fprintf_list ~sep:",@ " (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e))) zl;
+ if false then
+ Format.eprintf "Z3 exprs1: [%a]@ "
+ (fprintf_list ~sep:",@ " (fun fmt e ->
+ Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
+ zl;
let zl = simplify zl in
- if false then Format.eprintf "Z3 exprs2: [%a]@ " (fprintf_list ~sep:",@ " (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e))) zl;
+ if false then
+ Format.eprintf "Z3 exprs2: [%a]@ "
+ (fprintf_list ~sep:",@ " (fun fmt e ->
+ Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
+ zl;
(* Format.eprintf "Calling Z3@."; *)
let status_res = Z3.Solver.check solver zl in
(* Format.eprintf "Z3 done@."; *)
- if false then Format.eprintf "Z3 status: %s@ @]@. " (Z3.Solver.string_of_status status_res);
+ if false then
+ Format.eprintf "Z3 status: %s@ @]@. "
+ (Z3.Solver.string_of_status status_res);
match status_res with
- | Z3.Solver.UNSATISFIABLE -> false, []
- | _ -> (
- if false && just_check then
- true, l
+ | Z3.Solver.UNSATISFIABLE ->
+ false, []
+ | _ ->
+ if false && just_check then true, l
else
(* TODO: may be reactivate but it may create new expressions *)
(* let l = goal_simplify zl in *)
- let l = List.fold_left
- (fun accu ze -> accu @ (zexpr_to_guard_list ze))
- []
- zl
+ let l =
+ List.fold_left (fun accu ze -> accu @ zexpr_to_guard_list ze) [] zl
in
- (* Format.eprintf "@.@[<v 2>Check_Sat:@ before: %a@ after:
- %a@. Goal precise? %b/%b@]@.@. " * pp_guard_list l
- pp_guard_list l' * (Z3.Goal.is_precise goal) *
- (Z3.Goal.is_precise goal'); *)
-
+ (* Format.eprintf "@.@[<v 2>Check_Sat:@ before: %a@ after: %a@. Goal
+ precise? %b/%b@]@.@. " * pp_guard_list l pp_guard_list l' *
+ (Z3.Goal.is_precise goal) * (Z3.Goal.is_precise goal'); *)
true, l
-
-
- )
-
- )
- with Zustre_common.UnknownFunction(_, msg) -> (
+ with Zustre_common.UnknownFunction (_, msg) ->
report ~level:1 msg;
- true, l (* keeping everything. *)
- )
-
-
-
+ true, l
+(* keeping everything. *)
(**************************************************************)
-
let clean_sys sys =
- List.fold_left (fun accu (guards, updates) ->
- let sat, guards' = check_sat (List.map (fun (g, pn) -> Expr g, pn) guards) in
- (*Format.eprintf "Guard: %a@.Guard cleaned: %a@.Sat? %b@."
- (fprintf_list ~sep:"@ " (pp_guard_expr Printers.pp_expr)) guards
- (fprintf_list ~sep:"@ " (pp_guard_expr Printers.pp_expr)) guards'
- sat
-
- ;*)
- if sat then
- (List.map (fun (e, b) -> (deelem e, b)) guards', updates)::accu
- else
- accu
- )
+ List.fold_left
+ (fun accu (guards, updates) ->
+ let sat, guards' =
+ check_sat (List.map (fun (g, pn) -> Expr g, pn) guards)
+ in
+ (*Format.eprintf "Guard: %a@.Guard cleaned: %a@.Sat? %b@." (fprintf_list
+ ~sep:"@ " (pp_guard_expr Printers.pp_expr)) guards (fprintf_list ~sep:"@
+ " (pp_guard_expr Printers.pp_expr)) guards' sat
+
+ ;*)
+ if sat then
+ (List.map (fun (e, b) -> deelem e, b) guards', updates) :: accu
+ else accu)
[] sys
-(* Most costly function: has the be efficiently implemented. All
- registered guards are initially produced by the call to
- combine_guards. We csan normalize the guards to ease the
- comparisons.
-
- We assume that gl1 and gl2 are already both satisfiable and in a
- kind of reduced form. Let lshort and llong be the short and long
- list of gl1, gl2. We check whether each element elong of llong is
- satisfiable with lshort. If no, stop. If yes, we search to reduce
- the list. If elong => eshort_i, we can remove eshort_i from
- lshort. we can continue with this lshort shortened, lshort'; it is
- not necessary to add yet elong in lshort' since we already know
- rthat elong is somehow reduced with respect to other elements of
- llong. If eshort_i => elong, then we keep ehosrt_i in lshort and do
- not store elong.
-
- After iterating through llong, we have a shortened version of
- lshort + some elements of llong that have to be remembered. We add
- them to this new consolidated list.
-
- *)
-
-(* combine_guards ~fresh:Some(e,b) gl1 gl2 returns ok, gl with ok=true
- when (e=b) ang gl1 and gl2 is satisfiable and gl is a consilidated
- version of it. *)
-let combine_guards ?(fresh=None) gl1 gl2 =
- (* Filtering out trivial cases. More semantics ones would have to be
- addressed later *)
- let check_sat e = (* temp function before we clean the original one *)
+(* Most costly function: has the be efficiently implemented. All registered
+ guards are initially produced by the call to combine_guards. We csan
+ normalize the guards to ease the comparisons.
+
+ We assume that gl1 and gl2 are already both satisfiable and in a kind of
+ reduced form. Let lshort and llong be the short and long list of gl1, gl2. We
+ check whether each element elong of llong is satisfiable with lshort. If no,
+ stop. If yes, we search to reduce the list. If elong => eshort_i, we can
+ remove eshort_i from lshort. we can continue with this lshort shortened,
+ lshort'; it is not necessary to add yet elong in lshort' since we already
+ know rthat elong is somehow reduced with respect to other elements of llong.
+ If eshort_i => elong, then we keep ehosrt_i in lshort and do not store elong.
+
+ After iterating through llong, we have a shortened version of lshort + some
+ elements of llong that have to be remembered. We add them to this new
+ consolidated list. *)
+
+(* combine_guards ~fresh:Some(e,b) gl1 gl2 returns ok, gl with ok=true when
+ (e=b) ang gl1 and gl2 is satisfiable and gl is a consilidated version of it. *)
+let combine_guards ?(fresh = None) gl1 gl2 =
+ (* Filtering out trivial cases. More semantics ones would have to be addressed
+ later *)
+ let check_sat e =
+ (* temp function before we clean the original one *)
(* Format.eprintf "CheckSAT? %a@." (pp_guard_list pp_elem) e; *)
let ok, _ = check_sat e in
(* Format.eprintf "CheckSAT DONE@."; *)
ok
in
- let implies (e1,pn1) (e2,pn2) =
+ let implies (e1, pn1) (e2, pn2) =
let e2z e pn =
match e with
- | IsInit -> if pn then is_init_z3e else neg_ze is_init_z3e
- | Expr e -> expr_to_z3_expr (if pn then e else (Corelang.push_negations ~neg:true e))
- in
+ | IsInit ->
+ if pn then is_init_z3e else neg_ze is_init_z3e
+ | Expr e ->
+ expr_to_z3_expr (if pn then e else Corelang.push_negations ~neg:true e)
+ in
implies (e2z e1 pn1) (e2z e2 pn2)
in
let lshort, llong =
if List.length gl1 > List.length gl2 then gl2, gl1 else gl1, gl2
in
let merge long short =
- let short, long_sel, ok =
- List.fold_left (fun (short,long_sel, ok) long_e ->
- if not ok then
- [],[], false (* Propagating unsat case *)
- else if check_sat (long_e::short) then
- let short, keep_long_e =
- List.fold_left (fun (accu_short, keep_long_e) eshort_i ->
- if not keep_long_e then (* shorten the algo *)
- eshort_i :: accu_short, false
- else (* keep_long_e = true in the following *)
- if implies eshort_i long_e then
+ let short, long_sel, ok =
+ List.fold_left
+ (fun (short, long_sel, ok) long_e ->
+ if not ok then [], [], false (* Propagating unsat case *)
+ else if check_sat (long_e :: short) then
+ let short, keep_long_e =
+ List.fold_left
+ (fun (accu_short, keep_long_e) eshort_i ->
+ if not keep_long_e then
+ (* shorten the algo *)
+ eshort_i :: accu_short, false
+ else if
+ (* keep_long_e = true in the following *)
+ implies eshort_i long_e
+ then
(* First case is trying to remove long_e!
- Since short is already normalized, we can remove
- long_e. If later long_e is stronger than another
- element of short, then necessarily eshort_i =>
- long_e ->
- that_other_element_of_short. Contradiction. *)
- eshort_i::accu_short, false
- else if implies long_e eshort_i then
+ Since short is already normalized, we can remove long_e.
+ If later long_e is stronger than another element of
+ short, then necessarily eshort_i => long_e ->
+ that_other_element_of_short. Contradiction. *)
+ eshort_i :: accu_short, false
+ else if implies long_e eshort_i then
(* removing eshort_i, keeping long_e. *)
accu_short, true
- else (* Not comparable, keeping both *)
- eshort_i::accu_short, true
- )
- ([],true) (* Initially we assume that we will keep long_e *)
- short
- in
- if keep_long_e then
- short, long_e::long_sel, true
- else
- short, long_sel, true
- else
- [],[],false
- ) (short, [], true) long
+ else
+ (* Not comparable, keeping both *)
+ eshort_i :: accu_short, true)
+ ([], true)
+ (* Initially we assume that we will keep long_e *)
+ short
+ in
+ if keep_long_e then short, long_e :: long_sel, true
+ else short, long_sel, true
+ else [], [], false)
+ (short, [], true) long
in
- ok, long_sel@short
+ ok, long_sel @ short
in
- let ok, l = match fresh with
- | None -> true, []
- | Some g -> merge [g] []
- in
- if not ok then
- false, []
+ let ok, l = match fresh with None -> true, [] | Some g -> merge [ g ] [] in
+ if not ok then false, []
else
let ok, lshort = merge lshort l in
- if not ok then
- false, []
- else
- merge llong lshort
-
-
-(* Encode "If gel1=posneg then gel2":
- - Compute the combination of guarded exprs in gel1 and gel2:
- - Each guarded_expr in gel1 is transformed as a guard: the
- expression is associated to posneg.
- - Existing guards in gel2 are concatenated to that list of guards
- - We keep expr in the ge of gel2 as the legitimate expression
- *)
+ if not ok then false, [] else merge llong lshort
+
+(* Encode "If gel1=posneg then gel2": - Compute the combination of guarded exprs
+ in gel1 and gel2: - Each guarded_expr in gel1 is transformed as a guard: the
+ expression is associated to posneg. - Existing guards in gel2 are
+ concatenated to that list of guards - We keep expr in the ge of gel2 as the
+ legitimate expression *)
let concatenate_ge gel1 posneg gel2 =
let l, all_invalid =
- List.fold_left (
- fun (accu, all_invalid) (g2,e2) ->
- List.fold_left (
- fun (accu, all_invalid) (g1,e1) ->
- (* Format.eprintf "@[<v 2>Combining guards: (%a=%b) AND [%a] AND [%a]@ "
- * pp_elem e1
- * posneg
- * pp_guard_list g1
- * pp_guard_list g2; *)
-
- let ok, gl = combine_guards ~fresh:(Some(e1,posneg)) g1 g2 in
- (* Format.eprintf "@]@ Result is [%a]@ "
- * pp_guard_list gl; *)
-
- if ok then
- (gl, e2)::accu, false
- else (
- accu, all_invalid
- )
- ) (accu, all_invalid) gel1
- ) ([], true) gel2
+ List.fold_left
+ (fun (accu, all_invalid) (g2, e2) ->
+ List.fold_left
+ (fun (accu, all_invalid) (g1, e1) ->
+ (* Format.eprintf "@[<v 2>Combining guards: (%a=%b) AND [%a] AND
+ [%a]@ " * pp_elem e1 * posneg * pp_guard_list g1 * pp_guard_list
+ g2; *)
+ let ok, gl = combine_guards ~fresh:(Some (e1, posneg)) g1 g2 in
+
+ (* Format.eprintf "@]@ Result is [%a]@ " * pp_guard_list gl; *)
+ if ok then (gl, e2) :: accu, false else accu, all_invalid)
+ (accu, all_invalid) gel1)
+ ([], true) gel2
in
not all_invalid, l
-(* Transform the guard expressions ge = [gl1, e1; gl2, e2;...] as
- [gl1, e1=id; gl2, e2=id; ...] *)
+(* Transform the guard expressions ge = [gl1, e1; gl2, e2;...] as [gl1, e1=id;
+ gl2, e2=id; ...] *)
let mk_ge_eq_id ge id =
List.map
(fun (gl, g_e) ->
- gl,
- if id = "true" then
- g_e
- else
- match g_e with
- | Expr g_e ->
- if id = "false" then
- Expr (Corelang.push_negations ~neg:true g_e)
- else
- let loc = g_e.expr_loc in
- Expr(Corelang.mk_eq loc
- g_e
- (Corelang.expr_of_ident id loc))
- | _ -> assert false
- ) ge
-
- (* Rewrite the expression expr, replacing any occurence of a variable
- by its definition.
- *)
-let rec rewrite defs expr : elem_guarded_expr list =
+ ( gl,
+ if id = "true" then g_e
+ else
+ match g_e with
+ | Expr g_e ->
+ if id = "false" then Expr (Corelang.push_negations ~neg:true g_e)
+ else
+ let loc = g_e.expr_loc in
+ Expr (Corelang.mk_eq loc g_e (Corelang.expr_of_ident id loc))
+ | _ ->
+ assert false ))
+ ge
+
+(* Rewrite the expression expr, replacing any occurence of a variable by its
+ definition. *)
+let rec rewrite defs expr : elem_guarded_expr list =
let rewrite = rewrite defs in
let res =
match expr.expr_desc with
| Expr_appl (id, args, None) ->
- let args = rewrite args in
- List.map (fun (guards, e) ->
- let new_e =
- Corelang.mkexpr
- expr.expr_loc
- (Expr_appl(id, deelem e, None))
- in
- let new_e = { new_e with expr_type = expr.expr_type; expr_clock = expr.expr_clock } in
- guards,
- Expr (Corelang.partial_eval new_e)
- ) args
- | Expr_const _ -> [[], Expr expr]
+ let args = rewrite args in
+ List.map
+ (fun (guards, e) ->
+ let new_e =
+ Corelang.mkexpr expr.expr_loc (Expr_appl (id, deelem e, None))
+ in
+ let new_e =
+ {
+ new_e with
+ expr_type = expr.expr_type;
+ expr_clock = expr.expr_clock;
+ }
+ in
+ guards, Expr (Corelang.partial_eval new_e))
+ args
+ | Expr_const _ ->
+ [ [], Expr expr ]
| Expr_ident id ->
- if Hashtbl.mem defs id then
- Hashtbl.find defs id
- else
- (* id should be an input *)
- [[], Expr expr]
+ if Hashtbl.mem defs id then Hashtbl.find defs id
+ else (* id should be an input *)
+ [ [], Expr expr ]
| Expr_ite (g, e1, e2) ->
- let g = rewrite g and
- e1 = rewrite e1 and
- e2 = rewrite e2 in
- let ok_then, g_then = concatenate_ge g true e1 in
- let ok_else, g_else = concatenate_ge g false e2 in
- (if ok_then then g_then else [])@
- (if ok_else then g_else else [])
+ let g = rewrite g and e1 = rewrite e1 and e2 = rewrite e2 in
+ let ok_then, g_then = concatenate_ge g true e1 in
+ let ok_else, g_else = concatenate_ge g false e2 in
+ (if ok_then then g_then else []) @ if ok_else then g_else else []
| Expr_merge (g_id, branches) ->
- if Hashtbl.mem defs g_id then
- let g = Hashtbl.find defs g_id in
- (* Format.eprintf "Expr_merge %s = %a@." g_id (pp_mdefs pp_elem) g ; *)
- List.fold_left (fun accu (id, e) ->
- let g = mk_ge_eq_id g id in
- let e = rewrite e in
- let ok, g_eq_id = concatenate_ge g true e in
- if ok then g_eq_id@accu else accu
- ) [] branches
- else
- assert false (* g should be defined already *)
+ if Hashtbl.mem defs g_id then
+ let g = Hashtbl.find defs g_id in
+ (* Format.eprintf "Expr_merge %s = %a@." g_id (pp_mdefs pp_elem) g ; *)
+ List.fold_left
+ (fun accu (id, e) ->
+ let g = mk_ge_eq_id g id in
+ let e = rewrite e in
+ let ok, g_eq_id = concatenate_ge g true e in
+ if ok then g_eq_id @ accu else accu)
+ [] branches
+ else assert false (* g should be defined already *)
| Expr_when (e, id, l) ->
- let e = rewrite e in
- let id_def = Hashtbl.find defs id in
- let clock = mk_ge_eq_id id_def l in
- let ok, new_ge = concatenate_ge clock true e in
- if ok then new_ge else []
- | Expr_arrow _ -> [[], IsInit] (* At this point the only arrow should be true -> false *)
+ let e = rewrite e in
+ let id_def = Hashtbl.find defs id in
+ let clock = mk_ge_eq_id id_def l in
+ let ok, new_ge = concatenate_ge clock true e in
+ if ok then new_ge else []
+ | Expr_arrow _ ->
+ [ [], IsInit ] (* At this point the only arrow should be true -> false *)
| Expr_tuple el ->
- (* Each expr is associated to its flatten guarded expr list *)
- let gell = List.map rewrite el in
- (* Computing all combinations: we obtain a list of guarded tuple *)
- let rec aux gell : (elem_boolexpr guard * expr list) list =
- match gell with
- | [] -> assert false (* Not happening *)
- | [gel] -> List.map (fun (g,e) -> g, [deelem e]) gel
- | gel::getl ->
- let getl = aux getl in
- List.fold_left (
- fun accu (g,e) ->
- List.fold_left (
- fun accu (gl, minituple) ->
- let is_compat, guard_comb = combine_guards g gl in
- if is_compat then
- let new_gt : elem_boolexpr guard * expr list =
- (guard_comb, (deelem e)::minituple) in
- new_gt::accu
- else
- accu
-
- ) accu getl
- ) [] gel
- in
- let gtuples = aux gell in
- (* Rebuilding the valid type: guarded expr list (with tuple exprs) *)
- List.map
- (fun (g,tuple) -> g, Expr (Corelang.mkexpr expr.expr_loc (Expr_tuple tuple)))
- gtuples
+ (* Each expr is associated to its flatten guarded expr list *)
+ let gell = List.map rewrite el in
+ (* Computing all combinations: we obtain a list of guarded tuple *)
+ let rec aux gell : (elem_boolexpr guard * expr list) list =
+ match gell with
+ | [] ->
+ assert false (* Not happening *)
+ | [ gel ] ->
+ List.map (fun (g, e) -> g, [ deelem e ]) gel
+ | gel :: getl ->
+ let getl = aux getl in
+ List.fold_left
+ (fun accu (g, e) ->
+ List.fold_left
+ (fun accu (gl, minituple) ->
+ let is_compat, guard_comb = combine_guards g gl in
+ if is_compat then
+ let new_gt : elem_boolexpr guard * expr list =
+ guard_comb, deelem e :: minituple
+ in
+ new_gt :: accu
+ else accu)
+ accu getl)
+ [] gel
+ in
+ let gtuples = aux gell in
+ (* Rebuilding the valid type: guarded expr list (with tuple exprs) *)
+ List.map
+ (fun (g, tuple) ->
+ g, Expr (Corelang.mkexpr expr.expr_loc (Expr_tuple tuple)))
+ gtuples
| Expr_fby _
- | Expr_appl _
- (* Should be removed by normalization and inlining *)
- -> Format.eprintf "Pb expr: %a@.@?" Printers.pp_expr expr; assert false
- | Expr_array _ | Expr_access _ | Expr_power _
- (* Arrays not handled here yet *)
- -> assert false
- | Expr_pre _ -> (* Not rewriting mem assign *)
- assert false
+ | Expr_appl _ (* Should be removed by normalization and inlining *) ->
+ Format.eprintf "Pb expr: %a@.@?" Printers.pp_expr expr;
+ assert false
+ | Expr_array _
+ | Expr_access _
+ | Expr_power _ (* Arrays not handled here yet *) ->
+ assert false
+ | Expr_pre _ ->
+ (* Not rewriting mem assign *)
+ assert false
in
(* Format.eprintf "Rewriting %a as [@[<v 0>%a@]]@ "
* Printers.pp_expr expr
* (Utils.fprintf_list ~sep:"@ "
* (pp_guard_expr pp_elem)) res; *)
res
-
+
and add_def defs vid expr =
(* Format.eprintf "Add_def: %s = %a@."
* vid
@@ -697,409 +672,380 @@ and add_def defs vid expr =
(* Format.eprintf "-> @[<v 0>%a@]@."
* (Utils.fprintf_list ~sep:"@ "
* (pp_guard_expr pp_elem)) vid_defs; *)
- report ~level:6 (fun fmt -> Format.fprintf fmt "Add_def: %s = %a@. -> @[<v 0>%a@]@."
- vid
- Printers.pp_expr expr
-
- (
- (Utils.fprintf_list ~sep:"@ "
- (pp_guard_expr pp_elem))) vid_defs);
+ report ~level:6 (fun fmt ->
+ Format.fprintf fmt "Add_def: %s = %a@. -> @[<v 0>%a@]@." vid
+ Printers.pp_expr expr
+ (Utils.fprintf_list ~sep:"@ " (pp_guard_expr pp_elem))
+ vid_defs);
Hashtbl.add defs vid vid_defs;
vid_defs
-(* Takes a list of guarded exprs (ge) and a guard
-returns the same list of ge splited into the ones where the guard is true and the ones where it is false. In both lists the associated ge do not mention that guard anymore.
+(* Takes a list of guarded exprs (ge) and a guard returns the same list of ge
+ splited into the ones where the guard is true and the ones where it is false.
+ In both lists the associated ge do not mention that guard anymore.
-When a given ge doesn't mention positively or negatively such guards, it is duplicated in both lists *)
-let split_mdefs elem (mdefs: elem_guarded_expr list) =
- List.fold_left (
- fun (selected, left_out)
- ((guards, expr) as ge) ->
+ When a given ge doesn't mention positively or negatively such guards, it is
+ duplicated in both lists *)
+let split_mdefs elem (mdefs : elem_guarded_expr list) =
+ List.fold_left
+ (fun (selected, left_out) ((guards, expr) as ge) ->
(* select the element of guards that match the argument elem *)
let sel, others_guards = List.partition (select_elem elem) guards in
match sel with
- (* we extract the element from the list and add it to the
- appropriate list *)
- | [_, sel_status] ->
- if sel_status then
- (others_guards,expr)::selected, left_out
- else selected, (others_guards,expr)::left_out
- | [] -> (* no such guard exists, we have to duplicate the
- guard_expr in both lists *)
- ge::selected, ge::left_out
- | _ -> (
- Format.eprintf "@.Spliting list on elem %a.@.List:%a@."
- pp_elem elem
+ (* we extract the element from the list and add it to the appropriate list *)
+ | [ (_, sel_status) ] ->
+ if sel_status then (others_guards, expr) :: selected, left_out
+ else selected, (others_guards, expr) :: left_out
+ | [] ->
+ (* no such guard exists, we have to duplicate the guard_expr in both
+ lists *)
+ ge :: selected, ge :: left_out
+ | _ ->
+ Format.eprintf "@.Spliting list on elem %a.@.List:%a@." pp_elem elem
(pp_mdefs pp_elem) mdefs;
- assert false (* more then one element selected. Should
- not happen , or trival dead code like if
- x then if not x then dead code *)
- )
- ) ([],[]) mdefs
-
-let split_mem_defs
- (elem: element)
- (mem_defs: (ident * elem_guarded_expr list) list)
- :
- ((ident * elem_guarded_expr mdef_t) list) * ((ident * elem_guarded_expr mdef_t) list)
-
- =
- List.fold_right (fun (m,mdefs)
- (accu_pos, accu_neg) ->
- let pos, neg =
- split_mdefs elem mdefs
- in
- (m, pos)::accu_pos,
- (m, neg)::accu_neg
- ) mem_defs ([],[])
-
-
-(* Split a list of mem_defs into init and step lists of guarded
- expressions per memory. *)
-let split_init mem_defs =
- split_mem_defs IsInit mem_defs
-
-(* Previous version of the function: way too costly
-let pick_guard mem_defs : expr option =
- let gel = List.flatten (List.map snd mem_defs) in
- let gl = List.flatten (List.map fst gel) in
- let all_guards =
- List.map (
- (* selecting guards and getting rid of boolean *)
- fun (e,b) ->
- match e with
- | Expr e -> e
- | _ -> assert false
- (* should have been filtered out
- yet *)
- ) gl
- in
- (* TODO , one could sort by occurence and provided the most common
- one *)
- try
- Some (List.hd all_guards)
- with _ -> None
- *)
+ assert false
+ (* more then one element selected. Should not happen , or trival dead code
+ like if x then if not x then dead code *))
+ ([], []) mdefs
+
+let split_mem_defs (elem : element)
+ (mem_defs : (ident * elem_guarded_expr list) list) :
+ (ident * elem_guarded_expr mdef_t) list
+ * (ident * elem_guarded_expr mdef_t) list =
+ List.fold_right
+ (fun (m, mdefs) (accu_pos, accu_neg) ->
+ let pos, neg = split_mdefs elem mdefs in
+ (m, pos) :: accu_pos, (m, neg) :: accu_neg)
+ mem_defs ([], [])
+
+(* Split a list of mem_defs into init and step lists of guarded expressions per
+ memory. *)
+let split_init mem_defs = split_mem_defs IsInit mem_defs
+
+(* Previous version of the function: way too costly let pick_guard mem_defs :
+ expr option = let gel = List.flatten (List.map snd mem_defs) in let gl =
+ List.flatten (List.map fst gel) in let all_guards = List.map ( (* selecting
+ guards and getting rid of boolean *) fun (e,b) -> match e with | Expr e -> e
+ | _ -> assert false (* should have been filtered out yet *) ) gl in (* TODO ,
+ one could sort by occurence and provided the most common one *) try Some
+ (List.hd all_guards) with _ -> None *)
(* Returning the first non empty guard expression *)
let rec pick_guard mem_defs : expr option =
match mem_defs with
- | [] -> None
- | (_, gel)::tl -> (
+ | [] ->
+ None
+ | (_, gel) :: tl ->
let found =
- List.fold_left (fun found (g,_) ->
+ List.fold_left
+ (fun found (g, _) ->
if found = None then
match g with
- | [] -> None
- | (Expr e, _)::_ -> Some e
- | (IsInit, _)::_ -> assert false (* should be removed already *)
- else
- found
- ) None gel
+ | [] ->
+ None
+ | (Expr e, _) :: _ ->
+ Some e
+ | (IsInit, _) :: _ ->
+ assert false (* should be removed already *)
+ else found)
+ None gel
in
if found = None then pick_guard tl else found
- )
-
-(* Transform a list of variable * guarded exprs into a list of guarded pairs (variable, expressions)
-*)
+(* Transform a list of variable * guarded exprs into a list of guarded pairs
+ (variable, expressions) *)
let rec build_switch_sys
- (mem_defs : (Utils.ident * elem_guarded_expr list) list )
- prefix
- :
- ((expr * bool) list * (ident * expr) list ) list =
+ (mem_defs : (Utils.ident * elem_guarded_expr list) list) prefix :
+ ((expr * bool) list * (ident * expr) list) list =
if !seal_debug then
- report ~level:4 (fun fmt -> Format.fprintf fmt "@[<v 2>Build_switch with@ %a@]@."
- pp_all_defs
- mem_defs);
- (* if all mem_defs have empty guards, we are done, return prefix,
- mem_defs expr.
-
- otherwise pick a guard in one of the mem, eg (g, b) then for each
- other mem, one need to select the same guard g with the same
- status b, *)
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "@[<v 2>Build_switch with@ %a@]@." pp_all_defs
+ mem_defs);
+ (* if all mem_defs have empty guards, we are done, return prefix, mem_defs
+ expr.
+
+ otherwise pick a guard in one of the mem, eg (g, b) then for each other
+ mem, one need to select the same guard g with the same status b, *)
let res =
- if List.for_all (fun (_, mdefs) ->
- (* All defs are unguarded *)
- match mdefs with
- | [[], _] -> true (* Regular unguarded expression *)
- | [] -> true (* A unbalanced definition of the memory. Here
- we have m_{k+1} -> m_k *)
- | _ -> false
- ) mem_defs
- then
- [prefix ,
- List.map (fun (m,gel) ->
- match gel with
- | [_,e] ->
- let e =
- match e with
- | Expr e -> e
- | _ -> assert false (* No IsInit expression *)
- in
- m,e
- | [] -> m, Corelang.expr_of_ident m Location.dummy_loc
- | _ -> assert false
- ) mem_defs]
- else
- (* Picking a guard *)
- let elem_opt : expr option = pick_guard mem_defs in
- match elem_opt with
- None -> (
- Format.eprintf "Issues picking guard in mem_defs: %a@." pp_all_defs mem_defs;
- assert false (* Otherwise the first case should have matched *)
- )
- | Some elem -> (
- report ~level:4 (fun fmt -> Format.fprintf fmt "selecting guard %a@." Printers.pp_expr elem);
- let pos, neg =
- split_mem_defs
- (Expr elem)
- mem_defs
- in
- report ~level:4 (fun fmt -> Format.fprintf fmt "split by guard done@.");
-
- (* Format.eprintf "Selected item %a in@.%a@.POS=%a@.NEG=%a@."
- Printers.pp_expr elem
- pp_all_defs mem_defs
- pp_all_defs pos
- pp_all_defs neg
- ;
- *)
- (* Special cases to avoid useless computations: true, false conditions *)
- match elem.expr_desc with
- (*| Expr_ident "true" -> build_switch_sys pos prefix *)
- | Expr_const (Const_tag tag) when tag = tag_true
- -> build_switch_sys pos prefix
- (*| Expr_ident "false" -> build_switch_sys neg prefix *)
- | Expr_const (Const_tag tag) when tag = tag_false
- -> build_switch_sys neg prefix
- | _ -> (* Regular case *)
- report ~level:4 (fun fmt -> Format.fprintf fmt "Building both children branches@.");
- (* let _ = (
- * Format.eprintf "Expr is %a@." Printers.pp_expr elem;
- * match elem.expr_desc with
- * | Expr_const _ -> Format.eprintf "a const@."
- *
- * | Expr_ident _ -> Format.eprintf "an ident@."
- * | _ -> Format.eprintf "something else@."
- * )
- * in *)
- let clean l =
- let l = List.map (fun (e,b) -> (Expr e), b) l in
- report ~level:4 (fun fmt -> Format.fprintf fmt "Checking satisfiability of %a@."
- (pp_guard_list pp_elem) l
- );
- let ok, l = check_sat l in
- let l = List.map (fun (e,b) -> deelem e, b) l in
- ok, l
- in
- let pos_prefix = (elem, true)::prefix in
- let neg_prefix = (elem, false)::prefix in
- report ~level:4 (fun fmt -> Format.fprintf fmt "Cleaning branches ...@.");
- let ok_pos, pos_prefix = clean pos_prefix in
- report ~level:4 (fun fmt -> Format.fprintf fmt "Cleaning branche pos done@.");
- let ok_neg, neg_prefix = clean neg_prefix in
- report ~level:4 (fun fmt -> Format.fprintf fmt "Cleaning branche neg done@.");
- report ~level:4 (fun fmt -> Format.fprintf fmt "Cleaning branches done@.");
- report ~level:4 (fun fmt -> Format.fprintf fmt "Enforcing %a@." Printers.pp_expr elem);
- let ok_l = if ok_pos then build_switch_sys pos pos_prefix else [] in
- report ~level:4 (fun fmt -> Format.fprintf fmt "Enforcing not(%a)@." Printers.pp_expr elem);
- let nok_l = if ok_neg then build_switch_sys neg neg_prefix else [] in
- ok_l @ nok_l
- )
+ if
+ List.for_all
+ (fun (_, mdefs) ->
+ (* All defs are unguarded *)
+ match mdefs with
+ | [ ([], _) ] ->
+ true (* Regular unguarded expression *)
+ | [] ->
+ true
+ (* A unbalanced definition of the memory. Here we have m_{k+1} -> m_k *)
+ | _ ->
+ false)
+ mem_defs
+ then
+ [
+ ( prefix,
+ List.map
+ (fun (m, gel) ->
+ match gel with
+ | [ (_, e) ] ->
+ let e =
+ match e with Expr e -> e | _ -> assert false
+ (* No IsInit expression *)
+ in
+ m, e
+ | [] ->
+ m, Corelang.expr_of_ident m Location.dummy_loc
+ | _ ->
+ assert false)
+ mem_defs );
+ ]
+ else
+ (* Picking a guard *)
+ let elem_opt : expr option = pick_guard mem_defs in
+ match elem_opt with
+ | None ->
+ Format.eprintf "Issues picking guard in mem_defs: %a@." pp_all_defs
+ mem_defs;
+ assert false (* Otherwise the first case should have matched *)
+ | Some elem -> (
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "selecting guard %a@." Printers.pp_expr elem);
+ let pos, neg = split_mem_defs (Expr elem) mem_defs in
+ report ~level:4 (fun fmt -> Format.fprintf fmt "split by guard done@.");
+
+ (* Format.eprintf "Selected item %a in@.%a@.POS=%a@.NEG=%a@."
+ Printers.pp_expr elem pp_all_defs mem_defs pp_all_defs pos
+ pp_all_defs neg ; *)
+ (* Special cases to avoid useless computations: true, false conditions *)
+ match elem.expr_desc with
+ (*| Expr_ident "true" -> build_switch_sys pos prefix *)
+ | Expr_const (Const_tag tag) when tag = tag_true ->
+ build_switch_sys pos prefix
+ (*| Expr_ident "false" -> build_switch_sys neg prefix *)
+ | Expr_const (Const_tag tag) when tag = tag_false ->
+ build_switch_sys neg prefix
+ | _ ->
+ (* Regular case *)
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "Building both children branches@.");
+ (* let _ = ( * Format.eprintf "Expr is %a@." Printers.pp_expr elem; *
+ match elem.expr_desc with * | Expr_const _ -> Format.eprintf "a
+ const@." * * | Expr_ident _ -> Format.eprintf "an ident@." * | _ ->
+ Format.eprintf "something else@." * ) * in *)
+ let clean l =
+ let l = List.map (fun (e, b) -> Expr e, b) l in
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "Checking satisfiability of %a@."
+ (pp_guard_list pp_elem) l);
+ let ok, l = check_sat l in
+ let l = List.map (fun (e, b) -> deelem e, b) l in
+ ok, l
+ in
+ let pos_prefix = (elem, true) :: prefix in
+ let neg_prefix = (elem, false) :: prefix in
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "Cleaning branches ...@.");
+ let ok_pos, pos_prefix = clean pos_prefix in
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "Cleaning branche pos done@.");
+ let ok_neg, neg_prefix = clean neg_prefix in
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "Cleaning branche neg done@.");
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "Cleaning branches done@.");
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "Enforcing %a@." Printers.pp_expr elem);
+ let ok_l = if ok_pos then build_switch_sys pos pos_prefix else [] in
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "Enforcing not(%a)@." Printers.pp_expr elem);
+ let nok_l = if ok_neg then build_switch_sys neg neg_prefix else [] in
+ ok_l @ nok_l)
in
- if !seal_debug then (
- report ~level:4 (fun fmt ->
- Format.fprintf fmt
- "@[<v 2>===> @[%t@ @]@]@ @]@ "
- (fun fmt -> List.iter (fun (gl,up) ->
- Format.fprintf fmt "[@[%a@]] -> (%a)@ "
- (pp_guard_list Printers.pp_expr) gl (pp_up Printers.pp_expr) up) res);
-
- ));
- res
-
-
-let build_environement consts (mems:var_decl list) nd =
-
+ if !seal_debug then
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "@[<v 2>===> @[%t@ @]@]@ @]@ " (fun fmt ->
+ List.iter
+ (fun (gl, up) ->
+ Format.fprintf fmt "[@[%a@]] -> (%a)@ "
+ (pp_guard_list Printers.pp_expr)
+ gl (pp_up Printers.pp_expr) up)
+ res));
+ res
+
+let build_environement consts (mems : var_decl list) nd =
Z3.Params.update_param_value !ctx "timeout" "10000";
-
- (* rescheduling node: has been scheduled already, no need to protect
- the call to schedule_node *)
+ (* rescheduling node: has been scheduled already, no need to protect the call
+ to schedule_node *)
let nd_report = Scheduling.schedule_node nd in
let schedule = nd_report.Scheduling_type.schedule in
let eqs, auts = Corelang.get_node_eqs nd in
- assert (auts = []); (* Automata should be expanded by now *)
- let sorted_eqs, unused = Scheduling.sort_equations_from_schedule eqs schedule in
- let defs : (ident, elem_guarded_expr list) Hashtbl.t = Hashtbl.create 13 in
+ assert (auts = []);
+ (* Automata should be expanded by now *)
+ let sorted_eqs, unused =
+ Scheduling.sort_equations_from_schedule eqs schedule
+ in
+ let defs : (ident, elem_guarded_expr list) Hashtbl.t = Hashtbl.create 13 in
let add_def = add_def defs in
let vars = Corelang.get_node_vars nd in
(* Filtering out unused vars *)
let vars = List.filter (fun v -> not (List.mem v.var_id unused)) vars in
- (* Registering all locals variables as Z3 predicates. Will be use to
- simplify the expansion *)
- Zustre_common.decl_sorts ();
+ (* Registering all locals variables as Z3 predicates. Will be use to simplify
+ the expansion *)
+ Zustre_common.decl_sorts ();
let _ =
- List.iter (fun v ->
- let fdecl = Z3.FuncDecl.mk_func_decl_s
- !ctx
- v.var_id
- []
- (Zustre_common.type_to_sort v.var_type)
+ List.iter
+ (fun v ->
+ let fdecl =
+ Z3.FuncDecl.mk_func_decl_s !ctx v.var_id []
+ (Zustre_common.type_to_sort v.var_type)
in
- ignore (Zustre_common.register_fdecl v.var_id fdecl)
- ) vars
+ ignore (Zustre_common.register_fdecl v.var_id fdecl))
+ vars
in
let _ =
List.iter (fun c -> Hashtbl.add const_defs c.const_id c.const_value) consts
in
- report ~level:4 (fun fmt -> Format.fprintf fmt "Computing definitions for equations@.%a@."
- Printers.pp_node_eqs sorted_eqs
- );
-
-
- (* Registering node equations: identifying mem definitions and
- storing others in the "defs" hashtbl.
-
- Each assign is stored in a hash tbl as list of guarded
- expressions. The memory definition is also "rewritten" as such a
- list of guarded assigns. *)
- report ~level:1 (fun fmt -> Format.fprintf fmt "registering all definitions in guarded form ...@.");
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "Computing definitions for equations@.%a@."
+ Printers.pp_node_eqs sorted_eqs);
+
+ (* Registering node equations: identifying mem definitions and storing others
+ in the "defs" hashtbl.
+
+ Each assign is stored in a hash tbl as list of guarded expressions. The
+ memory definition is also "rewritten" as such a list of guarded assigns. *)
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "registering all definitions in guarded form ...@.");
let mem_defs, output_defs =
- List.fold_left (fun (accu_mems, accu_outputs) eq ->
+ List.fold_left
+ (fun (accu_mems, accu_outputs) eq ->
match eq.eq_lhs with
- | [vid] ->
- (* Only focus on memory definitions *)
- if List.exists (fun v -> v.var_id = vid) mems then
- (
- match eq.eq_rhs.expr_desc with
- | Expr_pre def_m ->
- report ~level:3 (fun fmt ->
- Format.fprintf fmt "Preparing mem %s@." vid);
- let def_vid = rewrite defs def_m in
- report ~level:4 (fun fmt ->
- Format.fprintf fmt "%s = %a@." vid
- (
- (Utils.fprintf_list ~sep:"@ "
- (pp_guard_expr pp_elem)))
- def_vid);
- (vid, def_vid)::accu_mems, accu_outputs
- | _ -> assert false
- )
- else if List.exists (fun v -> v.var_id = vid) nd.node_outputs then (
- report ~level:3 (fun fmt ->
- Format.fprintf fmt "Output variable %s@." vid);
- let def_vid = add_def vid eq.eq_rhs in
- accu_mems, (vid, def_vid)::accu_outputs
-
- )
- else
- (
- report ~level:3 (fun fmt ->
- Format.fprintf fmt "Registering variable %s@." vid);
- let _ = add_def vid eq.eq_rhs in
- accu_mems, accu_outputs
- )
- | _ -> assert false (* should have been removed by normalization *)
- ) ([], []) sorted_eqs
+ | [ vid ] ->
+ (* Only focus on memory definitions *)
+ if List.exists (fun v -> v.var_id = vid) mems then
+ match eq.eq_rhs.expr_desc with
+ | Expr_pre def_m ->
+ report ~level:3 (fun fmt ->
+ Format.fprintf fmt "Preparing mem %s@." vid);
+ let def_vid = rewrite defs def_m in
+ report ~level:4 (fun fmt ->
+ Format.fprintf fmt "%s = %a@." vid
+ (Utils.fprintf_list ~sep:"@ " (pp_guard_expr pp_elem))
+ def_vid);
+ (vid, def_vid) :: accu_mems, accu_outputs
+ | _ ->
+ assert false
+ else if List.exists (fun v -> v.var_id = vid) nd.node_outputs then (
+ report ~level:3 (fun fmt ->
+ Format.fprintf fmt "Output variable %s@." vid);
+ let def_vid = add_def vid eq.eq_rhs in
+ accu_mems, (vid, def_vid) :: accu_outputs)
+ else (
+ report ~level:3 (fun fmt ->
+ Format.fprintf fmt "Registering variable %s@." vid);
+ let _ = add_def vid eq.eq_rhs in
+ accu_mems, accu_outputs)
+ | _ ->
+ assert false
+ (* should have been removed by normalization *))
+ ([], []) sorted_eqs
in
- report ~level:1 (fun fmt -> Format.fprintf fmt "registering all definitions done@.");
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "registering all definitions done@.");
-
- report ~level:2 (fun fmt -> Format.fprintf fmt "Printing out (guarded) memories definitions (may takes time)@.");
- (* Printing memories definitions *)
- report ~level:3
- (fun fmt ->
+ report ~level:2 (fun fmt ->
Format.fprintf fmt
- "@[<v 0>%a@]@."
- (Utils.fprintf_list ~sep:"@ "
- (fun fmt (m,mdefs) ->
- Format.fprintf fmt
- "%s -> [@[<v 0>%a@] ]@ "
- m
- (Utils.fprintf_list ~sep:"@ "
- (pp_guard_expr pp_elem)) mdefs
- ))
+ "Printing out (guarded) memories definitions (may takes time)@.");
+ (* Printing memories definitions *)
+ report ~level:3 (fun fmt ->
+ Format.fprintf fmt "@[<v 0>%a@]@."
+ (Utils.fprintf_list ~sep:"@ " (fun fmt (m, mdefs) ->
+ Format.fprintf fmt "%s -> [@[<v 0>%a@] ]@ " m
+ (Utils.fprintf_list ~sep:"@ " (pp_guard_expr pp_elem))
+ mdefs))
mem_defs);
- mem_defs, output_defs
-
+ mem_defs, output_defs
(* Iter through the elements and gather them by updates *)
let merge_updates sys =
- (* The map will associate to each update up the pair (set, set
- list) where set is the share guards and set list a list of
- disjunctive guards. Each set represents a conjunction of
- expressions. *)
-
+ (* The map will associate to each update up the pair (set, set list) where set
+ is the share guards and set list a list of disjunctive guards. Each set
+ represents a conjunction of expressions. *)
+
(* We perform multiple pass to avoid errors *)
let map =
- List.fold_left (fun map (gl,up) ->
+ List.fold_left
+ (fun map (gl, up) ->
(* creating a new set to describe gl *)
let new_set =
- List.fold_left
- (fun set g -> Guards.add g set)
- Guards.empty
- gl
+ List.fold_left (fun set g -> Guards.add g set) Guards.empty gl
in
(* updating the map with up -> new_set *)
if UpMap.mem up map then
let guard_set = UpMap.find up map in
- UpMap.add up (new_set::guard_set) map
- else
- UpMap.add up [new_set] map
- ) UpMap.empty sys
+ UpMap.add up (new_set :: guard_set) map
+ else UpMap.add up [ new_set ] map)
+ UpMap.empty sys
in
- (* Processing the set of guards leading to the same update: return
- conj, disj with conf is a set of guards, and disj a DNF, ie a
- list of set of guards *)
+ (* Processing the set of guards leading to the same update: return conj, disj
+ with conf is a set of guards, and disj a DNF, ie a list of set of guards *)
let map =
- UpMap.map (
- fun guards ->
+ UpMap.map
+ (fun guards ->
match guards with
- | [] -> Guards.empty, [] (* Nothing *)
- | [s]-> s, [] (* basic case *)
- | hd::tl ->
- let shared = List.fold_left (fun shared s -> Guards.inter shared s) hd tl in
- let remaining = List.map (fun s -> Guards.diff s shared) guards in
- (* If one of them is empty, we can remove the others, otherwise keep them *)
- if List.exists Guards.is_empty remaining then
- shared, []
- else
- shared, remaining
- ) map
+ | [] ->
+ Guards.empty, [] (* Nothing *)
+ | [ s ] ->
+ s, [] (* basic case *)
+ | hd :: tl ->
+ let shared =
+ List.fold_left (fun shared s -> Guards.inter shared s) hd tl
+ in
+ let remaining = List.map (fun s -> Guards.diff s shared) guards in
+ (* If one of them is empty, we can remove the others, otherwise keep
+ them *)
+ if List.exists Guards.is_empty remaining then shared, []
+ else shared, remaining)
+ map
in
- let rec mk_binop op l = match l with
- [] -> assert false
- | [e] -> e
- | hd::tl -> Corelang.mkpredef_call hd.expr_loc op [hd; mk_binop op tl]
+ let rec mk_binop op l =
+ match l with
+ | [] ->
+ assert false
+ | [ e ] ->
+ e
+ | hd :: tl ->
+ Corelang.mkpredef_call hd.expr_loc op [ hd; mk_binop op tl ]
in
let gl_as_expr gl =
let gl = Guards.elements gl in
- let export (e,b) = if b then e else Corelang.push_negations ~neg:true e in
+ let export (e, b) = if b then e else Corelang.push_negations ~neg:true e in
match gl with
- [] -> []
- | [e] -> [export e]
+ | [] ->
+ []
+ | [ e ] ->
+ [ export e ]
| _ ->
- [mk_binop "&&"
- (List.map export gl)]
+ [ mk_binop "&&" (List.map export gl) ]
in
let clean_disj disj =
match disj with
- | [] -> []
- | [_] -> assert false (* A disjunction with a single case can be ignored *)
- | _::_::_ -> (
- (* First basic version: producing a DNF One can later, (1)
- simplify it with z3, or (2) build the compact tree with
- maximum shared subexpression (and simplify it with z3) *)
- let elems = List.fold_left (fun accu gl -> (gl_as_expr gl) @ accu) [] disj in
+ | [] ->
+ []
+ | [ _ ] ->
+ assert false (* A disjunction with a single case can be ignored *)
+ | _ :: _ :: _ ->
+ (* First basic version: producing a DNF One can later, (1) simplify it
+ with z3, or (2) build the compact tree with maximum shared
+ subexpression (and simplify it with z3) *)
+ let elems =
+ List.fold_left (fun accu gl -> gl_as_expr gl @ accu) [] disj
+ in
let or_expr = mk_binop "||" elems in
- [or_expr]
-
-
+ [ or_expr ]
(* TODO disj*)
(* get the item that occurs in most case *)
(* List.fold_left (fun accu s ->
@@ -1107,61 +1053,60 @@ let merge_updates sys =
* if List.mem_assoc (e.expr_tag, b)
* ) accu (Guards.elements s)
* ) [] disj *)
-
- )
in
if !seal_debug then Format.eprintf "Map: %i elements@ " (UpMap.cardinal map);
- UpMap.fold (fun up (common, disj) accu ->
+ UpMap.fold
+ (fun up (common, disj) accu ->
if !seal_debug then
- report ~level:6 (fun fmt -> Format.fprintf fmt
- "Guards:@.shared: [%a]@.disj: [@[<v 0>%a@ ]@]@.Updates: %a@."
- Guards.pp_short common
- (fprintf_list ~sep:";@ " Guards.pp_long) disj
- UpMap.pp up);
+ report ~level:6 (fun fmt ->
+ Format.fprintf fmt
+ "Guards:@.shared: [%a]@.disj: [@[<v 0>%a@ ]@]@.Updates: %a@."
+ Guards.pp_short common
+ (fprintf_list ~sep:";@ " Guards.pp_long)
+ disj UpMap.pp up);
let disj = clean_disj disj in
- let guard_expr = (gl_as_expr common)@disj in
-
- ((match guard_expr with
- | [] -> None
- | _ -> Some (mk_binop "&&" guard_expr)), up)::accu
- ) map []
-
-
-
-
-(* Take a normalized node and extract a list of switches: (cond,
- update) meaning "if cond then update" where update shall define all
- node memories. Everything as to be expressed over inputs or
- memories, intermediate variables are removed through inlining *)
-let node_as_switched_sys consts (mems:var_decl list) nd =
+ let guard_expr = gl_as_expr common @ disj in
+
+ ( (match guard_expr with
+ | [] ->
+ None
+ | _ ->
+ Some (mk_binop "&&" guard_expr)),
+ up )
+ :: accu)
+ map []
+
+(* Take a normalized node and extract a list of switches: (cond, update) meaning
+ "if cond then update" where update shall define all node memories. Everything
+ as to be expressed over inputs or memories, intermediate variables are
+ removed through inlining *)
+let node_as_switched_sys consts (mems : var_decl list) nd =
let mem_defs, output_defs = build_environement consts mems nd in
-
+
let init_defs, update_defs = split_init mem_defs in
- let init_out, update_out = split_init output_defs in
-
- report ~level:3 (fun fmt -> Format.fprintf fmt "@[<v 0>Init:@ %a@ Step:@ %a@]@."
- (pp_assign_map pp_elem) init_defs
- (pp_assign_map pp_elem) update_defs);
-
-
- report ~level:1 (fun fmt -> Format.fprintf fmt
- "init/step as a switched system ...@.");
- let sw_init= build_switch_sys init_defs [] in
- let sw_sys = build_switch_sys update_defs [] in
- report ~level:1 (fun fmt -> Format.fprintf fmt
- "init/step as a switched system ... done@.");
+ let init_out, update_out = split_init output_defs in
+
+ report ~level:3 (fun fmt ->
+ Format.fprintf fmt "@[<v 0>Init:@ %a@ Step:@ %a@]@."
+ (pp_assign_map pp_elem) init_defs (pp_assign_map pp_elem) update_defs);
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "init/step as a switched system ...@.");
+ let sw_init = build_switch_sys init_defs [] in
+ let sw_sys = build_switch_sys update_defs [] in
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "init/step as a switched system ... done@.");
- report ~level:1 (fun fmt -> Format.fprintf fmt
- "output function as a switched system ...@.");
- let init_out = build_switch_sys init_out [] in
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "output function as a switched system ...@.");
+ let init_out = build_switch_sys init_out [] in
let update_out = build_switch_sys update_out [] in
-
- report ~level:1 (fun fmt -> Format.fprintf fmt
- "output function as a switched system ... done@.");
- report ~level:1 (fun fmt -> Format.fprintf fmt
- "removing dead branches and merging remaining ...@.");
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "output function as a switched system ... done@.");
+
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "removing dead branches and merging remaining ...@.");
let sw_init = clean_sys sw_init in
let sw_sys = clean_sys sw_sys in
@@ -1177,108 +1122,62 @@ let node_as_switched_sys consts (mems:var_decl list) nd =
report ~level:3 (fun fmt -> Format.fprintf fmt "Process update_out:@.");
let update_out = merge_updates update_out in
report ~level:1 (fun fmt ->
- Format.fprintf fmt "removing dead branches and merging remaining ... done@.");
-
- sw_init , sw_sys, init_out, update_out
+ Format.fprintf fmt
+ "removing dead branches and merging remaining ... done@.");
+ sw_init, sw_sys, init_out, update_out
-let fun_as_switched_sys consts nd =
+let fun_as_switched_sys consts nd =
let _, update_out = build_environement consts [] nd in
- report ~level:1 (fun fmt -> Format.fprintf fmt
- "output function as a switched system ...@.");
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "output function as a switched system ...@.");
let update_out = build_switch_sys update_out [] in
- report ~level:1 (fun fmt -> Format.fprintf fmt
- "output function as a switched system ... done@.");
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "output function as a switched system ... done@.");
- report ~level:1 (fun fmt -> Format.fprintf fmt
- "removing dead branches and merging remaining ...@.");
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "removing dead branches and merging remaining ...@.");
let update_out = clean_sys update_out in
let update_out = merge_updates update_out in
report ~level:1 (fun fmt ->
- Format.fprintf fmt "removing dead branches and merging remaining ... done@.");
+ Format.fprintf fmt
+ "removing dead branches and merging remaining ... done@.");
update_out
+(* Some code that was used to check for duplicate entries in guards.
+ (* Some additional checks *)
+ if false then begin Format.eprintf "@.@.CHECKING!!!!!!!!!!!@.";
+ Format.eprintf "Any duplicate expression in guards?@.";
-
- (* Some code that was used to check for duplicate entries in guards.
+ let sw_sys = List.map (fun (gl, up) -> let gl = List.sort (fun (e,b) (e',b')
+ -> let res = compare e.expr_tag e'.expr_tag in if res = 0 then
+ (Format.eprintf "Same exprs?@.%a@.%a@.@." Printers.pp_expr e Printers.pp_expr
+ e' ); res ) gl in gl, up ) sw_sys in Format.eprintf "Another check for
+ duplicates in guard list@."; List.iter (fun (gl, _) -> let rec aux hd l =
+ match l with [] -> () | (e,b)::tl -> let others = hd@tl in List.iter (fun
+ (e',_) -> if Corelang.is_eq_expr e e' then (Format.eprintf "Same
+ exprs?@.%a@.%a@.@." Printers.pp_expr e Printers.pp_expr e' )) others; aux
+ ((e,b)::hd) tl in aux [] gl ) sw_sys; Format.eprintf "Checking duplicates in
+ updates@."; let rec check_dup_up accu l = match l with | [] -> () | ((gl, up)
+ as hd)::tl -> let others = accu@tl in List.iter (fun (gl',up') -> if up = up'
+ then Format.eprintf "Same updates?@.%a@.%a@.%a@.%a@.@."
+ pp_gl_short gl pp_up up pp_gl_short gl' pp_up up'
- (* Some additional checks *)
-
- if false then
- begin
- Format.eprintf "@.@.CHECKING!!!!!!!!!!!@.";
- Format.eprintf "Any duplicate expression in guards?@.";
-
- let sw_sys =
- List.map (fun (gl, up) ->
- let gl = List.sort (fun (e,b) (e',b') ->
- let res = compare e.expr_tag e'.expr_tag in
- if res = 0 then (Format.eprintf "Same exprs?@.%a@.%a@.@."
- Printers.pp_expr e
- Printers.pp_expr e'
- );
- res
- ) gl in
- gl, up
- ) sw_sys
- in
- Format.eprintf "Another check for duplicates in guard list@.";
- List.iter (fun (gl, _) ->
- let rec aux hd l =
- match l with
- [] -> ()
- | (e,b)::tl -> let others = hd@tl in
- List.iter (fun (e',_) -> if Corelang.is_eq_expr e e' then
- (Format.eprintf "Same exprs?@.%a@.%a@.@."
- Printers.pp_expr e
- Printers.pp_expr e'
- )) others;
- aux ((e,b)::hd) tl
- in
- aux [] gl
- ) sw_sys;
- Format.eprintf "Checking duplicates in updates@.";
- let rec check_dup_up accu l =
- match l with
- | [] -> ()
- | ((gl, up) as hd)::tl ->
- let others = accu@tl in
- List.iter (fun (gl',up') -> if up = up' then
- Format.eprintf "Same updates?@.%a@.%a@.%a@.%a@.@."
-
- pp_gl_short gl
- pp_up up
- pp_gl_short gl'
- pp_up up'
-
- ) others;
-
-
-
- check_dup_up (hd::accu) tl
-
- in
- check_dup_up [] sw_sys;
- let _ (* sw_sys *) =
- List.sort (fun (gl1, _) (gl2, _) ->
- let glid gl = List.map (fun (e,_) -> e.expr_tag) gl in
-
- let res = compare (glid gl1) (glid gl2) in
- if res = 0 then Format.eprintf "Same guards?@.%a@.%a@.@."
- pp_gl_short gl1 pp_gl_short gl2
- ;
- res
-
- ) sw_sys
+ ) others;
- in
- ()
- end;
-
+ check_dup_up (hd::accu) tl
+
+ in check_dup_up [] sw_sys; let _ (* sw_sys *) = List.sort (fun (gl1, _) (gl2,
+ _) -> let glid gl = List.map (fun (e,_) -> e.expr_tag) gl in
+
+ let res = compare (glid gl1) (glid gl2) in if res = 0 then Format.eprintf
+ "Same guards?@.%a@.%a@.@." pp_gl_short gl1 pp_gl_short gl2 ; res
+
+ ) sw_sys
- *)
+ in () end; *)
diff --git a/src/tools/seal/seal_slice.ml b/src/tools/seal/seal_slice.ml
index a0cf56fbe4eeb044b7312b29f21c25f75c699d82..5f5743a612b37910e1daab823c72fd7d9fa663c1 100644
--- a/src/tools/seal/seal_slice.ml
+++ b/src/tools/seal/seal_slice.ml
@@ -1,158 +1,124 @@
open Lustre_types
open Utils
-open Seal_utils
-
+open Seal_utils
+
(******************************************************************************)
(* Computing a slice of a node, selecting only some variables, based on *)
(* their COI (cone of influence) *)
(******************************************************************************)
(* Basic functions to search into nodes. Could be moved to corelang eventually *)
-let is_variable nd vid =
- List.exists
- (fun v -> v.var_id = vid)
- nd.node_locals
-
-let find_variable nd vid =
- List.find
- (fun v -> v.var_id = vid)
- nd.node_locals
+let is_variable nd vid = List.exists (fun v -> v.var_id = vid) nd.node_locals
+
+let find_variable nd vid = List.find (fun v -> v.var_id = vid) nd.node_locals
-(* Returns the vars required to compute v.
- Memories are specifically identified. *)
+(* Returns the vars required to compute v. Memories are specifically identified. *)
let coi_var deps nd v =
let vname = v.var_id in
- let sliced_deps =
- Causality.slice_graph deps vname
- in
+ let sliced_deps = Causality.slice_graph deps vname in
(* Format.eprintf "sliced graph for %a: %a@."
* Printers.pp_var v
* Causality.pp_dep_graph sliced_deps; *)
let vset, memset =
IdentDepGraph.fold_vertex
- (fun vname (vset,memset) ->
- if Causality.ExprDep.is_read_var vname
- then
- let vname' = String.sub vname 1 (-1 + String.length vname) in
- if is_variable nd vname' then
- ISet.add vname' vset,
- ISet.add vname' memset
- else
- vset, memset
- else
- ISet.add vname vset, memset
- )
+ (fun vname (vset, memset) ->
+ if Causality.ExprDep.is_read_var vname then
+ let vname' = String.sub vname 1 (-1 + String.length vname) in
+ if is_variable nd vname' then
+ ISet.add vname' vset, ISet.add vname' memset
+ else vset, memset
+ else ISet.add vname vset, memset)
sliced_deps
(ISet.singleton vname, ISet.empty)
in
- report ~level:3
- (fun fmt -> Format.fprintf fmt "COI of var %s: (%a // %a)@."
- v.var_id
- (fprintf_list ~sep:"," Format.pp_print_string) (ISet.elements vset)
- (fprintf_list ~sep:"," Format.pp_print_string) (ISet.elements memset)
- ) ;
+ report ~level:3 (fun fmt ->
+ Format.fprintf fmt "COI of var %s: (%a // %a)@." v.var_id
+ (fprintf_list ~sep:"," Format.pp_print_string)
+ (ISet.elements vset)
+ (fprintf_list ~sep:"," Format.pp_print_string)
+ (ISet.elements memset));
vset, memset
-
-
+
(* Computes the variables required to compute vl. Variables /seen/ do not need
- to be computed *)
+ to be computed *)
let rec coi_vars deps nd vl seen =
let coi_vars = coi_vars deps nd in
List.fold_left
(fun accu v ->
- let vset, memset = coi_var deps nd v in
- (* We handle the new mems discovered in the coi *)
- let memset =
- ISet.filter (
- fun vid ->
- not
- (List.exists
- (fun v -> v.var_id = vid)
- vl
- )
- ) memset
- in
- let memset_vars =
- ISet.fold (
- fun vid accu ->
- (find_variable nd vid)::accu
- ) memset []
- in
- let vset' =
- coi_vars memset_vars (vl@seen)
- in
- ISet.union accu (ISet.union vset vset')
- )
+ let vset, memset = coi_var deps nd v in
+ (* We handle the new mems discovered in the coi *)
+ let memset =
+ ISet.filter
+ (fun vid -> not (List.exists (fun v -> v.var_id = vid) vl))
+ memset
+ in
+ let memset_vars =
+ ISet.fold (fun vid accu -> find_variable nd vid :: accu) memset []
+ in
+ let vset' = coi_vars memset_vars (vl @ seen) in
+ ISet.union accu (ISet.union vset vset'))
ISet.empty
- (List.filter
- (fun v -> not (List.mem v seen))
- vl
- )
-
-
+ (List.filter (fun v -> not (List.mem v seen)) vl)
+
(* compute the coi of vars_to_keeps in node nd *)
let compute_sliced_vars vars_to_keep deps nd =
- ISet.elements (coi_vars deps nd vars_to_keep [])
-
-
+ ISet.elements (coi_vars deps nd vars_to_keep [])
-
-
- (* If existing outputs are included in vars_to_keep, just slice the content.
+(* If existing outputs are included in vars_to_keep, just slice the content.
Otherwise outputs are replaced by vars_to_keep *)
let slice_node vars_to_keep msch nd =
let coi_vars =
compute_sliced_vars vars_to_keep msch.Scheduling_type.dep_graph nd
in
- report ~level:3 (fun fmt -> Format.fprintf fmt
- "COI Vars: %a@."
- (Utils.fprintf_list ~sep:"," Format.pp_print_string)
- coi_vars);
+ report ~level:3 (fun fmt ->
+ Format.fprintf fmt "COI Vars: %a@."
+ (Utils.fprintf_list ~sep:"," Format.pp_print_string)
+ coi_vars);
let outputs =
- List.filter
- (
- fun v -> List.mem v.var_id coi_vars
- ) nd.node_outputs
+ List.filter (fun v -> List.mem v.var_id coi_vars) nd.node_outputs
in
- let outputs = match outputs with
- [] -> (
- report ~level:2 (fun fmt -> Format.fprintf fmt "No visible output variable, subtituting with provided vars@ ");
+ let outputs =
+ match outputs with
+ | [] ->
+ report ~level:2 (fun fmt ->
+ Format.fprintf fmt
+ "No visible output variable, subtituting with provided vars@ ");
vars_to_keep
- )
- | l -> l
+ | l ->
+ l
in
let locals =
List.filter (fun v -> List.mem v.var_id coi_vars) nd.node_locals
in
report ~level:3 (fun fmt -> Format.fprintf fmt "Scheduling node@.");
-
+
(* Split tuples while sorting eqs *)
let eqs, auts = Corelang.get_node_eqs nd in
- assert (auts = []); (* Automata should be expanded by now *)
- let sorted_eqs, unused = Scheduling.sort_equations_from_schedule
- eqs
- msch.Scheduling_type.schedule
+ assert (auts = []);
+ (* Automata should be expanded by now *)
+ let sorted_eqs, unused =
+ Scheduling.sort_equations_from_schedule eqs msch.Scheduling_type.schedule
in
let locals = List.filter (fun v -> not (List.mem v.var_id unused)) locals in
report ~level:3 (fun fmt -> Format.fprintf fmt "Scheduled node@.");
let stmts =
- List.filter (
- fun (* stmt ->
- * match stmt with
- * | Aut _ -> assert false
- * | Eq *) eq -> (
- match eq.eq_lhs with
- [vid] -> List.mem vid coi_vars
- | _ -> Format.eprintf "Faulty statement: %a@.@?" Printers.pp_node_eq eq; assert false
- (* should not happen after inlining and normalization *)
- )
- ) sorted_eqs
+ List.filter
+ (fun (* stmt -> * match stmt with * | Aut _ -> assert false * | Eq *)
+ eq ->
+ match eq.eq_lhs with
+ | [ vid ] ->
+ List.mem vid coi_vars
+ | _ ->
+ Format.eprintf "Faulty statement: %a@.@?" Printers.pp_node_eq eq;
+ assert false
+ (* should not happen after inlining and normalization *))
+ sorted_eqs
in
- { nd
- with
+ {
+ nd with
node_outputs = outputs;
node_locals = locals;
- node_stmts = List.map (fun e -> Eq e) stmts
- }
+ node_stmts = List.map (fun e -> Eq e) stmts;
+ }
diff --git a/src/tools/seal/seal_utils.ml b/src/tools/seal/seal_utils.ml
index 52089a7562932155395ad125f129047910f17d50..038185e8f050bc5212ff4426570a7af6a39f8e06 100644
--- a/src/tools/seal/seal_utils.ml
+++ b/src/tools/seal/seal_utils.ml
@@ -1,111 +1,110 @@
open Lustre_types
open Utils
-
+
let report = Log.report ~plugin:"seal"
+
let seal_debug = ref false
-type 'boolexpr guard = 'boolexpr list
-type ('guard, 'elem) guarded_expr = 'guard * 'elem
+type 'boolexpr guard = 'boolexpr list
+
+type ('guard, 'elem) guarded_expr = 'guard * 'elem
-
type element = IsInit | Expr of expr
+
type elem_boolexpr = element * bool
type elem_guarded_expr = (elem_boolexpr guard, element) guarded_expr
-type 'ge mdef_t = 'ge list
-
- (*
-type mdef_t = guarded_expr list
- *)
-
+
+type 'ge mdef_t = 'ge list
+
+(* type mdef_t = guarded_expr list *)
+
let pp_elem fmt e =
match e with
- | IsInit -> Format.fprintf fmt "init"
- | Expr e -> Format.fprintf fmt "%a" Printers.pp_expr e
+ | IsInit ->
+ Format.fprintf fmt "init"
+ | Expr e ->
+ Format.fprintf fmt "%a" Printers.pp_expr e
let pp_guard_list pp_elem fmt gl =
- (fprintf_list ~sep:";@ "
- (fun fmt (e,b) -> if b then pp_elem fmt e else Format.fprintf fmt "not(%a)" pp_elem e)) fmt gl
-
-let pp_guard_expr pp_elem fmt (gl,e) =
- Format.fprintf fmt "@[<v 2>@[%a@] ->@ @[<hov 2>%a@]@]"
- (pp_guard_list pp_elem) gl
- pp_elem e
+ (fprintf_list ~sep:";@ " (fun fmt (e, b) ->
+ if b then pp_elem fmt e else Format.fprintf fmt "not(%a)" pp_elem e))
+ fmt gl
+
+let pp_guard_expr pp_elem fmt (gl, e) =
+ Format.fprintf fmt "@[<v 2>@[%a@] ->@ @[<hov 2>%a@]@]" (pp_guard_list pp_elem)
+ gl pp_elem e
-let pp_mdefs pp_elem fmt gel = fprintf_list ~sep:"@ " (pp_guard_expr pp_elem) fmt gel
+let pp_mdefs pp_elem fmt gel =
+ fprintf_list ~sep:"@ " (pp_guard_expr pp_elem) fmt gel
let pp_assign_map pp_elem =
- fprintf_list ~sep:"@ "
- (fun fmt (m, mdefs) ->
- Format.fprintf fmt
- "%s -> @[<v 0>[%a@] ]@ "
- m
- (pp_mdefs pp_elem) mdefs
- )
-
-let deelem e = match e with
- Expr e -> e
- | IsInit -> assert false (* Wasn't expecting isinit here: we are building values! *)
+ fprintf_list ~sep:"@ " (fun fmt (m, mdefs) ->
+ Format.fprintf fmt "%s -> @[<v 0>[%a@] ]@ " m (pp_mdefs pp_elem) mdefs)
+
+let deelem e = match e with Expr e -> e | IsInit -> assert false
+(* Wasn't expecting isinit here: we are building values! *)
let is_eq_elem elem elem' =
match elem, elem' with
- | IsInit, IsInit -> true
- | Expr e, Expr e' -> Corelang.is_eq_expr e e'
- | _ -> false
+ | IsInit, IsInit ->
+ true
+ | Expr e, Expr e' ->
+ Corelang.is_eq_expr e e'
+ | _ ->
+ false
-let select_elem elem (gelem, _) =
- is_eq_elem elem gelem
+let select_elem elem (gelem, _) = is_eq_elem elem gelem
let pp_gl pp_expr =
- fprintf_list ~sep:", " (fun fmt (e,b) -> Format.fprintf fmt "%s%a" (if b then "" else "NOT ") pp_expr e)
-
-let pp_gl_short = pp_gl (fun fmt e -> Format.fprintf fmt "%i" e.Lustre_types.expr_tag)
+ fprintf_list ~sep:", " (fun fmt (e, b) ->
+ Format.fprintf fmt "%s%a" (if b then "" else "NOT ") pp_expr e)
+
+let pp_gl_short =
+ pp_gl (fun fmt e -> Format.fprintf fmt "%i" e.Lustre_types.expr_tag)
let pp_up pp_elem fmt up =
fprintf_list ~sep:"@ "
- (fun fmt (id,e) -> Format.fprintf fmt "%s == %a;@ " id pp_elem e)
- fmt
- up
+ (fun fmt (id, e) -> Format.fprintf fmt "%s == %a;@ " id pp_elem e)
+ fmt up
let pp_sys pp_elem fmt sw =
fprintf_list ~sep:"@ "
- (fun fmt (gl,up) ->
+ (fun fmt (gl, up) ->
match gl with
| None ->
- (pp_up pp_elem) fmt up
+ (pp_up pp_elem) fmt up
| Some gl ->
- Format.fprintf fmt "@[<v 2>[@[%a@]]:@ %a@]"
- Printers.pp_expr gl (pp_up pp_elem) up)
- fmt
- sw
-
+ Format.fprintf fmt "@[<v 2>[@[%a@]]:@ %a@]" Printers.pp_expr gl
+ (pp_up pp_elem) up)
+ fmt sw
+
let pp_all_defs =
- (Utils.fprintf_list ~sep:",@ "
- (fun fmt (id, gel) -> Format.fprintf fmt "%s -> [@[<v 0>%a]@]"
- id
- (pp_mdefs pp_elem) gel))
-module UpMap =
- struct
- include Map.Make (
- struct
- type t = (ident * expr) list
- let compare l1 l2 =
- let proj l = List.map (fun (s,e) -> s, e.expr_tag) l in
- compare (proj l1) (proj l2)
- end)
- let pp = pp_up Printers.pp_expr
- end
-
+ Utils.fprintf_list ~sep:",@ " (fun fmt (id, gel) ->
+ Format.fprintf fmt "%s -> [@[<v 0>%a]@]" id (pp_mdefs pp_elem) gel)
+
+module UpMap = struct
+ include Map.Make (struct
+ type t = (ident * expr) list
+
+ let compare l1 l2 =
+ let proj l = List.map (fun (s, e) -> s, e.expr_tag) l in
+ compare (proj l1) (proj l2)
+ end)
+
+ let pp = pp_up Printers.pp_expr
+end
+
module Guards = struct
- include Set.Make (
- struct
- type t = (expr * bool)
- let compare l1 l2 =
- let proj (e,b) = e.expr_tag, b in
- compare (proj l1) (proj l2)
- end)
+ include Set.Make (struct
+ type t = expr * bool
+
+ let compare l1 l2 =
+ let proj (e, b) = e.expr_tag, b in
+ compare (proj l1) (proj l2)
+ end)
+
let pp_short fmt s = pp_gl_short fmt (elements s)
+
let pp_long fmt s = pp_gl Printers.pp_expr fmt (elements s)
end
-
-
diff --git a/src/tools/seal/seal_verifier.ml b/src/tools/seal/seal_verifier.ml
index fed38147d448b158f2ce9726766af9a48b98dacf..546ef3c3eb16093fc9236131b0ea7272e4e6f7a9 100644
--- a/src/tools/seal/seal_verifier.ml
+++ b/src/tools/seal/seal_verifier.ml
@@ -1,162 +1,159 @@
(* TODO
- - build the output function: for the moment we slice the node with
- its memories, building the function updating the memory. We will
- need later the output function, using inputs and memories to
- compute the output. A way to do this would be to declared memories
- as input, remove their definitions, and slice the node with its
- outputs. This should clean up unnecessary internal variables and
- give us the output function.
+ - build the output function: for the moment we slice the node with its
+ memories, building the function updating the memory. We will need later the
+ output function, using inputs and memories to compute the output. A way to do
+ this would be to declared memories as input, remove their definitions, and
+ slice the node with its outputs. This should clean up unnecessary internal
+ variables and give us the output function.
- compute the dimension of the node (nb of memories)
- - if the updates are all linear or affine, provide the update as a
- matrix rather then a polynomial. Check if this is simpler to do
- here or in matlab.
-
- - analyzes require bounds on inputs or sometimes target property
- over states. These could be specified as node annotations: eg
- - /seal/bounds/inputs/semialg/: (in1^4 + in2^3, 1)
- to specify that the inputs are constrained by a semialgebraic
- set (p,b) such as p(inputs) <= b
- - /seal/bounds/inputs/LMI/: (todo_describe_a_matrix) .... and so on.
- To be defined depending on needs.
- - /seal/prop/semialg/: (x3 - x5, 2) -- if x3 - x5 <= 2 is
- the property to prove
-
- *)
+ - if the updates are all linear or affine, provide the update as a matrix
+ rather then a polynomial. Check if this is simpler to do here or in matlab.
+ - analyzes require bounds on inputs or sometimes target property over states.
+ These could be specified as node annotations: eg -
+ /seal/bounds/inputs/semialg/: (in1^4 + in2^3, 1) to specify that the inputs
+ are constrained by a semialgebraic set (p,b) such as p(inputs) <= b -
+ /seal/bounds/inputs/LMI/: (todo_describe_a_matrix) .... and so on. To be
+ defined depending on needs. - /seal/prop/semialg/: (x3 - x5, 2) -- if x3 - x5
+ <= 2 is the property to prove *)
open Seal_slice
open Seal_extract
open Seal_utils
let active = ref false
+
let seal_export = ref None
-let set_export s = match s with
- | "lustre" | "lus" | "m" | "matlab" -> seal_export := Some s
- | _ -> (Format.eprintf "Unrecognized seal export: %s@.@?" s; exit 1)
-
-(* Select the appropriate node, should have been inlined already and
- extract update/output functions. *)
+let set_export s =
+ match s with
+ | "lustre" | "lus" | "m" | "matlab" ->
+ seal_export := Some s
+ | _ ->
+ Format.eprintf "Unrecognized seal export: %s@.@?" s;
+ exit 1
+
+(* Select the appropriate node, should have been inlined already and extract
+ update/output functions. *)
let seal_run ~basename prog machines =
let node_name =
match !Options.main_node with
- | "" -> (
+ | "" ->
Format.eprintf "SEAL verifier requires a main node.@.";
Format.eprintf "@[<v 2>Available ones are:@ %a@]@.@?"
- (Utils.fprintf_list ~sep:"@ "
- (fun fmt m ->
- Format.fprintf fmt "%s" m.Machine_code_types.mname.node_id
- )
- )
- machines;
+ (Utils.fprintf_list ~sep:"@ " (fun fmt m ->
+ Format.fprintf fmt "%s" m.Machine_code_types.mname.node_id))
+ machines;
exit 1
- )
- | s -> ( (* should have been addessed before *)
+ | s -> (
+ (* should have been addessed before *)
match Machine_code_common.get_machine_opt machines s with
- | None -> begin
- Global.main_node := s;
- Format.eprintf "Code generation error: %a@." Error.pp_error_msg Error.Main_not_found;
- raise (Error.Error (Location.dummy_loc, Error.Main_not_found))
- end
- | Some _ -> s
- )
+ | None ->
+ Global.main_node := s;
+ Format.eprintf "Code generation error: %a@." Error.pp_error_msg
+ Error.Main_not_found;
+ raise (Error.Error (Location.dummy_loc, Error.Main_not_found))
+ | Some _ ->
+ s)
in
let m = Machine_code_common.get_machine machines node_name in
let nd = m.mname in
let mems = m.mmemory in
- report ~level:1 (fun fmt -> Format.fprintf fmt "Node %s compiled: %i memories@." nd.node_id (List.length mems));
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "Node %s compiled: %i memories@." nd.node_id
+ (List.length mems));
(* Slicing node *)
let msch = Utils.desome m.msch in
- let sliced_nd = slice_node (mems@nd.node_outputs) msch nd in
+ let sliced_nd = slice_node (mems @ nd.node_outputs) msch nd in
report ~level:3 (fun fmt -> Format.fprintf fmt "Node sliced@.");
- report ~level:10 (fun fmt -> Format.fprintf fmt "Sliced Node %a@." Printers.pp_node sliced_nd);
+ report ~level:10 (fun fmt ->
+ Format.fprintf fmt "Sliced Node %a@." Printers.pp_node sliced_nd);
let consts = Corelang.(List.map const_of_top (get_consts prog)) in
let pp_sys = pp_sys Printers.pp_expr in
- if List.length mems = 0 then
- begin (* A stateless node = a function ! *)
-
- let update_out = fun_as_switched_sys consts sliced_nd in
-
- report ~level:1 (fun fmt ->
- Format.fprintf fmt
- "Output (%i step switch cases):@ @[<v 0>%a@]@."
- (List.length update_out)
- pp_sys update_out
- );
-
- let _ = match !seal_export with
- | Some "lustre" | Some "lus" ->
- Seal_export.fun_to_lustre basename prog m update_out
- | Some "matlab" | Some "m" -> assert false (* TODO *)
- | Some _ -> assert false
- | None -> ()
- in
- ()
- end
+ if List.length mems = 0 then (
+ (* A stateless node = a function ! *)
+ let update_out = fun_as_switched_sys consts sliced_nd in
+
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt "Output (%i step switch cases):@ @[<v 0>%a@]@."
+ (List.length update_out) pp_sys update_out);
+
+ let _ =
+ match !seal_export with
+ | Some "lustre" | Some "lus" ->
+ Seal_export.fun_to_lustre basename prog m update_out
+ | Some "matlab" | Some "m" ->
+ assert false (* TODO *)
+ | Some _ ->
+ assert false
+ | None ->
+ ()
+ in
+ ())
else
- begin (* A stateful node *)
-
- let sw_init, sw_sys, init_out, update_out = node_as_switched_sys consts mems sliced_nd in
-
- report ~level:1 (fun fmt ->
- Format.fprintf fmt
- "DynSys: (%i memories, %i init, %i step switch cases)@ @[<v 0>@[<v 3>Init:@ %a@]@ @[<v 3>Step:@ %a@]@]@."
- (List.length mems)
- (List.length sw_init)
- (List.length sw_sys)
- pp_sys sw_init
- pp_sys sw_sys
- );
-
- report ~level:1 (fun fmt ->
- Format.fprintf fmt
- "Output (%i init, %i step switch cases):@ @[<v 0>@[<v 3>Init:@ %a@]@ @[<v 3>Step:@ %a@]@]@."
- (List.length init_out)
- (List.length update_out)
- pp_sys init_out
- pp_sys update_out
- );
-
- let _ = match !seal_export with
- | Some "lustre" | Some "lus" ->
- Seal_export.node_to_lustre basename prog m sw_init sw_sys init_out update_out
- | Some "matlab" | Some "m" -> assert false (* TODO *)
- | Some _ -> assert false
- | None -> ()
- in
- ()
- end
-
-module Verifier =
- (struct
- include VerifierType.Default
- let name = "seal"
- let options =
- [
- "-export", Arg.String set_export, "seal export option (lustre, matlab)";
- "-debug", Arg.Set seal_debug, "seal debug"
-
- ]
- let activate () =
- active := true;
- Options.global_inline := true;
- Options.optimization := 0;
- Options.const_unfold := true;
- ()
-
- let is_active () = !active
- let run = seal_run
-
-
- end: VerifierType.S)
-
+ (* A stateful node *)
+ let sw_init, sw_sys, init_out, update_out =
+ node_as_switched_sys consts mems sliced_nd
+ in
+
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt
+ "DynSys: (%i memories, %i init, %i step switch cases)@ @[<v 0>@[<v \
+ 3>Init:@ %a@]@ @[<v 3>Step:@ %a@]@]@."
+ (List.length mems) (List.length sw_init) (List.length sw_sys) pp_sys
+ sw_init pp_sys sw_sys);
+
+ report ~level:1 (fun fmt ->
+ Format.fprintf fmt
+ "Output (%i init, %i step switch cases):@ @[<v 0>@[<v 3>Init:@ %a@]@ \
+ @[<v 3>Step:@ %a@]@]@."
+ (List.length init_out) (List.length update_out) pp_sys init_out pp_sys
+ update_out);
+
+ let _ =
+ match !seal_export with
+ | Some "lustre" | Some "lus" ->
+ Seal_export.node_to_lustre basename prog m sw_init sw_sys init_out
+ update_out
+ | Some "matlab" | Some "m" ->
+ assert false (* TODO *)
+ | Some _ ->
+ assert false
+ | None ->
+ ()
+ in
+ ()
+
+module Verifier : VerifierType.S = struct
+ include VerifierType.Default
+
+ let name = "seal"
+
+ let options =
+ [
+ "-export", Arg.String set_export, "seal export option (lustre, matlab)";
+ "-debug", Arg.Set seal_debug, "seal debug";
+ ]
+
+ let activate () =
+ active := true;
+ Options.global_inline := true;
+ Options.optimization := 0;
+ Options.const_unfold := true;
+ ()
+
+ let is_active () = !active
+
+ let run = seal_run
+end
+
let () =
- VerifierList.registered := (module Verifier : VerifierType.S) ::
- !VerifierList.registered
+ VerifierList.registered :=
+ (module Verifier : VerifierType.S) :: !VerifierList.registered
diff --git a/src/tools/stateflow/common/activeStates.ml b/src/tools/stateflow/common/activeStates.ml
index 3bfaba7584adaad4aca6644f36737cb28406cc72..48fb21b25ac86c3bfc3cbd4b4a458ae7d9db2942 100644
--- a/src/tools/stateflow/common/activeStates.ml
+++ b/src/tools/stateflow/common/activeStates.ml
@@ -1,44 +1,44 @@
-open Basetypes
+open Basetypes
(* Module to manipulate set of active states.
- It relies on sets of path to represent active ones.
-*)
+ It relies on sets of path to represent active ones. *)
(*******************************)
-module Vars =
-struct
- include Set.Make (struct type t = path_t let compare = compare end)
+module Vars = struct
+ include Set.Make (struct
+ type t = path_t
+
+ let compare = compare
+ end)
let pp_set fmt rho =
Format.fprintf fmt "@[<v 0>%a@ @]"
- (Utils.fprintf_list ~sep:"@ "
- (fun fmt p -> Format.fprintf fmt "%a" pp_path p))
+ (Utils.fprintf_list ~sep:"@ " (fun fmt p ->
+ Format.fprintf fmt "%a" pp_path p))
(elements rho)
end
-module Env =
-struct
- include Map.Make (struct type t = path_t let compare = compare end)
+module Env = struct
+ include Map.Make (struct
+ type t = path_t
+
+ let compare = compare
+ end)
+
+ let from_set s default = Vars.fold (fun e m -> add e default m) s empty
- let from_set s default =
- Vars.fold (fun e m -> add e default m ) s empty
-
let find a b =
- try
- find a b
- with Not_found -> (
- Format.printf "Looking for %a@." pp_path a ;
+ try find a b
+ with Not_found ->
+ Format.printf "Looking for %a@." pp_path a;
raise Not_found
- )
- let keys a =
- fold (fun key _ -> Vars.add key) a Vars.empty
+
+ let keys a = fold (fun key _ -> Vars.add key) a Vars.empty
let pp_env fmt rho =
Format.fprintf fmt "@[<v 0>%a@ @]"
- (Utils.fprintf_list ~sep:"@ "
- (fun fmt (p,b) -> Format.fprintf fmt "%a -> %b" pp_path p b))
+ (Utils.fprintf_list ~sep:"@ " (fun fmt (p, b) ->
+ Format.fprintf fmt "%a -> %b" pp_path p b))
(bindings rho)
end
-
-
diff --git a/src/tools/stateflow/common/basetypes.ml b/src/tools/stateflow/common/basetypes.ml
index 0d890e278f81c1165814151b1d65d99ea8029a82..3f0827096660c11b326a311de4c516803c7a5471 100644
--- a/src/tools/stateflow/common/basetypes.ml
+++ b/src/tools/stateflow/common/basetypes.ml
@@ -1,33 +1,50 @@
-
let sf_level = 2
(* Basic datatype for model elements: state and junction name, events ... *)
-type state_name_t = string
-type junction_name_t = string
-type path_t = state_name_t list
-type event_base_t = string
-type event_t = event_base_t option
+type state_name_t = string
+
+type junction_name_t = string
+
+type path_t = state_name_t list
+
+type event_base_t = string
+
+type event_t = event_base_t option
+
type user_variable_name_t = string
(* Connected to lustrec types *)
-type base_action_t = { defs : Lustre_types.statement list;
- ainputs: Lustre_types.var_decl list;
- aoutputs: Lustre_types.var_decl list;
- avariables: Lustre_types.var_decl list;
- (* ident: string; *)
- }
-type base_condition_t = { expr: Lustre_types.expr;
- cinputs: Lustre_types.var_decl list;
- coutputs: Lustre_types.var_decl list;
- cvariables: Lustre_types.var_decl list }
+type base_action_t = {
+ defs : Lustre_types.statement list;
+ ainputs : Lustre_types.var_decl list;
+ aoutputs : Lustre_types.var_decl list;
+ avariables : Lustre_types.var_decl list; (* ident: string; *)
+}
+
+type base_condition_t = {
+ expr : Lustre_types.expr;
+ cinputs : Lustre_types.var_decl list;
+ coutputs : Lustre_types.var_decl list;
+ cvariables : Lustre_types.var_decl list;
+}
(* P(r)etty printers *)
-let pp_state_name = Format.pp_print_string
-let pp_junction_name = Format.pp_print_string
-let pp_path fmt p = Utils.fprintf_list ~sep:"." pp_state_name fmt p
-let pp_event fmt e = match e with None -> Format.fprintf fmt "none" | Some s -> Format.fprintf fmt "%s" s
+let pp_state_name = Format.pp_print_string
+
+let pp_junction_name = Format.pp_print_string
+
+let pp_path fmt p = Utils.fprintf_list ~sep:"." pp_state_name fmt p
+
+let pp_event fmt e =
+ match e with
+ | None ->
+ Format.fprintf fmt "none"
+ | Some s ->
+ Format.fprintf fmt "%s" s
+
let pp_base_act fmt a = Printers.pp_node_stmts fmt a.defs
-let pp_base_cond fmt c= Printers.pp_expr fmt c.expr
+
+let pp_base_cond fmt c = Printers.pp_expr fmt c.expr
(* Action and Condition types and functions. *)
@@ -38,93 +55,114 @@ let pp_base_cond fmt c= Printers.pp_expr fmt c.expr
TODO: these rich call type could be externalized and a functor introduced. *)
-type frontier_t =
- | Loose
- | Strict
+type frontier_t = Loose | Strict
let pp_frontier fmt frontier =
match frontier with
- | Loose -> Format.fprintf fmt "Loose"
- | Strict -> Format.fprintf fmt "Strict"
+ | Loose ->
+ Format.fprintf fmt "Loose"
+ | Strict ->
+ Format.fprintf fmt "Strict"
type _ call_t =
| Ecall : (path_t * path_t * frontier_t) call_t
| Dcall : path_t call_t
| Xcall : (path_t * frontier_t) call_t
-let pp_call :
-type a. Format.formatter -> a call_t -> unit =
- fun fmt call ->
- match call with
- | Ecall -> Format.fprintf fmt "CallE"
- | Dcall -> Format.fprintf fmt "CallD"
- | Xcall -> Format.fprintf fmt "CallX"
-
-module type ActionType =
-sig
+let pp_call : type a. Format.formatter -> a call_t -> unit =
+ fun fmt call ->
+ match call with
+ | Ecall ->
+ Format.fprintf fmt "CallE"
+ | Dcall ->
+ Format.fprintf fmt "CallD"
+ | Xcall ->
+ Format.fprintf fmt "CallX"
+
+module type ActionType = sig
type t
+
val nil : t
+
val aquote : base_action_t -> t
+
val open_path : path_t -> t
+
val close_path : path_t -> t
+
val call : 'c call_t -> 'c -> t
val pp_act : Format.formatter -> t -> unit
end
-
-module Action =
-struct
+module Action = struct
type t =
| Quote : base_action_t -> t
| Close : path_t -> t
- | Open : path_t -> t
- | Call : 'c call_t * 'c -> t
- | Nil : t
-
+ | Open : path_t -> t
+ | Call : 'c call_t * 'c -> t
+ | Nil : t
let nil = Nil
+
let aquote act = Quote act
+
let open_path p = Open p
+
let close_path p = Close p
+
let call c a = Call (c, a)
let pp_call : type c. Format.formatter -> c call_t -> c -> unit =
- fun fmt call ->
+ fun fmt call ->
match call with
- | Ecall -> (fun (p, p', f) -> Format.fprintf fmt "%a(%a, %a, %a)" pp_call call pp_path p pp_path p' pp_frontier f)
- | Dcall -> (fun p -> Format.fprintf fmt "%a(%a)" pp_call call pp_path p)
- | Xcall -> (fun (p, f) -> Format.fprintf fmt "%a(%a, %a)" pp_call call pp_path p pp_frontier f)
+ | Ecall ->
+ fun (p, p', f) ->
+ Format.fprintf fmt "%a(%a, %a, %a)" pp_call call pp_path p pp_path p'
+ pp_frontier f
+ | Dcall ->
+ fun p -> Format.fprintf fmt "%a(%a)" pp_call call pp_path p
+ | Xcall ->
+ fun (p, f) ->
+ Format.fprintf fmt "%a(%a, %a)" pp_call call pp_path p pp_frontier f
let pp_act fmt act =
match act with
- | Call (c, a) -> pp_call fmt c a
- | Quote a -> Format.fprintf fmt "%a" pp_base_act a
- | Close p -> Format.fprintf fmt "Close(%a)" pp_path p
- | Open p -> Format.fprintf fmt "Open(%a)" pp_path p
- | Nil -> Format.fprintf fmt "Nil"
+ | Call (c, a) ->
+ pp_call fmt c a
+ | Quote a ->
+ Format.fprintf fmt "%a" pp_base_act a
+ | Close p ->
+ Format.fprintf fmt "Close(%a)" pp_path p
+ | Open p ->
+ Format.fprintf fmt "Open(%a)" pp_path p
+ | Nil ->
+ Format.fprintf fmt "Nil"
end
let _ = (module Action : ActionType)
-
(* Conditions are either (1) simple strings, (2) the active status of a state or
(3) occurence of an event. They can be combined (conjunction, negation) *)
-module type ConditionType =
-sig
+module type ConditionType = sig
type t
+
val cquote : base_condition_t -> t
+
val tru : t
+
val active : path_t -> t
+
val event : event_t -> t
+
val ( && ) : t -> t -> t
+
val neg : t -> t
val pp_cond : Format.formatter -> t -> unit
end
-
-module Condition =
-struct
+
+module Condition = struct
type t =
| Quote of base_condition_t
| Active of path_t
@@ -134,29 +172,35 @@ struct
| True
let cquote cond = Quote cond
+
let tru = True
+
let neg cond = Neg cond
+
let ( && ) cond1 cond2 = And (cond1, cond2)
+
let active path = Active path
- let event evt =
- match evt with
- | None -> True
- | Some e -> Event e
+
+ let event evt = match evt with None -> True | Some e -> Event e
let rec pp_cond fmt cond =
match cond with
- | True -> Format.fprintf fmt "true"
- | Active p -> Format.fprintf fmt "Active(%a)" pp_path p
- | Event e -> Format.fprintf fmt "Event(%s)" e
- | Neg cond -> Format.fprintf fmt "(neg %a)" pp_cond cond
- | And (cond1, cond2) -> Format.fprintf fmt "%a /\\ %a" pp_cond cond1 pp_cond cond2
- | Quote c -> Format.fprintf fmt "%a" pp_base_cond c
-
+ | True ->
+ Format.fprintf fmt "true"
+ | Active p ->
+ Format.fprintf fmt "Active(%a)" pp_path p
+ | Event e ->
+ Format.fprintf fmt "Event(%s)" e
+ | Neg cond ->
+ Format.fprintf fmt "(neg %a)" pp_cond cond
+ | And (cond1, cond2) ->
+ Format.fprintf fmt "%a /\\ %a" pp_cond cond1 pp_cond cond2
+ | Quote c ->
+ Format.fprintf fmt "%a" pp_base_cond c
end
let _ = (module Condition : ConditionType)
-module GlobalVarDef =
-struct
- type t = {variable: Lustre_types.var_decl; init_val: Lustre_types.expr}
+module GlobalVarDef = struct
+ type t = { variable : Lustre_types.var_decl; init_val : Lustre_types.expr }
end
diff --git a/src/tools/stateflow/common/datatype.ml b/src/tools/stateflow/common/datatype.ml
index f4b31423df54637c3f598424808a0aee2b8e297a..458702ee0ea0d49938dfe9c6bf18dc28f771e57a 100644
--- a/src/tools/stateflow/common/datatype.ml
+++ b/src/tools/stateflow/common/datatype.ml
@@ -3,16 +3,14 @@ open Basetypes
(* Type definitions of a model *)
-type destination_t =
- | DPath of path_t
- | DJunction of junction_name_t
+type destination_t = DPath of path_t | DJunction of junction_name_t
type trans_t = {
- event: event_t;
- condition: Condition.t;
- condition_act: Action.t;
- transition_act: Action.t;
- dest: destination_t;
+ event : event_t;
+ condition : Condition.t;
+ condition_act : Action.t;
+ transition_act : Action.t;
+ dest : destination_t;
}
type transitions_t = trans_t list
@@ -22,9 +20,9 @@ type composition_t =
| And of state_name_t list
type state_actions_t = {
- entry_act: Action.t;
- during_act: Action.t;
- exit_act: Action.t;
+ entry_act : Action.t;
+ during_act : Action.t;
+ exit_act : Action.t;
}
type state_def_t = {
@@ -39,7 +37,11 @@ type 'prog_t src_components_t =
| Junction of junction_name_t * transitions_t
| SFFunction of 'prog_t
-type prog_t = Program of state_name_t * prog_t src_components_t list * (Lustre_types.var_decl * Lustre_types.expr) list
+type prog_t =
+ | Program of
+ state_name_t
+ * prog_t src_components_t list
+ * (Lustre_types.var_decl * Lustre_types.expr) list
type scope_t = Constant | Input | Local | Output | Parameter
@@ -51,34 +53,44 @@ type trace_t = event_t list
module type MODEL_T = sig
val name : string
+
val model : prog_t
- val traces: trace_t list
+
+ val traces : trace_t list
end
(* Module (S)tate(F)low provides basic constructors for action, condition,
events, as well as printer functions *)
-module SF =
-struct
-
+module SF = struct
(* Basic constructors *)
- let no_action = Action.nil
+ let no_action = Action.nil
+
let no_condition = Condition.tru
- let no_event = None
- let event s = Some s
- let action s = Action.aquote s
- let condition s = Condition.cquote s
- let no_state_action = {entry_act = no_action; during_act = no_action; exit_act = no_action; }
- let state_action a b c = {entry_act = a; during_act = b; exit_act = c; }
+
+ let no_event = None
+
+ let event s = Some s
+
+ let action s = Action.aquote s
+
+ let condition s = Condition.cquote s
+
+ let no_state_action =
+ { entry_act = no_action; during_act = no_action; exit_act = no_action }
+
+ let state_action a b c = { entry_act = a; during_act = b; exit_act = c }
let states (Program (_, defs, _)) =
List.fold_left
(fun res c ->
- match c with
- | State (p, _) -> ActiveStates.Vars.add p res
- | Junction _ -> res
- | SFFunction _ -> res
- )
+ match c with
+ | State (p, _) ->
+ ActiveStates.Vars.add p res
+ | Junction _ ->
+ res
+ | SFFunction _ ->
+ res)
ActiveStates.Vars.empty defs
let init_env model = ActiveStates.Env.from_set (states model) false
@@ -89,83 +101,84 @@ struct
let pp_event fmt e =
match e with
- | Some e -> Format.fprintf fmt "%s" e
- | None -> Format.fprintf fmt "noevent"
-
- let pp_dest fmt d = match d with
- | DPath p -> Format.fprintf fmt "Path %a" pp_path p
- | DJunction j -> Format.fprintf fmt "Junction %a" pp_junction_name j
+ | Some e ->
+ Format.fprintf fmt "%s" e
+ | None ->
+ Format.fprintf fmt "noevent"
+
+ let pp_dest fmt d =
+ match d with
+ | DPath p ->
+ Format.fprintf fmt "Path %a" pp_path p
+ | DJunction j ->
+ Format.fprintf fmt "Junction %a" pp_junction_name j
let pp_trans fmt t =
- Format.fprintf fmt
- "@[<hov 0>(@[<hov 0>%a,@ %a,@ %a,@ %a,@ %a@]@ )@]"
- pp_event t.event
- Condition.pp_cond t.condition
- Action.pp_act t.condition_act
- Action.pp_act t.transition_act
- pp_dest t.dest
+ Format.fprintf fmt "@[<hov 0>(@[<hov 0>%a,@ %a,@ %a,@ %a,@ %a@]@ )@]"
+ pp_event t.event Condition.pp_cond t.condition Action.pp_act
+ t.condition_act Action.pp_act t.transition_act pp_dest t.dest
let pp_transitions fmt l =
- Format.fprintf fmt
- "@[<hov 0>[@[<hov 0>%a@]@ ]@]"
- (Utils.fprintf_list ~sep:";@ " pp_trans) l
+ Format.fprintf fmt "@[<hov 0>[@[<hov 0>%a@]@ ]@]"
+ (Utils.fprintf_list ~sep:";@ " pp_trans)
+ l
- let pp_comp fmt c = match c with
+ let pp_comp fmt c =
+ match c with
| Or (_T, _S) ->
- Format.fprintf fmt "Or(%a, {%a})"
- pp_transitions _T
- (Utils.fprintf_list ~sep:"; " pp_state_name) _S
- | And (_S) ->
- Format.fprintf fmt "And({%a})"
- (Utils.fprintf_list ~sep:"; " pp_state_name) _S
+ Format.fprintf fmt "Or(%a, {%a})" pp_transitions _T
+ (Utils.fprintf_list ~sep:"; " pp_state_name)
+ _S
+ | And _S ->
+ Format.fprintf fmt "And({%a})"
+ (Utils.fprintf_list ~sep:"; " pp_state_name)
+ _S
let pp_state_actions fmt sa =
- Format.fprintf fmt "@[<hov 0>(%a,@ %a,@ %a)@]"
- Action.pp_act sa.entry_act
- Action.pp_act sa.during_act
- Action.pp_act sa.exit_act
+ Format.fprintf fmt "@[<hov 0>(%a,@ %a,@ %a)@]" Action.pp_act sa.entry_act
+ Action.pp_act sa.during_act Action.pp_act sa.exit_act
let pp_state fmt s =
Format.fprintf fmt "@[<v 0>(@[<v 0>%a,@ %a,@ %a,@ %a@]@ @])"
- pp_state_actions s.state_actions
- pp_transitions s.outer_trans
- pp_transitions s.inner_trans
- pp_comp s.internal_composition
+ pp_state_actions s.state_actions pp_transitions s.outer_trans
+ pp_transitions s.inner_trans pp_comp s.internal_composition
let pp_src pp_sffunction fmt src =
Format.fprintf fmt "@[<v>%a@ @]"
- (Utils.fprintf_list ~sep:"@ @ "
- (fun fmt src -> match src with
- | State (p, def) -> Format.fprintf fmt "%a: %a"
- pp_path p pp_state def
- | Junction (s, tl) -> Format.fprintf fmt "%a: %a"
- pp_state_name s
- pp_transitions tl
- | SFFunction p -> pp_sffunction fmt p
- ))
+ (Utils.fprintf_list ~sep:"@ @ " (fun fmt src ->
+ match src with
+ | State (p, def) ->
+ Format.fprintf fmt "%a: %a" pp_path p pp_state def
+ | Junction (s, tl) ->
+ Format.fprintf fmt "%a: %a" pp_state_name s pp_transitions tl
+ | SFFunction p ->
+ pp_sffunction fmt p))
src
let rec pp_sffunction fmt (Program (name, component_list, _)) =
- Format.fprintf fmt "SFFunction name: %s@ %a@ "
- name
- (pp_src pp_sffunction) component_list
+ Format.fprintf fmt "SFFunction name: %s@ %a@ " name (pp_src pp_sffunction)
+ component_list
let pp_vars fmt src =
Format.fprintf fmt "@[<v>%a@ @]"
(Utils.fprintf_list ~sep:"@ " Printers.pp_var)
- src
+ src
let pp_prog fmt (Program (name, component_list, vars)) =
- Format.fprintf fmt "Main node name: %s@ %a@ %a@"
- name
- (pp_src pp_sffunction) component_list
- pp_vars (List.map fst vars)
+ Format.fprintf fmt "Main node name: %s@ %a@ %a@" name (pp_src pp_sffunction)
+ component_list pp_vars (List.map fst vars)
let pp_scope fmt src =
- Format.fprintf fmt (match src with
- | Constant -> "Constant"
- | Input -> "Input"
- | Local -> "Local"
- | Output -> "Output"
- | Parameter -> "Parameter")
+ Format.fprintf fmt
+ (match src with
+ | Constant ->
+ "Constant"
+ | Input ->
+ "Input"
+ | Local ->
+ "Local"
+ | Output ->
+ "Output"
+ | Parameter ->
+ "Parameter")
end
diff --git a/src/tools/stateflow/json-parser/json_parser.ml b/src/tools/stateflow/json-parser/json_parser.ml
index 30505ebae8bf62f1c6dc6346ed07837e68f554ab..7ca93ae8f1f083cfbe61093cea09860f6ae8eba8 100644
--- a/src/tools/stateflow/json-parser/json_parser.ml
+++ b/src/tools/stateflow/json-parser/json_parser.ml
@@ -6,156 +6,184 @@ open Str
open Yojson
open Basic
-module type ParseExt =
-sig
+module type ParseExt = sig
val parse_condition : json -> Condition.t
- val parse_action : json -> Action.t
- val parse_event : json -> Basetypes.event_t
+
+ val parse_action : json -> Action.t
+
+ val parse_event : json -> Basetypes.event_t
end
-module Parser (Ext : ParseExt) =
-struct
+module Parser (Ext : ParseExt) = struct
exception JSON_parse_error of string
let path_split = String.split_on_char '/'
+
let path_concat = String.concat (String.make 1 '/')
open Util
- let to_list json =
- try
- json |> to_list
- with
- Type_error _ -> [ json ]
+ let to_list json = try json |> to_list with Type_error _ -> [ json ]
let rec parse_prog json : prog_t =
- Logs.info (fun m -> m "parse_prog %s" (json |> member "name" |> to_string));
- Program (
- json |> member "name" |> to_string,
- (json |> member "states" |> to_list |> List.map parse_state) @
- (json |> member "junctions" |> to_list |> List.map parse_junction)
- @
- (json |> member "sffunctions" |> to_list |> List.map
- (fun res -> SFFunction (parse_prog res))),
- json |> member "data" |> to_list |> List.map parse_variable
- )
+ Logs.info (fun m -> m "parse_prog %s" (json |> member "name" |> to_string));
+ Program
+ ( json |> member "name" |> to_string,
+ (json |> member "states" |> to_list |> List.map parse_state)
+ @ (json |> member "junctions" |> to_list |> List.map parse_junction)
+ @ (json |> member "sffunctions" |> to_list
+ |> List.map (fun res -> SFFunction (parse_prog res))),
+ json |> member "data" |> to_list |> List.map parse_variable )
+
and parse_state json =
Logs.debug (fun m -> m "parse_state");
- State (
- json |> member "path" |> parse_path,
- json |> parse_state_def
- )
+ State (json |> member "path" |> parse_path, json |> parse_state_def)
+
and parse_path json =
Logs.debug (fun m -> m "parse_path %s" (json |> to_string));
json |> to_string |> path_split
+
and parse_state_def json =
Logs.debug (fun m -> m "parse_state_def");
{
- state_actions = json |> member "state_actions" |> parse_state_actions;
- outer_trans = json |> member "outer_trans" |> to_list |> List.map parse_transition;
- inner_trans = json |> member "inner_trans" |> to_list |> List.map parse_transition;
- internal_composition = json |> member "internal_composition" |> parse_internal_composition
+ state_actions = json |> member "state_actions" |> parse_state_actions;
+ outer_trans =
+ json |> member "outer_trans" |> to_list |> List.map parse_transition;
+ inner_trans =
+ json |> member "inner_trans" |> to_list |> List.map parse_transition;
+ internal_composition =
+ json |> member "internal_composition" |> parse_internal_composition;
}
+
and parse_state_actions json =
Logs.debug (fun m -> m "parse_state_actions");
{
- entry_act = json |> member "entry_act" |> Ext.parse_action;
+ entry_act = json |> member "entry_act" |> Ext.parse_action;
during_act = json |> member "during_act" |> Ext.parse_action;
- exit_act = json |> member "exit_act" |> Ext.parse_action;
+ exit_act = json |> member "exit_act" |> Ext.parse_action;
}
+
and parse_transition json =
Logs.debug (fun m -> m "parse_transition");
{
- event = json |> member "event" |> Ext.parse_event;
- condition = json |> member "condition" |> Ext.parse_condition;
- condition_act = json |> member "condition_act" |> Ext.parse_action;
+ event = json |> member "event" |> Ext.parse_event;
+ condition = json |> member "condition" |> Ext.parse_condition;
+ condition_act = json |> member "condition_act" |> Ext.parse_action;
transition_act = json |> member "transition_act" |> Ext.parse_action;
- dest = json |> member "dest" |> parse_dest
+ dest = json |> member "dest" |> parse_dest;
}
+
and parse_dest json =
Logs.debug (fun m -> m "parse_dest");
let dest_type = json |> member "type" |> to_string in
- (dest_type |>
- (function
- | "State" -> (fun p -> DPath p)
- | "Junction" -> (fun j -> DJunction (path_concat j))
- | _ -> raise (JSON_parse_error ("Invalid destination type: " ^ dest_type))))
+ (dest_type |> function
+ | "State" ->
+ fun p -> DPath p
+ | "Junction" ->
+ fun j -> DJunction (path_concat j)
+ | _ ->
+ raise (JSON_parse_error ("Invalid destination type: " ^ dest_type)))
(json |> member "name" |> parse_path)
+
and parse_internal_composition json =
Logs.debug (fun m -> m "parse_internal_composition");
let state_type = json |> member "type" |> to_string in
- (state_type |>
- (function
- | "EXCLUSIVE_OR" -> (fun tinit substates -> Or (tinit, substates))
- | "PARALLEL_AND" -> (fun tinit substates -> assert (tinit = []); And (substates))
- | _ -> raise (JSON_parse_error ("Invalid state type: " ^ state_type))))
- (json |> member "tinit" |> parse_tinit)
+ (state_type |> function
+ | "EXCLUSIVE_OR" ->
+ fun tinit substates -> Or (tinit, substates)
+ | "PARALLEL_AND" ->
+ fun tinit substates ->
+ assert (tinit = []);
+ And substates
+ | _ ->
+ raise (JSON_parse_error ("Invalid state type: " ^ state_type)))
+ (json |> member "tinit" |> parse_tinit)
(json |> member "substates" |> to_list |> List.map to_string)
+
and parse_tinit json =
Logs.debug (fun m -> m "parse_tinit");
json |> to_list |> List.map parse_transition
+
and parse_junction json =
Logs.debug (fun m -> m "parse_junction");
- Junction (
- json |> member "path" |> to_string,
- json |> member "outer_trans" |> to_list |> List.map parse_transition
- )
+ Junction
+ ( json |> member "path" |> to_string,
+ json |> member "outer_trans" |> to_list |> List.map parse_transition )
+
and scope_of_string s =
match s with
- | "Constant" -> Constant
- | "Input" -> Input
- | "Local" -> Local
- | "Output" -> Output
- | "Parameter" -> Parameter
- | _ -> raise (JSON_parse_error ("Invalid scope for variable: " ^ s))
+ | "Constant" ->
+ Constant
+ | "Input" ->
+ Input
+ | "Local" ->
+ Local
+ | "Output" ->
+ Output
+ | "Parameter" ->
+ Parameter
+ | _ ->
+ raise (JSON_parse_error ("Invalid scope for variable: " ^ s))
+
and parse_real_value s =
Logs.debug (fun m -> m "parse_real_value %s" s);
let real_regexp_simp = regexp "\\(-?[0-9][0-9]*\\)\\.\\([0-9]*\\)" in
- let real_regexp_e = regexp "\\(-?[0-9][0-9]*\\)\\.\\([0-9]*\\)\\(E\\|e\\)\\(\\(\\+\\|\\-\\)[0-9][0-9]*\\)" in
+ let real_regexp_e =
+ regexp
+ "\\(-?[0-9][0-9]*\\)\\.\\([0-9]*\\)\\(E\\|e\\)\\(\\(\\+\\|\\-\\)[0-9][0-9]*\\)"
+ in
if string_match real_regexp_e s 0 then
let l = matched_group 1 s in
let r = matched_group 2 s in
let e = matched_group 4 s in
- Const_real (Num.num_of_string (l ^ r),
- String.length r + (-1 * int_of_string e),
- s)
- else
- if string_match real_regexp_simp s 0 then
+ Const_real
+ (Num.num_of_string (l ^ r), String.length r + (-1 * int_of_string e), s)
+ else if string_match real_regexp_simp s 0 then
let l = matched_group 1 s in
let r = matched_group 2 s in
Const_real (Num.num_of_string (l ^ r), String.length r, s)
- else
- raise (JSON_parse_error ("Invalid real constant " ^ s))
+ else raise (JSON_parse_error ("Invalid real constant " ^ s))
+
and lustre_datatype_of_json json location =
- let datatype = json |> member "datatype" |> to_string in
+ let datatype = json |> member "datatype" |> to_string in
let initial_value = json |> member "initial_value" |> to_string in
match datatype with
- | "bool" -> (Tydec_bool, mkexpr location
- (Expr_const (Const_tag
- ((fun s -> match s with
- | "true" -> tag_true
- | "false" -> tag_false
- | _ ->
- raise (JSON_parse_error ("Invalid constant for
- boolean: " ^ s))) initial_value))))
- | "int" -> (Tydec_int, mkexpr location
- (Expr_const (Const_int (int_of_string
- initial_value))))
- | "real" -> (Tydec_real, mkexpr location
- (Expr_const (parse_real_value initial_value)))
- | _ -> raise (JSON_parse_error ("Invalid datatype " ^ datatype
- ^ " for variable " ^ (json |> member "name"
- |> to_string)))
+ | "bool" ->
+ ( Tydec_bool,
+ mkexpr location
+ (Expr_const
+ (Const_tag
+ ((fun s ->
+ match s with
+ | "true" ->
+ tag_true
+ | "false" ->
+ tag_false
+ | _ ->
+ raise
+ (JSON_parse_error
+ ("Invalid constant for\n boolean: " ^ s)))
+ initial_value))) )
+ | "int" ->
+ ( Tydec_int,
+ mkexpr location (Expr_const (Const_int (int_of_string initial_value))) )
+ | "real" ->
+ Tydec_real, mkexpr location (Expr_const (parse_real_value initial_value))
+ | _ ->
+ raise
+ (JSON_parse_error
+ ("Invalid datatype " ^ datatype ^ " for variable "
+ ^ (json |> member "name" |> to_string)))
+
and parse_variable json =
- Logs.debug (fun m -> m "parse_variable %s" (json |> member "name" |> to_string));
- let location = Location.dummy_loc in
- let (datatype, initial_value) = lustre_datatype_of_json json location in
+ Logs.debug (fun m ->
+ m "parse_variable %s" (json |> member "name" |> to_string));
+ let location = Location.dummy_loc in
+ let datatype, initial_value = lustre_datatype_of_json json location in
mkvar_decl location ~orig:true
( json |> member "name" |> to_string,
- {ty_dec_desc = datatype; ty_dec_loc = location},
- {ck_dec_desc = Ckdec_any; ck_dec_loc = location},
+ { ty_dec_desc = datatype; ty_dec_loc = location },
+ { ck_dec_desc = Ckdec_any; ck_dec_loc = location },
true,
- Some initial_value
- )
+ Some initial_value )
end
-
diff --git a/src/tools/stateflow/json-parser/main_parse_json_file.ml b/src/tools/stateflow/json-parser/main_parse_json_file.ml
index f0dd09c324be291ba72a895ae126476b519771b5..8680096679911505cc62e741dd2c54c8c0b155bf 100644
--- a/src/tools/stateflow/json-parser/main_parse_json_file.ml
+++ b/src/tools/stateflow/json-parser/main_parse_json_file.ml
@@ -4,89 +4,79 @@ open Datatype
open Json_parser
open Sys
-module ParseExt =
-struct
+module ParseExt = struct
open Yojson.Basic
-
-
+
let remove_quotes s =
let len = String.length s in
- if String.get s 0 = '"' && String.get s (len-1) = '"' then
- String.sub s 1 (len-2)
+ if String.get s 0 = '"' && String.get s (len - 1) = '"' then
+ String.sub s 1 (len - 2)
else (
Format.eprintf "No quotes in string %s@.@?" s;
- assert false
- )
+ assert false)
let get_vars json =
- let get_vdecls key json =
- let s = json |> Util.member key |> to_string in
- try
- let s'= remove_quotes s in
- if s' = "" then [] else
- let lexbuf = Lexing.from_string s' in
- Parser_lustre.vdecl_list Lexer_lustre.token lexbuf
- with _ -> (Format.eprintf "Issues parsing decls for %s: %s@.@?" key s; assert false)
-
- in
- let inputs = get_vdecls "inputs" json in
- let outputs = get_vdecls "outputs" json in
- let variables = get_vdecls "variables" json in
- inputs, outputs, variables
-
+ let get_vdecls key json =
+ let s = json |> Util.member key |> to_string in
+ try
+ let s' = remove_quotes s in
+ if s' = "" then []
+ else
+ let lexbuf = Lexing.from_string s' in
+ Parser_lustre.vdecl_list Lexer_lustre.token lexbuf
+ with _ ->
+ Format.eprintf "Issues parsing decls for %s: %s@.@?" key s;
+ assert false
+ in
+
+ let inputs = get_vdecls "inputs" json in
+ let outputs = get_vdecls "outputs" json in
+ let variables = get_vdecls "variables" json in
+ inputs, outputs, variables
+
(* Protecting the generation of condition/action in case of an empty string
instead of a subtree *)
let protect default parse_fun embed_fun json =
try
let vars = get_vars json in
- let actions = json |> Util.member "actions" |> to_string in
- if actions = "[]" || actions = "" then default (* should not happen *) else (
- Format.eprintf "Parsing string: %s@." actions;
- let lexbuf = Lexing.from_string (remove_quotes actions) in
- try
- let content = parse_fun Lexer_lustre.token lexbuf in
- Parsing.clear_parser ();
- embed_fun content vars
- with Parsing.Parse_error ->
- let loc = Location.dummy_loc in
- raise (Parse.Error (loc, Parse.String_Syntax_error actions))
- )
- with Util.Type_error _ -> (
- Format.eprintf
- "Unable to explore json subtree: empty string %s@." (to_string json);
+ let actions = json |> Util.member "actions" |> to_string in
+ if actions = "[]" || actions = "" then default (* should not happen *)
+ else (
+ Format.eprintf "Parsing string: %s@." actions;
+ let lexbuf = Lexing.from_string (remove_quotes actions) in
+ try
+ let content = parse_fun Lexer_lustre.token lexbuf in
+ Parsing.clear_parser ();
+ embed_fun content vars
+ with Parsing.Parse_error ->
+ let loc = Location.dummy_loc in
+ raise (Parse.Error (loc, Parse.String_Syntax_error actions)))
+ with Util.Type_error _ ->
+ Format.eprintf "Unable to explore json subtree: empty string %s@."
+ (to_string json);
default
- )
-
+
let parse_condition =
- protect
- Condition.tru
- Parser_lustre.expr
- (fun e (in_,out_,locals_) ->
- (* let vars = Corelang.get_expr_vars e in *)
- Condition.cquote {
- expr = e;
- cinputs = in_;
- coutputs = out_;
- cvariables = locals_;
-
- })
-
+ protect Condition.tru Parser_lustre.expr (fun e (in_, out_, locals_) ->
+ (* let vars = Corelang.get_expr_vars e in *)
+ Condition.cquote
+ { expr = e; cinputs = in_; coutputs = out_; cvariables = locals_ })
+
let parse_action =
protect Action.nil Parser_lustre.stmt_list
(fun (stmts, asserts, annots) (in_, out_, locals_) ->
- if asserts != [] || annots != [] then
- assert false (* Stateflow equations should not use asserts nor define
- annotations *)
- else
- Action.aquote ({
- defs = stmts;
- ainputs = in_;
- aoutputs = out_;
- avariables = locals_;
- })
- )
-
- let parse_event json = Some Yojson.Basic.(json |> to_string)
+ if asserts != [] || annots != [] then assert false
+ (* Stateflow equations should not use asserts nor define annotations *)
+ else
+ Action.aquote
+ {
+ defs = stmts;
+ ainputs = in_;
+ aoutputs = out_;
+ avariables = locals_;
+ })
+
+ let parse_event json = Some Yojson.Basic.(json |> to_string)
end
module JParse = Parser (ParseExt)
@@ -104,58 +94,69 @@ let modular = ref 0
let json_parse _ file pp =
try
let prog = JParse.parse_prog (Yojson.Basic.from_file file) in
- if pp then
- SF.pp_prog Format.std_formatter prog;
-
- let module Model =
- struct
- let model = prog
- let name = "toto" (* TODO find a meaningful name *)
- let traces = [] (* TODO: shall we remove the traces field? *)
- end
- in
+ if pp then SF.pp_prog Format.std_formatter prog;
+
+ let module Model = struct
+ let model = prog
+
+ let name = "toto"
+ (* TODO find a meaningful name *)
+
+ let traces = []
+ (* TODO: shall we remove the traces field? *)
+ end in
let modularmode =
match !modular with
- | 2 -> true, true, true
- | 1 -> false, true, false
- | _ (* 0 *) -> false, false ,false
+ | 2 ->
+ true, true, true
+ | 1 ->
+ false, true, false
+ | _ (* 0 *) ->
+ false, false, false
in
let state_vars = Datatype.SF.states Model.model in
let global_vars = Datatype.SF.global_vars Model.model in
-
+
let module T = CPS_lustre_generator.LustrePrinter (struct
let state_vars = state_vars
- let global_vars = global_vars
+
+ let global_vars = global_vars
end) in
let module Sem = CPS.Semantics (T) (Model) in
let prog = Sem.code_gen modularmode in
- let header = List.map Corelang.mktop [
- (LustreSpec.Open (false,"lustrec_math"));
- (LustreSpec.Open (false,"conv"));
- (LustreSpec.Open (true,"locallib"));
- ]
+ let header =
+ List.map Corelang.mktop
+ [
+ LustreSpec.Open (false, "lustrec_math");
+ LustreSpec.Open (false, "conv");
+ LustreSpec.Open (true, "locallib");
+ ]
in
- let prog =header@prog in
+ let prog = header @ prog in
Options.print_dec_types := true;
- (* Format.printf "%a@." Printers.pp_prog prog; *)
- let auto_file = "sf_gen_test_auto.lus" in (* Could be changed *)
+ (* Format.printf "%a@." Printers.pp_prog prog; *)
+ let auto_file = "sf_gen_test_auto.lus" in
+ (* Could be changed *)
let auto_out = open_out auto_file in
let auto_fmt = Format.formatter_of_out_channel auto_out in
Format.fprintf auto_fmt "%a@." Printers.pp_prog prog;
- Format.eprintf "Print initial lustre model with automaton in sf_gen_test_auto.lus@.";
-
+ Format.eprintf
+ "Print initial lustre model with automaton in sf_gen_test_auto.lus@.";
+
let prog, deps = Compiler_stages.stage1 prog "" "" in
(* Format.printf "%a@." Printers.pp_prog prog; *)
- let noauto_file = "sf_gen_test_noauto.lus" in (* Could be changed *)
+ let noauto_file = "sf_gen_test_noauto.lus" in
+ (* Could be changed *)
let noauto_out = open_out noauto_file in
let noauto_fmt = Format.formatter_of_out_channel noauto_out in
Format.fprintf noauto_fmt "%a@." Printers.pp_prog prog;
Format.eprintf "Print expanded lustre model in sf_gen_test_noauto.lus@.";
()
-
- with Parse.Error (l, err) -> Format.eprintf "Parse error at loc %a : %a@.@?" Location.pp_loc l Parse.pp_error err
+ with Parse.Error (l, err) ->
+ Format.eprintf "Parse error at loc %a : %a@.@?" Location.pp_loc l
+ Parse.pp_error err
(* term representing argument for file *)
let file =
@@ -167,7 +168,7 @@ let file =
(* term representing argument for flag for pretty printing the program *)
let pp =
let doc = "Pretty print the resulting program" in
- Arg.(value & flag & info ["pp"; "pretty-print"] ~docv:"PP" ~doc)
+ Arg.(value & flag & info [ "pp"; "pretty-print" ] ~docv:"PP" ~doc)
(* term for argument for logging *)
let setup_log_arg =
@@ -180,12 +181,8 @@ let json_parse_t = Term.(const json_parse $ setup_log_arg $ file $ pp)
(* term info for manpages etc. *)
let info =
let doc = "parse a JSON file representing a Stateflow model" in
- let man = [
- `S Manpage.s_bugs;
- `P "Report bug to Github issues tracking." ]
- in
+ let man = [ `S Manpage.s_bugs; `P "Report bug to Github issues tracking." ] in
Term.info "parse_json_file" ~doc ~exits:Term.default_exits ~man
(* program *)
-let _ =
- Term.exit @@ Term.eval (json_parse_t, info)
+let _ = Term.exit @@ Term.eval (json_parse_t, info)
diff --git a/src/tools/stateflow/json-parser/test_json_parser_variables.ml b/src/tools/stateflow/json-parser/test_json_parser_variables.ml
index f717bd78c9a4c70add2925361e8bc8964ef357b1..e4cc89297fc98a187d25667da642561e6f356365 100644
--- a/src/tools/stateflow/json-parser/test_json_parser_variables.ml
+++ b/src/tools/stateflow/json-parser/test_json_parser_variables.ml
@@ -5,11 +5,12 @@ open Json_parser
open LustreSpec
open OUnit2
-module ParseExt =
-struct
+module ParseExt = struct
let parse_condition _ = Condition.tru
- let parse_action _ = Action.nil
- let parse_event json = Some Yojson.Basic.(json |> to_string)
+
+ let parse_action _ = Action.nil
+
+ let parse_event json = Some Yojson.Basic.(json |> to_string)
end
module Parse = Parser (ParseExt)
@@ -18,172 +19,192 @@ let location = Location.dummy_loc
let string_of_var_type var_type =
match var_type with
- | Tydec_bool -> "bool"
- | Tydec_int -> "int"
- | Tydec_real -> "real"
- | _ -> "other"
+ | Tydec_bool ->
+ "bool"
+ | Tydec_int ->
+ "int"
+ | Tydec_real ->
+ "real"
+ | _ ->
+ "other"
let string_of_var_value value =
match value with
- | Expr_const (Const_tag label) -> label
- | Expr_const (Const_int v) -> string_of_int v
- | Expr_const (Const_real (n, l, s)) -> (Num.string_of_num n) ^
- " x 10^-" ^
- (string_of_int l) ^
- " (" ^ s ^ ")"
- | _ -> "other value (not possible)"
+ | Expr_const (Const_tag label) ->
+ label
+ | Expr_const (Const_int v) ->
+ string_of_int v
+ | Expr_const (Const_real (n, l, s)) ->
+ Num.string_of_num n ^ " x 10^-" ^ string_of_int l ^ " (" ^ s ^ ")"
+ | _ ->
+ "other value (not possible)"
let test_var_skeleton var id var_type value =
- begin
- assert_bool
- "orig for user variables should be true"
- var.var_orig;
- assert_bool
- "user variables are considered as constants"
- var.var_dec_const;
- assert_equal
- ~msg:("problem with variable " ^ var.var_id ^ " clock type")
- Ckdec_any
- var.var_dec_clock.ck_dec_desc;
- assert_equal
- ~msg:("problem with variable " ^ var.var_id ^ " ident")
- ~printer:(fun x -> x)
- id
- var.var_id;
+ assert_bool "orig for user variables should be true" var.var_orig;
+ assert_bool "user variables are considered as constants" var.var_dec_const;
+ assert_equal
+ ~msg:("problem with variable " ^ var.var_id ^ " clock type")
+ Ckdec_any var.var_dec_clock.ck_dec_desc;
+ assert_equal
+ ~msg:("problem with variable " ^ var.var_id ^ " ident")
+ ~printer:(fun x -> x)
+ id var.var_id;
+ assert_equal
+ ~msg:("problem with variable " ^ var.var_id ^ " type")
+ ~printer:string_of_var_type var_type var.var_dec_type.ty_dec_desc;
+ match var.var_dec_value with
+ | Some { expr_desc = d } ->
assert_equal
- ~msg:("problem with variable " ^ var.var_id ^ " type")
- ~printer:string_of_var_type
- var_type
- var.var_dec_type.ty_dec_desc;
- match var.var_dec_value with
- | Some { expr_desc = d } ->
- assert_equal
- ~msg:("problem with variable " ^ var.var_id ^ " value")
- ~printer:string_of_var_value
- value
- d
- | _ -> raise (OUnitTest.OUnit_failure
- "User variables should have an initial value")
- end
+ ~msg:("problem with variable " ^ var.var_id ^ " value")
+ ~printer:string_of_var_value value d
+ | _ ->
+ raise
+ (OUnitTest.OUnit_failure "User variables should have an initial value")
let test_simple_var_bool_false tests_ctxt =
- let prog = Parse.parse_prog
- (Yojson.Basic.from_file "../data-test/simple-var-bool-false.json") in
+ let prog =
+ Parse.parse_prog
+ (Yojson.Basic.from_file "../data-test/simple-var-bool-false.json")
+ in
match prog with
- | Program ("simple_var_bool_false", [ ], [ x ]) ->
- test_var_skeleton x "my_bool_var_false"
- Tydec_bool (Expr_const (Const_tag tag_false))
- | _ -> raise (OUnitTest.OUnit_failure
- "Program obtained from simple-var-bool-false.json is not correct")
+ | Program ("simple_var_bool_false", [], [ x ]) ->
+ test_var_skeleton x "my_bool_var_false" Tydec_bool
+ (Expr_const (Const_tag tag_false))
+ | _ ->
+ raise
+ (OUnitTest.OUnit_failure
+ "Program obtained from simple-var-bool-false.json is not correct")
let test_simple_var_bool_true tests_ctxt =
- let prog = Parse.parse_prog
- (Yojson.Basic.from_file "../data-test/simple-var-bool-true.json") in
+ let prog =
+ Parse.parse_prog
+ (Yojson.Basic.from_file "../data-test/simple-var-bool-true.json")
+ in
match prog with
- | Program ("simple_var_bool_true", [ ], [ x ]) ->
- test_var_skeleton x "my_bool_var_true"
- Tydec_bool (Expr_const (Const_tag tag_true))
- | _ -> raise (OUnitTest.OUnit_failure
- "Program obtained from simple-var-bool-true.json is not correct")
+ | Program ("simple_var_bool_true", [], [ x ]) ->
+ test_var_skeleton x "my_bool_var_true" Tydec_bool
+ (Expr_const (Const_tag tag_true))
+ | _ ->
+ raise
+ (OUnitTest.OUnit_failure
+ "Program obtained from simple-var-bool-true.json is not correct")
let test_simple_var_int_zero tests_ctxt =
- let prog = Parse.parse_prog
- (Yojson.Basic.from_file "../data-test/simple-var-int-zero.json") in
+ let prog =
+ Parse.parse_prog
+ (Yojson.Basic.from_file "../data-test/simple-var-int-zero.json")
+ in
match prog with
- | Program ("simple_var_int_zero", [ ], [ x ]) ->
- test_var_skeleton x "my_int_var_zero"
- Tydec_int (Expr_const (Const_int 0))
- | _ -> raise (OUnitTest.OUnit_failure
- "Program obtained from simple-var-int-zero.json is not correct")
+ | Program ("simple_var_int_zero", [], [ x ]) ->
+ test_var_skeleton x "my_int_var_zero" Tydec_int (Expr_const (Const_int 0))
+ | _ ->
+ raise
+ (OUnitTest.OUnit_failure
+ "Program obtained from simple-var-int-zero.json is not correct")
let test_simple_var_int_pos tests_ctxt =
- let prog = Parse.parse_prog
- (Yojson.Basic.from_file "../data-test/simple-var-int-pos.json") in
+ let prog =
+ Parse.parse_prog
+ (Yojson.Basic.from_file "../data-test/simple-var-int-pos.json")
+ in
match prog with
- | Program ("simple_var_int_pos", [ ], [ x ]) ->
- test_var_skeleton x "my_int_var_pos"
- Tydec_int (Expr_const (Const_int 2))
- | _ -> raise (OUnitTest.OUnit_failure
- "Program obtained from simple-var-int-pos.json is not correct")
+ | Program ("simple_var_int_pos", [], [ x ]) ->
+ test_var_skeleton x "my_int_var_pos" Tydec_int (Expr_const (Const_int 2))
+ | _ ->
+ raise
+ (OUnitTest.OUnit_failure
+ "Program obtained from simple-var-int-pos.json is not correct")
let test_simple_var_int_neg tests_ctxt =
- let prog = Parse.parse_prog
- (Yojson.Basic.from_file "../data-test/simple-var-int-neg.json") in
+ let prog =
+ Parse.parse_prog
+ (Yojson.Basic.from_file "../data-test/simple-var-int-neg.json")
+ in
match prog with
- | Program ("simple_var_int_neg", [ ], [ x ]) ->
- test_var_skeleton x "my_int_var_neg"
- Tydec_int (Expr_const (Const_int (-5)))
- | _ -> raise (OUnitTest.OUnit_failure
- "Program obtained from simple-var-int-neg.json is not correct")
+ | Program ("simple_var_int_neg", [], [ x ]) ->
+ test_var_skeleton x "my_int_var_neg" Tydec_int (Expr_const (Const_int (-5)))
+ | _ ->
+ raise
+ (OUnitTest.OUnit_failure
+ "Program obtained from simple-var-int-neg.json is not correct")
let test_simple_var_real_zero tests_ctxt =
- let prog = Parse.parse_prog
- (Yojson.Basic.from_file "../data-test/simple-var-real-zero.json") in
+ let prog =
+ Parse.parse_prog
+ (Yojson.Basic.from_file "../data-test/simple-var-real-zero.json")
+ in
match prog with
- | Program ("simple_var_real_zero", [ ], [ x ]) ->
- test_var_skeleton x "my_real_var_zero"
- Tydec_real (Expr_const (Const_real (Num.num_of_int 0, 1, "0.0")))
- | _ -> raise (OUnitTest.OUnit_failure
- "Program obtained from simple-var-real-zero.json is not correct")
+ | Program ("simple_var_real_zero", [], [ x ]) ->
+ test_var_skeleton x "my_real_var_zero" Tydec_real
+ (Expr_const (Const_real (Num.num_of_int 0, 1, "0.0")))
+ | _ ->
+ raise
+ (OUnitTest.OUnit_failure
+ "Program obtained from simple-var-real-zero.json is not correct")
let test_simple_var_real_pos tests_ctxt =
- let prog = Parse.parse_prog
- (Yojson.Basic.from_file "../data-test/simple-var-real-pos.json") in
+ let prog =
+ Parse.parse_prog
+ (Yojson.Basic.from_file "../data-test/simple-var-real-pos.json")
+ in
match prog with
- | Program ("simple_var_real_pos", [ ], [ x ]) ->
- test_var_skeleton x "my_real_var_pos"
- Tydec_real (Expr_const (Const_real (Num.num_of_int 2115, 2, "21.15")))
- | _ -> raise (OUnitTest.OUnit_failure
- "Program obtained from simple-var-real-pos.json is not correct")
+ | Program ("simple_var_real_pos", [], [ x ]) ->
+ test_var_skeleton x "my_real_var_pos" Tydec_real
+ (Expr_const (Const_real (Num.num_of_int 2115, 2, "21.15")))
+ | _ ->
+ raise
+ (OUnitTest.OUnit_failure
+ "Program obtained from simple-var-real-pos.json is not correct")
let test_simple_var_real_neg tests_ctxt =
- let prog = Parse.parse_prog
- (Yojson.Basic.from_file "../data-test/simple-var-real-neg.json") in
+ let prog =
+ Parse.parse_prog
+ (Yojson.Basic.from_file "../data-test/simple-var-real-neg.json")
+ in
match prog with
- | Program ("simple_var_real_neg", [ ], [ x ]) ->
- test_var_skeleton x "my_real_var_neg"
- Tydec_real (Expr_const (Const_real (Num.num_of_int (-224), 2, "-2.24")))
- | _ -> raise (OUnitTest.OUnit_failure
- "Program obtained from simple-var-real-neg.json is not correct")
+ | Program ("simple_var_real_neg", [], [ x ]) ->
+ test_var_skeleton x "my_real_var_neg" Tydec_real
+ (Expr_const (Const_real (Num.num_of_int (-224), 2, "-2.24")))
+ | _ ->
+ raise
+ (OUnitTest.OUnit_failure
+ "Program obtained from simple-var-real-neg.json is not correct")
let test_simple_var_real_e tests_ctxt =
- let prog = Parse.parse_prog
- (Yojson.Basic.from_file "../data-test/simple-var-real-e.json") in
+ let prog =
+ Parse.parse_prog
+ (Yojson.Basic.from_file "../data-test/simple-var-real-e.json")
+ in
match prog with
- | Program ("simple_var_real_e", [ ], [ x ]) ->
- test_var_skeleton x "my_real_var_e"
- Tydec_real (Expr_const (Const_real (Num.num_of_int (-2115), 4, "-21.15e-02")))
- | _ -> raise (OUnitTest.OUnit_failure
- "Program obtained from simple-var-real-e.json is not correct")
+ | Program ("simple_var_real_e", [], [ x ]) ->
+ test_var_skeleton x "my_real_var_e" Tydec_real
+ (Expr_const (Const_real (Num.num_of_int (-2115), 4, "-21.15e-02")))
+ | _ ->
+ raise
+ (OUnitTest.OUnit_failure
+ "Program obtained from simple-var-real-e.json is not correct")
let test_simple_var_real_wo_dec tests_ctxt =
- assert_raises (Parse.JSON_parse_error("Invalid real constant 2500"))
- (fun _ -> Parse.parse_prog (Yojson.Basic.from_file
- "../data-test/simple-var-real-wo-dec.json"))
+ assert_raises (Parse.JSON_parse_error "Invalid real constant 2500") (fun _ ->
+ Parse.parse_prog
+ (Yojson.Basic.from_file "../data-test/simple-var-real-wo-dec.json"))
let var_suite =
- "suite for variables" >:::
- [ "simple test for variable (boolean, false)" >::
- test_simple_var_bool_false;
- "simple test for variable (boolean, true)" >::
- test_simple_var_bool_true;
- "simple test for variable (int, 0)" >::
- test_simple_var_int_zero;
- "simple test for variable (int, 2)" >::
- test_simple_var_int_pos;
- "simple test for variable (int, -5)" >::
- test_simple_var_int_neg;
- "simple test for variable (real, 0.0)" >::
- test_simple_var_real_zero;
- "simple test for variable (real, 21.15)" >::
- test_simple_var_real_pos;
- "simple test for variable (real, -2.24)" >::
- test_simple_var_real_neg;
- "simple test for variable (real, -21.15e-02)" >::
- test_simple_var_real_e;
- "simple test for variable (real, 2500)" >::
- test_simple_var_real_wo_dec;
- ]
-
-let _ =
- run_test_tt_main var_suite
+ "suite for variables"
+ >::: [
+ "simple test for variable (boolean, false)"
+ >:: test_simple_var_bool_false;
+ "simple test for variable (boolean, true)"
+ >:: test_simple_var_bool_true;
+ "simple test for variable (int, 0)" >:: test_simple_var_int_zero;
+ "simple test for variable (int, 2)" >:: test_simple_var_int_pos;
+ "simple test for variable (int, -5)" >:: test_simple_var_int_neg;
+ "simple test for variable (real, 0.0)" >:: test_simple_var_real_zero;
+ "simple test for variable (real, 21.15)" >:: test_simple_var_real_pos;
+ "simple test for variable (real, -2.24)" >:: test_simple_var_real_neg;
+ "simple test for variable (real, -21.15e-02)"
+ >:: test_simple_var_real_e;
+ "simple test for variable (real, 2500)" >:: test_simple_var_real_wo_dec;
+ ]
+
+let _ = run_test_tt_main var_suite
diff --git a/src/tools/stateflow/models/model_medium.ml b/src/tools/stateflow/models/model_medium.ml
index d2d118a8791aff27ee4f10fa36a64908c0150e47..b07930cbe6515a008550220d586645db3951eb3d 100644
--- a/src/tools/stateflow/models/model_medium.ml
+++ b/src/tools/stateflow/models/model_medium.ml
@@ -3,88 +3,102 @@ open SF
let name = "medium"
-let condition x = condition (Corelang.mkexpr Location.dummy_loc (LustreSpec.Expr_const (Corelang.const_of_bool true)))
+let condition x =
+ condition
+ (Corelang.mkexpr Location.dummy_loc
+ (LustreSpec.Expr_const (Corelang.const_of_bool true)))
let model : prog_t =
- let state_main = "main" in
- let state_a = "a" in
- let state_a1 = "a1" in
- let state_b = "b" in
+ let state_main = "main" in
+ let state_a = "a" in
+ let state_a1 = "a1" in
+ let state_b = "b" in
- let actions_main = state_action (action "emain") (action "dmain") (action "xmain") in
- let actions_a = state_action (action "eA") (action "dA") (action "xA") in
- let actions_a1 = state_action (action "eA1") (action "dA1") (action "xA1") in
- let actions_b = state_action (action "eB") (action "dB") (action "xB") in
+ let actions_main =
+ state_action (action "emain") (action "dmain") (action "xmain")
+ in
+ let actions_a = state_action (action "eA") (action "dA") (action "xA") in
+ let actions_a1 = state_action (action "eA1") (action "dA1") (action "xA1") in
+ let actions_b = state_action (action "eB") (action "dB") (action "xB") in
- let tA = {
+ let tA =
+ {
event = no_event;
condition = condition "cond_tA";
condition_act = action "condact_tA";
transition_act = action "transact_tA";
- dest = DPath [state_main;state_a];
+ dest = DPath [ state_main; state_a ];
}
- in
- let tJ = {
+ in
+ let tJ =
+ {
event = no_event;
condition = condition "cond_tJ";
condition_act = action "condact_tJ";
transition_act = action "transact_tJ";
dest = DJunction "jmid";
}
- in
- let tB = {
+ in
+ let tB =
+ {
event = no_event;
condition = condition "cond_tB";
condition_act = action "condact_tB";
transition_act = action "transact_tB";
- dest = DPath [state_main;state_b];
+ dest = DPath [ state_main; state_b ];
}
- in
- let tA1 = {
+ in
+ let tA1 =
+ {
event = no_event;
condition = condition "cond_tA1";
condition_act = action "condact_tA1";
transition_act = action "transact_tA1";
- dest = DPath [state_main;state_a;state_a1];
+ dest = DPath [ state_main; state_a; state_a1 ];
}
- in
+ in
-
- let def_a = {
+ let def_a =
+ {
state_actions = actions_a;
- outer_trans = [tJ];
+ outer_trans = [ tJ ];
inner_trans = [];
- internal_composition = Or ([tA1], [state_a1])
+ internal_composition = Or ([ tA1 ], [ state_a1 ]);
}
- in
- let def_a1 = {
+ in
+ let def_a1 =
+ {
state_actions = actions_a1;
- outer_trans = [tB];
+ outer_trans = [ tB ];
inner_trans = [];
- internal_composition = Or ([], [])
+ internal_composition = Or ([], []);
}
- in
- let def_b = {
+ in
+ let def_b =
+ {
state_actions = actions_b;
- outer_trans = [tA1];
+ outer_trans = [ tA1 ];
inner_trans = [];
- internal_composition = Or ([], [])
+ internal_composition = Or ([], []);
}
- in
- let def_main = {
+ in
+ let def_main =
+ {
state_actions = actions_main;
outer_trans = [];
inner_trans = [];
- internal_composition = Or ([tA], [state_a; state_b])
+ internal_composition = Or ([ tA ], [ state_a; state_b ]);
}
- in
- let src = [State([state_main;state_a], def_a);
- State([state_main;state_a;state_a1], def_a1);
- State([state_main;state_b], def_b);
- State([state_main], def_main);
- Junction("jmid", [tB]);
- ]
- in
- Program (state_main, src, [])
+ in
+ let src =
+ [
+ State ([ state_main; state_a ], def_a);
+ State ([ state_main; state_a; state_a1 ], def_a1);
+ State ([ state_main; state_b ], def_b);
+ State ([ state_main ], def_main);
+ Junction ("jmid", [ tB ]);
+ ]
+ in
+ Program (state_main, src, [])
-let traces : trace_t list = [[None; None]]
+let traces : trace_t list = [ [ None; None ] ]
diff --git a/src/tools/stateflow/models/model_simple.ml b/src/tools/stateflow/models/model_simple.ml
index 83d940992fe2bbf5726ac2522262619a603d6b37..729f8f6262e324be6e837c4e4a7cf8c594f93360 100644
--- a/src/tools/stateflow/models/model_simple.ml
+++ b/src/tools/stateflow/models/model_simple.ml
@@ -4,86 +4,100 @@ open SF
let name = "simple"
-let condition _ = condition {
- expr = Corelang.mkexpr Location.dummy_loc (Lustre_types.Expr_const (Corelang.const_of_bool true));
- cinputs = [];
- coutputs = [];
- cvariables = [];
-}
-
- let action _ = no_action
+let condition _ =
+ condition
+ {
+ expr =
+ Corelang.mkexpr Location.dummy_loc
+ (Lustre_types.Expr_const (Corelang.const_of_bool true));
+ cinputs = [];
+ coutputs = [];
+ cvariables = [];
+ }
+
+let action _ = no_action
let model : prog_t =
- let state_main = "main" in
- let state_a = "a" in
- let state_a1 = "a1" in
- let state_b = "b" in
+ let state_main = "main" in
+ let state_a = "a" in
+ let state_a1 = "a1" in
+ let state_b = "b" in
- let actions_main = state_action (action "emain") (action "dmain") (action "xmain") in
- let actions_a = state_action (action "eA") (action "dA") (action "xA") in
- let actions_a1 = state_action (action "eA1") (action "dA1") (action "xA1") in
- let actions_b = state_action (action "eB") (action "dB") (action "xB") in
+ let actions_main =
+ state_action (action "emain") (action "dmain") (action "xmain")
+ in
+ let actions_a = state_action (action "eA") (action "dA") (action "xA") in
+ let actions_a1 = state_action (action "eA1") (action "dA1") (action "xA1") in
+ let actions_b = state_action (action "eB") (action "dB") (action "xB") in
- let tA = {
+ let tA =
+ {
event = no_event;
condition = condition "cond_tA";
condition_act = action "condact_tA";
transition_act = action "transact_tA";
- dest = DPath [state_main;state_a];
+ dest = DPath [ state_main; state_a ];
}
- in
- let tB = {
+ in
+ let tB =
+ {
event = no_event;
condition = condition "cond_tB";
condition_act = action "condact_tB";
transition_act = action "transact_tB";
- dest = DPath [state_main;state_b];
+ dest = DPath [ state_main; state_b ];
}
- in
- let tA1 = {
+ in
+ let tA1 =
+ {
event = no_event;
condition = condition "cond_tA1";
condition_act = action "condact_tA1";
transition_act = action "transact_tA1";
- dest = DPath [state_main;state_a;state_a1];
+ dest = DPath [ state_main; state_a; state_a1 ];
}
- in
-
+ in
- let def_a = {
+ let def_a =
+ {
state_actions = actions_a;
- outer_trans = [tB];
+ outer_trans = [ tB ];
inner_trans = [];
- internal_composition = Or ([tA1], [state_a1])
+ internal_composition = Or ([ tA1 ], [ state_a1 ]);
}
- in
- let def_a1 = {
+ in
+ let def_a1 =
+ {
state_actions = actions_a1;
- outer_trans = [tB];
+ outer_trans = [ tB ];
inner_trans = [];
- internal_composition = Or ([], [])
+ internal_composition = Or ([], []);
}
- in
- let def_b = {
+ in
+ let def_b =
+ {
state_actions = actions_b;
- outer_trans = [tA1];
+ outer_trans = [ tA1 ];
inner_trans = [];
- internal_composition = Or ([], [])
+ internal_composition = Or ([], []);
}
- in
- let def_main = {
+ in
+ let def_main =
+ {
state_actions = actions_main;
outer_trans = [];
inner_trans = [];
- internal_composition = Or ([tA], [state_a; state_b])
+ internal_composition = Or ([ tA ], [ state_a; state_b ]);
}
- in
- let src = [State([state_main;state_a], def_a);
- State([state_main;state_a;state_a1], def_a1);
- State([state_main;state_b], def_b);
- State([state_main], def_main);
- ]
- in
- Program (state_main, src, [])
+ in
+ let src =
+ [
+ State ([ state_main; state_a ], def_a);
+ State ([ state_main; state_a; state_a1 ], def_a1);
+ State ([ state_main; state_b ], def_b);
+ State ([ state_main ], def_main);
+ ]
+ in
+ Program (state_main, src, [])
-let traces : trace_t list = [[None; None]]
+let traces : trace_t list = [ [ None; None ] ]
diff --git a/src/tools/stateflow/models/model_stopwatch.ml b/src/tools/stateflow/models/model_stopwatch.ml
index 2e1d6cd1021195e35a7aa0a08df0c9567329ee1d..098cf377c232f88a205c5fdb3969805fa481c5a6 100644
--- a/src/tools/stateflow/models/model_stopwatch.ml
+++ b/src/tools/stateflow/models/model_stopwatch.ml
@@ -1,278 +1,319 @@
open Datatype
open Basetypes
+
(* open Transformer2 *)
open SF
let verbose = false
-let actionv _ = no_action (*TODO if verbose then action x else no_action*)
-let action _ = no_action (* TODO *)
-let condition _ = condition {
- expr = Corelang.mkexpr Location.dummy_loc (Lustre_types.Expr_const (Corelang.const_of_bool true));
- cinputs = [];
- coutputs = [];
- cvariables = [];
-}
+
+let actionv _ = no_action
+(*TODO if verbose then action x else no_action*)
+
+let action _ = no_action
+(* TODO *)
+
+let condition _ =
+ condition
+ {
+ expr =
+ Corelang.mkexpr Location.dummy_loc
+ (Lustre_types.Expr_const (Corelang.const_of_bool true));
+ cinputs = [];
+ coutputs = [];
+ cvariables = [];
+ }
+
let name = "stopwatch"
let model =
- let smain = "main" in
- let sstop = "stop" in
- let sreset = "reset" in
+ let smain = "main" in
+ let sstop = "stop" in
+ let sreset = "reset" in
let slapstop = "lap_stop" in
- let srun = "run" in
+ let srun = "run" in
let srunning = "running" in
- let slap = "lap" in
+ let slap = "lap" in
- let tinitstop = {
- event = no_event;
- condition = no_condition;
- condition_act = actionv "ac_cond_init_stop";
- transition_act = actionv "ac_trans_init_stop";
- dest = DPath [smain;sstop];
- }
+ let tinitstop =
+ {
+ event = no_event;
+ condition = no_condition;
+ condition_act = actionv "ac_cond_init_stop";
+ transition_act = actionv "ac_trans_init_stop";
+ dest = DPath [ smain; sstop ];
+ }
in
- let tinitreset = {
- event = no_event;
- condition = no_condition;
- condition_act = actionv "ac_cond_init_reset";
- transition_act = actionv "ac_cond_init_stop";
- dest = DPath [smain;sstop;sreset];
- }
+ let tinitreset =
+ {
+ event = no_event;
+ condition = no_condition;
+ condition_act = actionv "ac_cond_init_reset";
+ transition_act = actionv "ac_cond_init_stop";
+ dest = DPath [ smain; sstop; sreset ];
+ }
in
- let treset = {
- event = event "LAP";
- condition = no_condition;
- condition_act = action "reset counter";
- transition_act = actionv "ac_trans_reset_junction";
- dest = DJunction "jreset" (* [smain;sstop;sreset]; ou bien mettre une junction. Verifier
- si il y a des effets de bords non
- desirés de fermeture/ouverture de
- noeud *)
- }
+ let treset =
+ {
+ event = event "LAP";
+ condition = no_condition;
+ condition_act = action "reset counter";
+ transition_act = actionv "ac_trans_reset_junction";
+ dest =
+ DJunction "jreset"
+ (* [smain;sstop;sreset]; ou bien mettre une junction. Verifier si il y a
+ des effets de bords non desirés de fermeture/ouverture de noeud *);
+ }
in
- let treset_start = {
- event = event "START";
- condition = no_condition;
- condition_act = actionv "ac_cond_reset->running";
- transition_act = actionv "ac_trans_reset->running";
- dest = DPath [smain;srun;srunning];
- }
+ let treset_start =
+ {
+ event = event "START";
+ condition = no_condition;
+ condition_act = actionv "ac_cond_reset->running";
+ transition_act = actionv "ac_trans_reset->running";
+ dest = DPath [ smain; srun; srunning ];
+ }
in
- let tlapstop_lap = {
- event = event "LAP";
- condition = no_condition;
- condition_act = actionv "ac_cond_lap_stop->reset";
- transition_act = actionv "ac_trans_lap_stop->reset";
- dest = DPath [smain;sstop;sreset];
- }
+ let tlapstop_lap =
+ {
+ event = event "LAP";
+ condition = no_condition;
+ condition_act = actionv "ac_cond_lap_stop->reset";
+ transition_act = actionv "ac_trans_lap_stop->reset";
+ dest = DPath [ smain; sstop; sreset ];
+ }
in
- let tlapstop_start = {
- event = event "START";
- condition = no_condition;
- condition_act = actionv "ac_cond_lap_stop->lap";
- transition_act = actionv "ac_trans_lap_stop->lap";
- dest = DPath [smain;srun;slap];
- }
+ let tlapstop_start =
+ {
+ event = event "START";
+ condition = no_condition;
+ condition_act = actionv "ac_cond_lap_stop->lap";
+ transition_act = actionv "ac_trans_lap_stop->lap";
+ dest = DPath [ smain; srun; slap ];
+ }
in
- let ttic = {
- event = event "TIC";
- condition = no_condition;
- condition_act = action "cent+=1";
- transition_act = actionv "ac_trans_->J1";
- dest = DJunction "j1";
- }
+ let ttic =
+ {
+ event = event "TIC";
+ condition = no_condition;
+ condition_act = action "cent+=1";
+ transition_act = actionv "ac_trans_->J1";
+ dest = DJunction "j1";
+ }
in
- let trunning_start = {
- event = event "START";
- condition = no_condition;
- condition_act = actionv "ac_cond_running->reset";
- transition_act = actionv "ac_trans_running->reset";
- dest = DPath [smain;sstop;sreset];
- }
+ let trunning_start =
+ {
+ event = event "START";
+ condition = no_condition;
+ condition_act = actionv "ac_cond_running->reset";
+ transition_act = actionv "ac_trans_running->reset";
+ dest = DPath [ smain; sstop; sreset ];
+ }
in
- let tlap_start = {
- event = event "START";
- condition = no_condition;
- condition_act = actionv "ac_cond_lap->lap_stop";
- transition_act = actionv "ac_trans_lap->lap_stop";
- dest = DPath [smain;sstop;slapstop];
- }
+ let tlap_start =
+ {
+ event = event "START";
+ condition = no_condition;
+ condition_act = actionv "ac_cond_lap->lap_stop";
+ transition_act = actionv "ac_trans_lap->lap_stop";
+ dest = DPath [ smain; sstop; slapstop ];
+ }
in
- let tlap_lap = {
- event = event "LAP";
- condition = no_condition;
- condition_act = actionv "ac_cond_lap->running";
- transition_act = actionv "ac_trans_lap->running";
- dest = DPath [smain;srun;srunning];
- }
+ let tlap_lap =
+ {
+ event = event "LAP";
+ condition = no_condition;
+ condition_act = actionv "ac_cond_lap->running";
+ transition_act = actionv "ac_trans_lap->running";
+ dest = DPath [ smain; srun; srunning ];
+ }
in
- let trunning_lap = {
- event = event "LAP";
- condition = no_condition;
- condition_act = actionv "ac_cond_running->lap";
- transition_act = actionv "ac_trans_running->lap";
- dest = DPath [smain;srun;slap];
- }
+ let trunning_lap =
+ {
+ event = event "LAP";
+ condition = no_condition;
+ condition_act = actionv "ac_cond_running->lap";
+ transition_act = actionv "ac_trans_running->lap";
+ dest = DPath [ smain; srun; slap ];
+ }
in
- let tj1j2 = {
- event = no_event;
- condition = condition "cent==100";
- condition_act = action "cont=0;sec+=1";
- transition_act = actionv "ac_trans_J1->J2";
- dest = DJunction "j2";
- }
+ let tj1j2 =
+ {
+ event = no_event;
+ condition = condition "cent==100";
+ condition_act = action "cont=0;sec+=1";
+ transition_act = actionv "ac_trans_J1->J2";
+ dest = DJunction "j2";
+ }
in
- let tj1j3 = {
- event = no_event;
- condition = condition "cent!=100";
- condition_act = actionv "ac_cond_J1->J3";
- transition_act = actionv "ac_trans_J1->J3";
- dest = DJunction "j3";
- }
+ let tj1j3 =
+ {
+ event = no_event;
+ condition = condition "cent!=100";
+ condition_act = actionv "ac_cond_J1->J3";
+ transition_act = actionv "ac_trans_J1->J3";
+ dest = DJunction "j3";
+ }
in
- let tj2j3gauche = {
- event = no_event;
- condition = condition "sec!=60";
- condition_act = actionv "ac_cond_J2->J3_left";
- transition_act = actionv "ac_trans_J2->J3_left";
- dest = DJunction "j3";
- }
+ let tj2j3gauche =
+ {
+ event = no_event;
+ condition = condition "sec!=60";
+ condition_act = actionv "ac_cond_J2->J3_left";
+ transition_act = actionv "ac_trans_J2->J3_left";
+ dest = DJunction "j3";
+ }
in
- let tj2j3droite = {
- event = no_event;
- condition = condition "sec==60";
- condition_act = action "sec=0; min+=1";
- transition_act = actionv "ac_trans_J2->J3_right";
- dest = (*DPath [smain;srun];*) DJunction "j3";
- }
+ let tj2j3droite =
+ {
+ event = no_event;
+ condition = condition "sec==60";
+ condition_act = action "sec=0; min+=1";
+ transition_act = actionv "ac_trans_J2->J3_right";
+ dest = (*DPath [smain;srun];*)
+ DJunction "j3";
+ }
in
- let def_main = {
- state_actions = {
- entry_act = actionv "ac_main_entry";
- during_act = actionv "ac_main_during";
- exit_act = actionv "ac_main_exit";
- };
- outer_trans = [];
- inner_trans = [];
- internal_composition = Or ([tinitstop], [sstop; srun])
- }
+ let def_main =
+ {
+ state_actions =
+ {
+ entry_act = actionv "ac_main_entry";
+ during_act = actionv "ac_main_during";
+ exit_act = actionv "ac_main_exit";
+ };
+ outer_trans = [];
+ inner_trans = [];
+ internal_composition = Or ([ tinitstop ], [ sstop; srun ]);
+ }
in
- let def_stop = {
- state_actions = {
- entry_act = actionv "ac_stop_entry";
- during_act = actionv "ac_stop_during";
- exit_act = actionv "ac_stop_exit";
- };
- outer_trans = [];
- inner_trans = [];
- internal_composition = Or ([tinitreset], [sreset; slapstop])
- }
+ let def_stop =
+ {
+ state_actions =
+ {
+ entry_act = actionv "ac_stop_entry";
+ during_act = actionv "ac_stop_during";
+ exit_act = actionv "ac_stop_exit";
+ };
+ outer_trans = [];
+ inner_trans = [];
+ internal_composition = Or ([ tinitreset ], [ sreset; slapstop ]);
+ }
in
- let def_reset = {
- state_actions = {
- entry_act = actionv "ac_reset_entry";
- during_act = actionv "ac_reset_during";
- exit_act = actionv "ac_reset_exit";
- };
- outer_trans = [treset_start];
- inner_trans = [treset];
- internal_composition = Or ([treset_start], [])
- }
+ let def_reset =
+ {
+ state_actions =
+ {
+ entry_act = actionv "ac_reset_entry";
+ during_act = actionv "ac_reset_during";
+ exit_act = actionv "ac_reset_exit";
+ };
+ outer_trans = [ treset_start ];
+ inner_trans = [ treset ];
+ internal_composition = Or ([ treset_start ], []);
+ }
in
- let def_lapstop = {
- state_actions = {
- entry_act = actionv "ac_lapstop_entry";
- during_act = actionv "ac_lapstop_during";
- exit_act = actionv "ac_lapstop_exit";
- };
- outer_trans = [tlapstop_lap; tlapstop_start];
- inner_trans = [];
- internal_composition = Or ([], [])
- }
+ let def_lapstop =
+ {
+ state_actions =
+ {
+ entry_act = actionv "ac_lapstop_entry";
+ during_act = actionv "ac_lapstop_during";
+ exit_act = actionv "ac_lapstop_exit";
+ };
+ outer_trans = [ tlapstop_lap; tlapstop_start ];
+ inner_trans = [];
+ internal_composition = Or ([], []);
+ }
in
- let def_run = {
- state_actions = {
- entry_act = actionv "ac_run_entry";
- during_act = actionv "ac_run_during";
- exit_act = actionv "ac_run_exit";
- };
- outer_trans = [];
- inner_trans = [ttic];
- internal_composition = Or ([], [srunning; slap])
- }
+ let def_run =
+ {
+ state_actions =
+ {
+ entry_act = actionv "ac_run_entry";
+ during_act = actionv "ac_run_during";
+ exit_act = actionv "ac_run_exit";
+ };
+ outer_trans = [];
+ inner_trans = [ ttic ];
+ internal_composition = Or ([], [ srunning; slap ]);
+ }
in
- let def_running = {
- state_actions = {
- entry_act = actionv "ac_running_entry";
- during_act = action "disp=(cent,sec,min)";
- exit_act = actionv "ac_running_exit";
- };
- outer_trans = [trunning_start; trunning_lap];
- inner_trans = [];
- internal_composition = Or ([], [])
- }
+ let def_running =
+ {
+ state_actions =
+ {
+ entry_act = actionv "ac_running_entry";
+ during_act = action "disp=(cent,sec,min)";
+ exit_act = actionv "ac_running_exit";
+ };
+ outer_trans = [ trunning_start; trunning_lap ];
+ inner_trans = [];
+ internal_composition = Or ([], []);
+ }
in
- let def_lap = {
- state_actions = {
- entry_act = actionv "ac_lap_entry";
- during_act = actionv "ac_lap_during";
- exit_act = actionv "ac_lap_exit";
- };
- outer_trans = [tlap_start; tlap_lap];
- inner_trans = [];
- internal_composition = Or ([], [])
- }
+ let def_lap =
+ {
+ state_actions =
+ {
+ entry_act = actionv "ac_lap_entry";
+ during_act = actionv "ac_lap_during";
+ exit_act = actionv "ac_lap_exit";
+ };
+ outer_trans = [ tlap_start; tlap_lap ];
+ inner_trans = [];
+ internal_composition = Or ([], []);
+ }
in
- let src = [
- State([smain;srun;srunning], def_running);
- State([smain;srun;slap], def_lap);
- State([smain;srun], def_run);
- State([smain;sstop;sreset], def_reset);
- State([smain;sstop;slapstop], def_lapstop);
- State([smain;sstop], def_stop);
- State([smain], def_main);
- Junction("jreset", []);
- Junction("j1", [tj1j2;tj1j3]);
- Junction("j2", [tj2j3droite; tj2j3gauche]);
- Junction("j3", []);
- ]
+ let src =
+ [
+ State ([ smain; srun; srunning ], def_running);
+ State ([ smain; srun; slap ], def_lap);
+ State ([ smain; srun ], def_run);
+ State ([ smain; sstop; sreset ], def_reset);
+ State ([ smain; sstop; slapstop ], def_lapstop);
+ State ([ smain; sstop ], def_stop);
+ State ([ smain ], def_main);
+ Junction ("jreset", []);
+ Junction ("j1", [ tj1j2; tj1j3 ]);
+ Junction ("j2", [ tj2j3droite; tj2j3gauche ]);
+ Junction ("j3", []);
+ ]
in
let globals =
let int_typ = Corelang.mktyp Location.dummy_loc Lustre_types.Tydec_int in
- List.map (fun k ->
- Corelang.mkvar_decl
- Location.dummy_loc
- (k, (* name *)
- int_typ, (* type *)
- Corelang.dummy_clock_dec, (* clock *)
- false, (* not a constant *)
- None, (* no default value *)
- None (* no parent known *)
- ),
- (* Default value is zero *)
- Corelang.mkexpr Location.dummy_loc (Lustre_types.Expr_const (Lustre_types.Const_int 0))
-
- )
- ["cent";
- "sec";
- "min";
- "cont"
- ]
+ List.map
+ (fun k ->
+ ( Corelang.mkvar_decl Location.dummy_loc
+ ( k,
+ (* name *)
+ int_typ,
+ (* type *)
+ Corelang.dummy_clock_dec,
+ (* clock *)
+ false,
+ (* not a constant *)
+ None,
+ (* no default value *)
+ None (* no parent known *) ),
+ (* Default value is zero *)
+ Corelang.mkexpr Location.dummy_loc
+ (Lustre_types.Expr_const (Lustre_types.Const_int 0)) ))
+ [ "cent"; "sec"; "min"; "cont" ]
in
Program (smain, src, globals)
let traces : trace_t list =
[
- [None; Some "TIC"; Some "START"; Some "TIC"; Some "TIC"];
- [None; Some "START"; Some "START"; Some "START"];
- [None; Some "START"; Some "TIC"; Some "START"; Some "TIC"]
+ [ None; Some "TIC"; Some "START"; Some "TIC"; Some "TIC" ];
+ [ None; Some "START"; Some "START"; Some "START" ];
+ [ None; Some "START"; Some "TIC"; Some "START"; Some "TIC" ];
]
diff --git a/src/tools/stateflow/semantics/cPS.ml b/src/tools/stateflow/semantics/cPS.ml
index 723887fabac2a17e0dfa259dc5b88cddc23295b1..4115b9aef386bf0da97d7d03f098139752eeb909 100644
--- a/src/tools/stateflow/semantics/cPS.ml
+++ b/src/tools/stateflow/semantics/cPS.ml
@@ -3,48 +3,61 @@ open Datatype
open CPS_transformer
open Theta
-module Semantics = functor (T: TransformerType) (M: MODEL_T) ->
-struct
-
-module Prog =
-struct
- let init, defs, state_vars, globals =
- let Program (init, defs, globals) = M.model in
- let state_vars = SF.states M.model in
- init, defs, state_vars, globals
-
-(*let _ = Format.printf "Model definitions@.%a@.####" Simulink.pp_src defs; () *)
-end
-
-
-module Interp = CPS_interpreter.Interpreter (T)
-module KenvTheta = KenvTheta (T)
-module Tables = KenvTheta.MemoThetaTables ()
-
-let eval ((modular_entry:bool), (modular_during:bool), (modular_exit:bool)) =
- let module Modularity : KenvTheta.ModularType =
- struct
- let modular : type b. (path_t, b, bool) tag_t -> path_t -> b =
- fun tag ->
- match tag with
- | E -> (fun _p _p' _f -> modular_entry)
- | D -> (fun _p -> modular_during)
- | X -> (fun _p _f -> modular_exit)
- end
- in
- let module Thetaify = KenvTheta.ModularThetaify (Tables) (Modularity) in
- let module EvalProg = Interp.Evaluation (Thetaify) (Prog) in
- (module EvalProg: Interp.EvaluationType)
-
-let compute modular =
- let module Eval = (val (eval modular)) in
- Eval.eval_prog
-
-let code_gen modular =
- let module Eval = (val (eval modular)) in
- let principal, components = Eval.eval_prog, Eval.eval_components in
- List.flatten (List.map (fun (c, tr) -> T.mkcomponent Ecall c tr) (components Ecall))@
- List.flatten (List.map (fun (c, tr) -> T.mkcomponent Dcall c tr) (components Dcall))@
- List.flatten (List.map (fun (c, tr) -> T.mkcomponent Xcall c tr) (components Xcall))@
- (T.mkprincipal principal)
-end
+module Semantics =
+functor
+ (T : TransformerType)
+ (M : MODEL_T)
+ ->
+ struct
+ module Prog = struct
+ let init, defs, state_vars, globals =
+ let (Program (init, defs, globals)) = M.model in
+ let state_vars = SF.states M.model in
+ init, defs, state_vars, globals
+
+ (*let _ = Format.printf "Model definitions@.%a@.####" Simulink.pp_src
+ defs; () *)
+ end
+
+ module Interp = CPS_interpreter.Interpreter (T)
+ module KenvTheta = KenvTheta (T)
+
+ module Tables = KenvTheta.MemoThetaTables ()
+
+ let eval
+ ((modular_entry : bool), (modular_during : bool), (modular_exit : bool))
+ =
+ let module Modularity : KenvTheta.ModularType = struct
+ let modular : type b. (path_t, b, bool) tag_t -> path_t -> b =
+ fun tag ->
+ match tag with
+ | E ->
+ fun _p _p' _f -> modular_entry
+ | D ->
+ fun _p -> modular_during
+ | X ->
+ fun _p _f -> modular_exit
+ end in
+ let module Thetaify = KenvTheta.ModularThetaify (Tables) (Modularity) in
+ let module EvalProg = Interp.Evaluation (Thetaify) (Prog) in
+ (module EvalProg : Interp.EvaluationType)
+
+ let compute modular =
+ let module Eval = (val eval modular) in
+ Eval.eval_prog
+
+ let code_gen modular =
+ let module Eval = (val eval modular) in
+ let principal, components = Eval.eval_prog, Eval.eval_components in
+ List.flatten
+ (List.map (fun (c, tr) -> T.mkcomponent Ecall c tr) (components Ecall))
+ @ List.flatten
+ (List.map
+ (fun (c, tr) -> T.mkcomponent Dcall c tr)
+ (components Dcall))
+ @ List.flatten
+ (List.map
+ (fun (c, tr) -> T.mkcomponent Xcall c tr)
+ (components Xcall))
+ @ T.mkprincipal principal
+ end
diff --git a/src/tools/stateflow/semantics/cPS_ccode_generator.ml b/src/tools/stateflow/semantics/cPS_ccode_generator.ml
index df96e3236184ffe076ba484dafff7ad75fb77313..bcead07f8bec78dde66e28f2c4a06cf58817fe10 100644
--- a/src/tools/stateflow/semantics/cPS_ccode_generator.ml
+++ b/src/tools/stateflow/semantics/cPS_ccode_generator.ml
@@ -1,25 +1,24 @@
open CPS_transformer
-module CodeGenerator : ComparableTransformerType =
-struct
+module CodeGenerator : ComparableTransformerType = struct
include TransformerStub
- type t =
- | Bot
- | Act of act_t
- | Seq of t list
- | Ite of cond_t * t * t
+ type t = Bot | Act of act_t | Seq of t list | Ite of cond_t * t * t
let null = Seq []
let bot = Bot
-
+
let ( >> ) tr1 tr2 =
match tr1, tr2 with
- | Seq trl1, Seq trl2 -> Seq (trl1@trl2)
- | Seq trl1, _ -> Seq (trl1@[tr2])
- | _ , Seq trl2 -> Seq (tr1::trl2)
- | _ -> Seq ([tr1;tr2])
+ | Seq trl1, Seq trl2 ->
+ Seq (trl1 @ trl2)
+ | Seq trl1, _ ->
+ Seq (trl1 @ [ tr2 ])
+ | _, Seq trl2 ->
+ Seq (tr1 :: trl2)
+ | _ ->
+ Seq [ tr1; tr2 ]
let ( == ) tr1 tr2 = tr1 = tr2
@@ -27,11 +26,12 @@ struct
(*Format.printf "----- action = %a@." Action.pp_act action;*)
Act action
- (*if (match trans.event with None -> true | _ -> e = trans.event) && trans.condition rho*)
+ (*if (match trans.event with None -> true | _ -> e = trans.event) &&
+ trans.condition rho*)
let eval_cond condition ok ko =
(*Format.printf "----- cond = %a@." Condition.pp_cond condition;*)
Ite (condition, ok, ko)
-
+
(* let rec pp_transformer fmt tr =
* match tr with
* | Bot -> Format.fprintf fmt "bot"
@@ -46,7 +46,7 @@ struct
(* let pp_principal fmt tr =
* Format.fprintf fmt "principal =@.%a" pp_transformer tr *)
-
+
(* let pp_component : type c. Format.formatter -> c call_t -> c -> t -> unit =
* fun fmt call -> match call with
* | Ecall -> (fun (p, p', f) tr ->
@@ -56,9 +56,8 @@ struct
* | Xcall -> (fun (p, f) tr ->
* Format.fprintf fmt "component %a(%a, %a) =@.@[<v 2>begin@ %a@]@.end" pp_call call pp_path p pp_frontier f pp_transformer tr) *)
- let mkcomponent _ = assert false
- let mkprincipal _ = assert false
- (* let mktransformer _ = assert false *)
-
-end
+ let mkcomponent _ = assert false
+ let mkprincipal _ = assert false
+ (* let mktransformer _ = assert false *)
+end
diff --git a/src/tools/stateflow/semantics/cPS_evaluator.ml b/src/tools/stateflow/semantics/cPS_evaluator.ml
index c15d501d9ab2e7932fec1dc141ea642873da7654..bc33cc99c09b8ab57ba0d0ef2ddc2dc1cfc0f133 100644
--- a/src/tools/stateflow/semantics/cPS_evaluator.ml
+++ b/src/tools/stateflow/semantics/cPS_evaluator.ml
@@ -1,125 +1,165 @@
- (* this file is no longer used. It contains the code that enable the use of
- the CPS to build an evaluator.
-
- Three pieces of code:
- - excerpt from the main that instanciate the functor to the evaluator and run the provided trace
- - run_trace function
- - Evaluator module
- *)
-
- let _main_ _ = function
- | Eval ->
- let module Model = (val model) in
- let module T = CPS_transformer.Evaluator in
- let module Sem = CPS.Semantics (T) (Model) in
- let nb_traces = List.length Model.traces in
- if nb_traces = 0 then
- failwith ("no available traces for model " ^ Model.name);
- if !trace_id >= 0 && !trace_id < nb_traces then
- let eval_func =
- match !eval_mode with
- | CPSEval ->
- fun (evt, env) ->
- let _, env', actions_performed = Sem.compute modularmode (evt, env, []) in
- env', actions_performed
- in
- run_trace Model.model eval_func (List.nth Model.traces !trace_id)
-
- else
- failwith (string_of_int !trace_id ^
- " is not a valid trace index in [0.." ^ string_of_int nb_traces ^ "]")
+(* this file is no longer used. It contains the code that enable the use of the
+ CPS to build an evaluator.
+ Three pieces of code: - excerpt from the main that instanciate the functor to
+ the evaluator and run the provided trace - run_trace function - Evaluator
+ module *)
+let _main_ _ = function
+ | Eval ->
+ let module Model = (val model) in
+ let module T = CPS_transformer.Evaluator in
+ let module Sem = CPS.Semantics (T) (Model) in
+ let nb_traces = List.length Model.traces in
+ if nb_traces = 0 then
+ failwith ("no available traces for model " ^ Model.name);
+ if !trace_id >= 0 && !trace_id < nb_traces then
+ let eval_func =
+ match !eval_mode with
+ | CPSEval ->
+ fun (evt, env) ->
+ let _, env', actions_performed =
+ Sem.compute modularmode (evt, env, [])
+ in
+ env', actions_performed
+ in
+ run_trace Model.model eval_func (List.nth Model.traces !trace_id)
+ else
+ failwith
+ (string_of_int !trace_id ^ " is not a valid trace index in [0.."
+ ^ string_of_int nb_traces ^ "]")
let run_trace model func t =
let init_env = Datatype.SF.init_env model in
- let _ = Format.printf "Model definitions@.%a@.Initial state: %s @.####" Datatype.SF.pp_src (snd model) (fst model) in
-
+ let _ =
+ Format.printf "Model definitions@.%a@.Initial state: %s @.####"
+ Datatype.SF.pp_src (snd model) (fst model)
+ in
+
let final_env, cpt =
- List.fold_left (fun (env, cpt) event ->
- Format.printf "#### %i@.%a@." cpt ActiveStates.Env.pp_env env;
- Format.printf "-- Event %a --@." Basetypes.pp_event event;
- let env', actions_performed = func (event, env) in
- let _ =
- match actions_performed with
- | [] -> Format.printf "-- no action performed --@."
- | _ -> (
- Format.printf "@[<v 2>-- action performed --@ ";
- List.iter (fun a -> Format.printf "%s@ " a) actions_performed;
- Format.printf "@]@."
- ) in
- (* we do not consider produced events *)
- env', cpt+1
- ) (init_env, 1) t
+ List.fold_left
+ (fun (env, cpt) event ->
+ Format.printf "#### %i@.%a@." cpt ActiveStates.Env.pp_env env;
+ Format.printf "-- Event %a --@." Basetypes.pp_event event;
+ let env', actions_performed = func (event, env) in
+ let _ =
+ match actions_performed with
+ | [] ->
+ Format.printf "-- no action performed --@."
+ | _ ->
+ Format.printf "@[<v 2>-- action performed --@ ";
+ List.iter (fun a -> Format.printf "%s@ " a) actions_performed;
+ Format.printf "@]@."
+ in
+ (* we do not consider produced events *)
+ env', cpt + 1)
+ (init_env, 1) t
in
Format.printf "#### %i@.%a@." cpt ActiveStates.Env.pp_env final_env;
()
+type truc = A of base_action_t | C of base_condition_t
- type truc = A of base_action_t | C of base_condition_t
-module Evaluator : TransformerType with type t = (event_t * bool ActiveStates.Env.t * truc list) -> (event_t * bool ActiveStates.Env.t * truc list ) =
-struct
+module Evaluator :
+ TransformerType
+ with type t =
+ event_t * bool ActiveStates.Env.t * truc list ->
+ event_t * bool ActiveStates.Env.t * truc list = struct
include TransformerStub
- type env_t = event_t * bool ActiveStates.Env.t * truc list (* Don't care for values yet *)
+
+ type env_t = event_t * bool ActiveStates.Env.t * truc list
+ (* Don't care for values yet *)
+
type t = env_t -> env_t
-
+
let null rho = rho
- let add_action a (evt, rho, al) = (evt, rho, al@[A a]) (* not very efficient but
- avoid to keep track of
- action order *)
- let add_condition c (evt, rho, al) = (evt, rho, al@[C c]) (* not very efficient but
- avoid to keep track of
- action order *)
+
+ let add_action a (evt, rho, al) = evt, rho, al @ [ A a ]
+ (* not very efficient but avoid to keep track of action order *)
+
+ let add_condition c (evt, rho, al) = evt, rho, al @ [ C c ]
+ (* not very efficient but avoid to keep track of action order *)
let bot _ = assert false
-
- let ( >> ) tr1 tr2 = fun rho -> rho |> tr1 |> tr2
+
+ let ( >> ) tr1 tr2 rho = rho |> tr1 |> tr2
let ( ?? ) b tr = if b then tr else null
- let eval_open p (evt, rho, al) = (evt, ActiveStates.Env.add p true rho, al)
- let eval_close p (evt, rho, al) = (evt, ActiveStates.Env.add p false rho, al)
- let eval_call : type c. (module ThetaType with type t = t) -> c call_t -> c -> t =
- fun kenv ->
- let module Theta = (val kenv : ThetaType with type t = t) in
- fun call -> match call with
- | Ecall -> (fun (p, p', f) -> Theta.theta E p p' f)
- | Dcall -> (fun p -> Theta.theta D p)
- | Xcall -> (fun (p, f) -> Theta.theta X p f)
+ let eval_open p (evt, rho, al) = evt, ActiveStates.Env.add p true rho, al
+
+ let eval_close p (evt, rho, al) = evt, ActiveStates.Env.add p false rho, al
+
+ let eval_call :
+ type c. (module ThetaType with type t = t) -> c call_t -> c -> t =
+ fun kenv ->
+ let module Theta = (val kenv : ThetaType with type t = t) in
+ fun call ->
+ match call with
+ | Ecall ->
+ fun (p, p', f) -> Theta.theta E p p' f
+ | Dcall ->
+ fun p -> Theta.theta D p
+ | Xcall ->
+ fun (p, f) -> Theta.theta X p f
let eval_act kenv action =
(* Format.printf "----- action = %a@." Action.pp_act action; *)
match action with
- | Action.Call (c, a) -> eval_call kenv c a
- | Action.Quote a -> add_action a
- | Action.Open p -> eval_open p
- | Action.Close p -> eval_close p
- | Action.Nil -> null
+ | Action.Call (c, a) ->
+ eval_call kenv c a
+ | Action.Quote a ->
+ add_action a
+ | Action.Open p ->
+ eval_open p
+ | Action.Close p ->
+ eval_close p
+ | Action.Nil ->
+ null
- (*if (match trans.event with None -> true | _ -> e = trans.event) && trans.condition rho*)
+ (*if (match trans.event with None -> true | _ -> e = trans.event) &&
+ trans.condition rho*)
let rec eval_cond condition ok ko : t =
(* Format.printf "----- cond = %a@." Condition.pp_cond condition; *)
match condition with
- | Condition.True -> ok
- | Condition.Active p -> (fun ((evt, env, al) as rho) -> if ActiveStates.Env.find p env then ok rho else ko rho)
- | Condition.Event e -> (fun ((evt, env, al) as rho) -> match evt with None -> ko rho | Some e' -> if e=e' then ok rho else ko rho)
- | Condition.Neg cond -> eval_cond cond ko ok
- | Condition.And (cond1, cond2) -> eval_cond cond1 (eval_cond cond2 ok ko) ko
- | Condition.Quote c -> add_condition c >> ok (* invalid behavior but similar to the other: should evaluate condition *)
+ | Condition.True ->
+ ok
+ | Condition.Active p ->
+ fun ((evt, env, al) as rho) ->
+ if ActiveStates.Env.find p env then ok rho else ko rho
+ | Condition.Event e -> (
+ fun ((evt, env, al) as rho) ->
+ match evt with
+ | None ->
+ ko rho
+ | Some e' ->
+ if e = e' then ok rho else ko rho)
+ | Condition.Neg cond ->
+ eval_cond cond ko ok
+ | Condition.And (cond1, cond2) ->
+ eval_cond cond1 (eval_cond cond2 ok ko) ko
+ | Condition.Quote c ->
+ add_condition c >> ok
+ (* invalid behavior but similar to the other: should evaluate condition *)
- let pp_transformer fmt tr =
- Format.fprintf fmt "<transformer>"
+ let pp_transformer fmt tr = Format.fprintf fmt "<transformer>"
let pp_principal fmt tr =
Format.fprintf fmt "principal =@.%a" pp_transformer tr
let pp_component : type c. Format.formatter -> c call_t -> c -> t -> unit =
- fun fmt call -> match call with
- | Ecall -> (fun (p, p', f) tr ->
- Format.fprintf fmt "component %a(%a, %a, %a) =@.%a" pp_call call pp_path p pp_path p' pp_frontier f pp_transformer tr)
- | Dcall -> (fun p tr ->
- Format.fprintf fmt "component %a(%a) =@.%a" pp_call call pp_path p pp_transformer tr)
- | Xcall -> (fun (p, f) tr ->
- Format.fprintf fmt "component %a(%a, %a) =@.%a" pp_call call pp_path p pp_frontier f pp_transformer tr)
+ fun fmt call ->
+ match call with
+ | Ecall ->
+ fun (p, p', f) tr ->
+ Format.fprintf fmt "component %a(%a, %a, %a) =@.%a" pp_call call pp_path
+ p pp_path p' pp_frontier f pp_transformer tr
+ | Dcall ->
+ fun p tr ->
+ Format.fprintf fmt "component %a(%a) =@.%a" pp_call call pp_path p
+ pp_transformer tr
+ | Xcall ->
+ fun (p, f) tr ->
+ Format.fprintf fmt "component %a(%a, %a) =@.%a" pp_call call pp_path p
+ pp_frontier f pp_transformer tr
end
-
diff --git a/src/tools/stateflow/semantics/cPS_interpreter.ml b/src/tools/stateflow/semantics/cPS_interpreter.ml
index f6a91d974f5cea5aa4d0a7da66f8292734da7675..493aeb592546049773b9a15755fb816c83d33630 100644
--- a/src/tools/stateflow/semantics/cPS_interpreter.ml
+++ b/src/tools/stateflow/semantics/cPS_interpreter.ml
@@ -1,227 +1,363 @@
open Basetypes
open Datatype
+
(* open ActiveEnv *)
open CPS_transformer
+
(* open Simulink *)
open Theta
-module Interpreter (Transformer : TransformerType) =
-struct
+module Interpreter (Transformer : TransformerType) = struct
module KT = KenvTheta (Transformer)
open KT
- let ( >? ) cond tr =
- if cond then tr else Transformer.null
+ let ( >? ) cond tr = if cond then tr else Transformer.null
- module type DenotationType =
- sig
+ module type DenotationType = sig
module Theta : MemoThetaType
- val eval_dest : destination_t -> Transformer.t wrapper_t -> Transformer.t success_t -> Transformer.t fail_t -> Transformer.t
- val eval_tau : trans_t -> Transformer.t wrapper_t -> Transformer.t success_t -> Transformer.t fail_t -> Transformer.t
- val eval_T : transitions_t -> Transformer.t wrapper_t -> Transformer.t success_t -> Transformer.t fail_t -> Transformer.t
- val eval_C : (path_t, 'b, Transformer.t) tag_t -> path_t -> composition_t -> Transformer.t
+ val eval_dest :
+ destination_t ->
+ Transformer.t wrapper_t ->
+ Transformer.t success_t ->
+ Transformer.t fail_t ->
+ Transformer.t
+
+ val eval_tau :
+ trans_t ->
+ Transformer.t wrapper_t ->
+ Transformer.t success_t ->
+ Transformer.t fail_t ->
+ Transformer.t
+
+ val eval_T :
+ transitions_t ->
+ Transformer.t wrapper_t ->
+ Transformer.t success_t ->
+ Transformer.t fail_t ->
+ Transformer.t
+
+ val eval_C :
+ (path_t, 'b, Transformer.t) tag_t ->
+ path_t ->
+ composition_t ->
+ Transformer.t
+
val eval_open_path : mode_t -> path_t -> path_t -> Transformer.t wrapper_t
- val eval_S : (path_t, 'b, Transformer.t) tag_t -> path_t -> state_def_t -> 'b
+
+ val eval_S :
+ (path_t, 'b, Transformer.t) tag_t -> path_t -> state_def_t -> 'b
end
- module type AbsDenotationType =
- sig
- val eval_dest : kenv_t -> destination_t -> Transformer.t wrapper_t -> Transformer.t success_t -> Transformer.t fail_t -> Transformer.t
- val eval_tau : kenv_t -> trans_t -> Transformer.t wrapper_t -> Transformer.t success_t -> Transformer.t fail_t -> Transformer.t
- val eval_T : kenv_t -> transitions_t -> Transformer.t wrapper_t -> Transformer.t success_t -> Transformer.t fail_t -> Transformer.t
- val eval_C : kenv_t -> (path_t, 'b, Transformer.t) tag_t -> path_t -> composition_t -> Transformer.t
- val eval_open_path : kenv_t -> mode_t -> path_t -> path_t -> Transformer.t wrapper_t
- val eval_S : kenv_t -> (path_t, 'b, Transformer.t) tag_t -> path_t -> state_def_t -> 'b
+ module type AbsDenotationType = sig
+ val eval_dest :
+ kenv_t ->
+ destination_t ->
+ Transformer.t wrapper_t ->
+ Transformer.t success_t ->
+ Transformer.t fail_t ->
+ Transformer.t
+
+ val eval_tau :
+ kenv_t ->
+ trans_t ->
+ Transformer.t wrapper_t ->
+ Transformer.t success_t ->
+ Transformer.t fail_t ->
+ Transformer.t
+
+ val eval_T :
+ kenv_t ->
+ transitions_t ->
+ Transformer.t wrapper_t ->
+ Transformer.t success_t ->
+ Transformer.t fail_t ->
+ Transformer.t
+
+ val eval_C :
+ kenv_t ->
+ (path_t, 'b, Transformer.t) tag_t ->
+ path_t ->
+ composition_t ->
+ Transformer.t
+
+ val eval_open_path :
+ kenv_t -> mode_t -> path_t -> path_t -> Transformer.t wrapper_t
+
+ val eval_S :
+ kenv_t -> (path_t, 'b, Transformer.t) tag_t -> path_t -> state_def_t -> 'b
end
- module AbstractKenv (Denot : functor (Kenv : KenvType) -> DenotationType) : AbsDenotationType =
- struct
+ module AbstractKenv (Denot : functor (Kenv : KenvType) -> DenotationType) :
+ AbsDenotationType = struct
let eval_dest kenv =
- let module Kenv =
- struct
- let kenv = kenv
- end in
+ let module Kenv = struct
+ let kenv = kenv
+ end in
let module D = Denot (Kenv) in
D.eval_dest
let eval_tau kenv =
- let module Kenv =
- struct
- let kenv = kenv
- end in
+ let module Kenv = struct
+ let kenv = kenv
+ end in
let module D = Denot (Kenv) in
D.eval_tau
let eval_T kenv =
- let module Kenv =
- struct
- let kenv = kenv
- end in
+ let module Kenv = struct
+ let kenv = kenv
+ end in
let module D = Denot (Kenv) in
D.eval_T
let eval_C kenv =
- let module Kenv =
- struct
- let kenv = kenv
- end in
+ let module Kenv = struct
+ let kenv = kenv
+ end in
let module D = Denot (Kenv) in
D.eval_C
let eval_open_path kenv =
- let module Kenv =
- struct
- let kenv = kenv
- end in
+ let module Kenv = struct
+ let kenv = kenv
+ end in
let module D = Denot (Kenv) in
D.eval_open_path
let eval_S kenv =
- let module Kenv =
- struct
- let kenv = kenv
- end in
+ let module Kenv = struct
+ let kenv = kenv
+ end in
let module D = Denot (Kenv) in
D.eval_S
end
- module Denotation : functor (Thetaify : ThetaifyType) (Kenv : KenvType) -> DenotationType =
- functor (Thetaify : ThetaifyType) (Kenv : KenvType) ->
- struct
- module Theta = Thetaify (Kenv)
-
- let eval_dest dest wrapper success fail =
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "@[<v 2>D[[%a]]@ " SF.pp_dest dest);
- match dest with
- | DPath p -> wrapper p (success p)
- | DJunction j -> Theta.theta J j wrapper success fail
-
- let eval_tau trans wrapper success fail =
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "@[<v 2>tau[[%a]]@ " SF.pp_trans trans);
- let success' p =
- Transformer.(success p >> eval_act (module Theta) trans.transition_act)
- in
- let cond = Transformer.(event trans.event && trans.condition) in
- Transformer.(eval_cond cond
- (eval_act (module Theta) trans.condition_act >> eval_dest trans.dest wrapper success' fail)
- fail.local)
-
- let rec eval_T tl wrapper success fail =
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "@[<v 2>T[[%a]]@ " SF.pp_transitions tl);
- match tl with
- | [] -> fail.global
- | t::[] -> eval_tau t wrapper success fail
- | t::tl ->
- let fail' = { fail with local = eval_T tl wrapper success fail } in
- eval_tau t wrapper success fail'
-
- let frontier path =
- match path with
- | [] -> [], []
- | t::q -> [t], q
-
- let rec eval_open_path mode p p1 p2 success_p2 =
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "@[<v 2>open_path_rec[[mode %a, prefix %a, src %a, dst %a]]@ " pp_mode mode pp_path p pp_path p1 pp_path p2);
- match frontier p1, frontier p2 with
- | ([x], ps), ([y], pd) when x = y -> eval_open_path mode (p@[x]) ps pd success_p2
- | (x , _ ), (y , pd) ->
- match mode with
- | Outer -> (Transformer.(Theta.theta X (p@x) Loose >> success_p2 >> Theta.theta E (p@y) pd Loose))
- | Inner -> (assert (x = []);
- Transformer.(Theta.theta X (p@x) Strict >> success_p2 >> Theta.theta E (p@y) pd Strict))
- | Enter -> (assert (x = [] && y <> []);
- Transformer.( success_p2 >> Theta.theta E (p@y) pd Loose))
-
- let rec eval_C : type a b. (a, b, Transformer.t) tag_t -> path_t -> composition_t -> Transformer.t =
- fun tag prefix comp ->
- match tag with
- | E -> Transformer.(
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "@[<v 2>C_%a[[%a, %a]]@ " pp_tag tag pp_path prefix SF.pp_comp comp);
- match comp with
- | Or (_T, []) -> null
- | Or ([], [s0]) -> eval_open_path Enter prefix [] [s0] null
- | Or (_T, _S) -> let wrapper = eval_open_path Enter [] prefix in
- let success _p_d = null in
- eval_T _T wrapper success { local = bot; global = bot }
- | And (_S) -> List.fold_right (fun p -> (>>) (Theta.theta E (prefix@[p]) [] Loose)) _S null
- )
- | D -> Transformer.(
- match comp with
- | Or (_T, []) -> null
- | Or (_T, p::_S) -> eval_cond (active (prefix@[p])) (Theta.theta D (prefix@[p])) (eval_C D prefix (Or (_T, _S)))
- | And (_S) -> List.fold_right (fun p -> (>>) (Theta.theta D (prefix@[p]))) _S null
- )
- | X -> Transformer.(
- match comp with
- | Or (_T, []) -> null
- | Or (_T, p::_S) -> eval_cond (active (prefix@[p])) (Theta.theta X (prefix@[p]) Loose) (eval_C X prefix (Or (_T, _S)))
- | And (_S) -> List.fold_right (fun p -> (>>) (Theta.theta X (prefix@[p]) Loose)) _S null
- )
- | J -> assert false
-
- let eval_S : type b. (path_t, b, Transformer.t) tag_t -> path_t -> state_def_t -> b =
- fun tag p p_def ->
- match tag with
- | E -> fun path frontier -> Transformer.(
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "@[<v 2>S_%a[[node %a, dest %a, frontier %a]]@ " pp_tag tag pp_path p pp_path path pp_frontier frontier);
- ((frontier = Loose) >? (eval_act (module Theta) p_def.state_actions.entry_act >> eval_act (module Theta) (open_path p))) >>
- match path with
- | [] -> eval_C E p p_def.internal_composition
- | s::path_tl -> Theta.theta E (p@[s]) path_tl Loose
- )
- | D -> Transformer.(
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "@[<v 2>S_%a[[node %a]]@ " pp_tag tag pp_path p);
- let wrapper_i = eval_open_path Inner [] p in
- let wrapper_o = eval_open_path Outer [] p in
- let success _p_d = null in
- let fail_o =
- let fail_i =
- let same_fail_C = eval_C D p p_def.internal_composition in
- { local = same_fail_C; global = same_fail_C }
- in
- let same_fail_i = eval_act (module Theta) p_def.state_actions.during_act >> eval_T p_def.inner_trans wrapper_i success fail_i in
- { local = same_fail_i; global = same_fail_i }
- in
- eval_T p_def.outer_trans wrapper_o success fail_o
- )
- | X -> fun frontier -> Transformer.(
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "@[<v 2>S_%a[[node %a, frontier %a]]@ " pp_tag tag pp_path p pp_frontier frontier);
- eval_C X p p_def.internal_composition >>
- ((frontier = Loose) >? (eval_act (module Theta) p_def.state_actions.exit_act >> eval_act (module Theta) (close_path p)))
- )
- end
+ module Denotation : functor (Thetaify : ThetaifyType) (Kenv : KenvType) ->
+ DenotationType =
+ functor
+ (Thetaify : ThetaifyType)
+ (Kenv : KenvType)
+ ->
+ struct
+ module Theta = Thetaify (Kenv)
+
+ let eval_dest dest wrapper success fail =
+ Log.report ~level:sf_level (fun fmt ->
+ Format.fprintf fmt "@[<v 2>D[[%a]]@ " SF.pp_dest dest);
+ match dest with
+ | DPath p ->
+ wrapper p (success p)
+ | DJunction j ->
+ Theta.theta J j wrapper success fail
+
+ let eval_tau trans wrapper success fail =
+ Log.report ~level:sf_level (fun fmt ->
+ Format.fprintf fmt "@[<v 2>tau[[%a]]@ " SF.pp_trans trans);
+ let success' p =
+ Transformer.(
+ success p >> eval_act (module Theta) trans.transition_act)
+ in
+ let cond = Transformer.(event trans.event && trans.condition) in
+ Transformer.(
+ eval_cond cond
+ (eval_act (module Theta) trans.condition_act
+ >> eval_dest trans.dest wrapper success' fail)
+ fail.local)
+
+ let rec eval_T tl wrapper success fail =
+ Log.report ~level:sf_level (fun fmt ->
+ Format.fprintf fmt "@[<v 2>T[[%a]]@ " SF.pp_transitions tl);
+ match tl with
+ | [] ->
+ fail.global
+ | [ t ] ->
+ eval_tau t wrapper success fail
+ | t :: tl ->
+ let fail' = { fail with local = eval_T tl wrapper success fail } in
+ eval_tau t wrapper success fail'
+
+ let frontier path = match path with [] -> [], [] | t :: q -> [ t ], q
+
+ let rec eval_open_path mode p p1 p2 success_p2 =
+ Log.report ~level:sf_level (fun fmt ->
+ Format.fprintf fmt
+ "@[<v 2>open_path_rec[[mode %a, prefix %a, src %a, dst %a]]@ "
+ pp_mode mode pp_path p pp_path p1 pp_path p2);
+ match frontier p1, frontier p2 with
+ | ([ x ], ps), ([ y ], pd) when x = y ->
+ eval_open_path mode (p @ [ x ]) ps pd success_p2
+ | (x, _), (y, pd) -> (
+ match mode with
+ | Outer ->
+ Transformer.(
+ Theta.theta X (p @ x) Loose
+ >> success_p2
+ >> Theta.theta E (p @ y) pd Loose)
+ | Inner ->
+ assert (x = []);
+ Transformer.(
+ Theta.theta X (p @ x) Strict
+ >> success_p2
+ >> Theta.theta E (p @ y) pd Strict)
+ | Enter ->
+ assert (x = [] && y <> []);
+ Transformer.(success_p2 >> Theta.theta E (p @ y) pd Loose))
+
+ let rec eval_C :
+ type a b.
+ (a, b, Transformer.t) tag_t ->
+ path_t ->
+ composition_t ->
+ Transformer.t =
+ fun tag prefix comp ->
+ match tag with
+ | E -> (
+ Transformer.(
+ Log.report ~level:sf_level (fun fmt ->
+ Format.fprintf fmt "@[<v 2>C_%a[[%a, %a]]@ " pp_tag tag pp_path
+ prefix SF.pp_comp comp);
+ match comp with
+ | Or (_T, []) ->
+ null
+ | Or ([], [ s0 ]) ->
+ eval_open_path Enter prefix [] [ s0 ] null
+ | Or (_T, _S) ->
+ let wrapper = eval_open_path Enter [] prefix in
+ let success _p_d = null in
+ eval_T _T wrapper success { local = bot; global = bot }
+ | And _S ->
+ List.fold_right
+ (fun p -> ( >> ) (Theta.theta E (prefix @ [ p ]) [] Loose))
+ _S null))
+ | D -> (
+ Transformer.(
+ match comp with
+ | Or (_T, []) ->
+ null
+ | Or (_T, p :: _S) ->
+ eval_cond
+ (active (prefix @ [ p ]))
+ (Theta.theta D (prefix @ [ p ]))
+ (eval_C D prefix (Or (_T, _S)))
+ | And _S ->
+ List.fold_right
+ (fun p -> ( >> ) (Theta.theta D (prefix @ [ p ])))
+ _S null))
+ | X -> (
+ Transformer.(
+ match comp with
+ | Or (_T, []) ->
+ null
+ | Or (_T, p :: _S) ->
+ eval_cond
+ (active (prefix @ [ p ]))
+ (Theta.theta X (prefix @ [ p ]) Loose)
+ (eval_C X prefix (Or (_T, _S)))
+ | And _S ->
+ List.fold_right
+ (fun p -> ( >> ) (Theta.theta X (prefix @ [ p ]) Loose))
+ _S null))
+ | J ->
+ assert false
+
+ let eval_S :
+ type b. (path_t, b, Transformer.t) tag_t -> path_t -> state_def_t -> b
+ =
+ fun tag p p_def ->
+ match tag with
+ | E -> (
+ fun path frontier ->
+ Transformer.(
+ Log.report ~level:sf_level (fun fmt ->
+ Format.fprintf fmt
+ "@[<v 2>S_%a[[node %a, dest %a, frontier %a]]@ " pp_tag tag
+ pp_path p pp_path path pp_frontier frontier);
+ frontier = Loose
+ >? (eval_act (module Theta) p_def.state_actions.entry_act
+ >> eval_act (module Theta) (open_path p))
+ >>
+ match path with
+ | [] ->
+ eval_C E p p_def.internal_composition
+ | s :: path_tl ->
+ Theta.theta E (p @ [ s ]) path_tl Loose))
+ | D ->
+ Transformer.(
+ Log.report ~level:sf_level (fun fmt ->
+ Format.fprintf fmt "@[<v 2>S_%a[[node %a]]@ " pp_tag tag pp_path
+ p);
+ let wrapper_i = eval_open_path Inner [] p in
+ let wrapper_o = eval_open_path Outer [] p in
+ let success _p_d = null in
+ let fail_o =
+ let fail_i =
+ let same_fail_C = eval_C D p p_def.internal_composition in
+ { local = same_fail_C; global = same_fail_C }
+ in
+ let same_fail_i =
+ eval_act (module Theta) p_def.state_actions.during_act
+ >> eval_T p_def.inner_trans wrapper_i success fail_i
+ in
+ { local = same_fail_i; global = same_fail_i }
+ in
+ eval_T p_def.outer_trans wrapper_o success fail_o)
+ | X ->
+ fun frontier ->
+ Transformer.(
+ Log.report ~level:sf_level (fun fmt ->
+ Format.fprintf fmt "@[<v 2>S_%a[[node %a, frontier %a]]@ "
+ pp_tag tag pp_path p pp_frontier frontier);
+ eval_C X p p_def.internal_composition
+ >> (frontier = Loose
+ >? (eval_act (module Theta) p_def.state_actions.exit_act
+ >> eval_act (module Theta) (close_path p))))
+ end
- module type ProgType =
- sig
+ module type ProgType = sig
val init : state_name_t
+
val defs : prog_t src_components_t list
end
- module type EvaluationType =
- sig
+ module type EvaluationType = sig
module Theta : ThetaType with type t = Transformer.t
+
val eval_prog : Transformer.t
+
val eval_components : 'c call_t -> ('c * Transformer.t) list
end
- module Evaluation (Thetaify : ThetaifyType) (Prog : ProgType) : EvaluationType =
- struct
+ module Evaluation (Thetaify : ThetaifyType) (Prog : ProgType) :
+ EvaluationType = struct
module Denotation = Denotation (Thetaify)
module AbsDenotation = AbstractKenv (Denotation)
include AbsDenotation
- module Kenv : KenvType =
- struct
+ module Kenv : KenvType = struct
let kenv =
- List.fold_left (
- fun accu d -> match d with
- | State (p, defp) -> { accu with cont_node = (p, ((fun kenv -> eval_S kenv E p defp),
- (fun kenv -> eval_S kenv D p defp),
- (fun kenv -> eval_S kenv X p defp)))::accu.cont_node }
- | Junction (j, defj) -> { accu with cont_junc = (j, (fun kenv -> eval_T kenv defj))::accu.cont_junc }
- | SFFunction _ -> accu
- ) {cont_node = []; cont_junc = []} Prog.defs
+ List.fold_left
+ (fun accu d ->
+ match d with
+ | State (p, defp) ->
+ {
+ accu with
+ cont_node =
+ ( p,
+ ( (fun kenv -> eval_S kenv E p defp),
+ (fun kenv -> eval_S kenv D p defp),
+ fun kenv -> eval_S kenv X p defp ) )
+ :: accu.cont_node;
+ }
+ | Junction (j, defj) ->
+ {
+ accu with
+ cont_junc = (j, fun kenv -> eval_T kenv defj) :: accu.cont_junc;
+ }
+ | SFFunction _ ->
+ accu)
+ { cont_node = []; cont_junc = [] }
+ Prog.defs
end
module AppDenotation = Denotation (Kenv)
@@ -230,58 +366,42 @@ struct
let eval_components = Theta.components
let eval_prog =
- Transformer.(eval_cond (active [Prog.init]) (Theta.theta D [Prog.init]) (Theta.theta E [Prog.init] [] Loose))
- end
- (*
- module ThetaFix (Prog : ProgType) (Theta : ThetaType) : ThetaType =
- struct
- include Denotation (Theta)
-
- let theta =
- let kenv =
- List.fold_left (
- fun accu d -> match d with
- | State (p, defp) -> { accu with cont_node = (p, (eval_S E p defp, eval_S D p defp, eval_S X p defp))::accu.cont_node }
- | Junction (j, defj) -> { accu with cont_junc = (j, (eval_T defj))::accu.cont_junc }
- ) {cont_node = []; cont_junc = []} Prog.defs
- in Obj.magic (fun tag -> theta_ify kenv tag)
+ Transformer.(
+ eval_cond
+ (active [ Prog.init ])
+ (Theta.theta D [ Prog.init ])
+ (Theta.theta E [ Prog.init ] [] Loose))
end
- module Rec (Prog : ProgType) =
- struct
- module rec Theta : ThetaType = ThetaFix (Prog) (Theta)
- end
-
- module Eval (Prog : ProgType) : EvaluationType =
- struct
- module RecTheta = Rec (Prog)
- module Theta = RecTheta.Theta
-
- let eval_prog =
- Transformer.(eval_cond (active [Prog.init]) (Theta.theta D [Prog.init]) (Theta.theta E [Prog.init] []))
- end
-
- module Eval (Prog : ProgType) =
- struct
- module ThetaFunctor (Evaluation : EvaluationType) : ThetaType =
- struct
- let theta tag = (theta_ify Evaluation.kenv) tag
- end
- module EvaluationFunctor (Theta : ThetaType) : EvaluationType =
- struct
- include Denotation (Theta)
-
- let kenv =
- List.fold_left (
- fun accu d -> match d with
- | State (p, defp) -> { accu with cont_node = (p, (fun kenv -> eval_S E p defp, eval_S D p defp, eval_S X p defp))::accu.cont_node }
- | Junction (j, defj) -> { accu with cont_junc = (j, (eval_T defj))::accu.cont_junc }
- ) {cont_node = []; cont_junc = []} Prog.defs
-
- let eval_prog =
- Transformer.(eval_cond (active [Prog.init]) (Theta.theta D [Prog.init]) (Theta.theta E [Prog.init] []))
- end
- module rec Theta : ThetaType = ThetaFunctor (Evaluation)
- and Evaluation : EvaluationType = EvaluationFunctor (Theta)
-end
- *)
+ (* module ThetaFix (Prog : ProgType) (Theta : ThetaType) : ThetaType = struct
+ include Denotation (Theta)
+
+ let theta = let kenv = List.fold_left ( fun accu d -> match d with | State
+ (p, defp) -> { accu with cont_node = (p, (eval_S E p defp, eval_S D p defp,
+ eval_S X p defp))::accu.cont_node } | Junction (j, defj) -> { accu with
+ cont_junc = (j, (eval_T defj))::accu.cont_junc } ) {cont_node = [];
+ cont_junc = []} Prog.defs in Obj.magic (fun tag -> theta_ify kenv tag) end
+ module Rec (Prog : ProgType) = struct module rec Theta : ThetaType =
+ ThetaFix (Prog) (Theta) end
+
+ module Eval (Prog : ProgType) : EvaluationType = struct module RecTheta =
+ Rec (Prog) module Theta = RecTheta.Theta
+
+ let eval_prog = Transformer.(eval_cond (active [Prog.init]) (Theta.theta D
+ [Prog.init]) (Theta.theta E [Prog.init] [])) end
+
+ module Eval (Prog : ProgType) = struct module ThetaFunctor (Evaluation :
+ EvaluationType) : ThetaType = struct let theta tag = (theta_ify
+ Evaluation.kenv) tag end module EvaluationFunctor (Theta : ThetaType) :
+ EvaluationType = struct include Denotation (Theta)
+
+ let kenv = List.fold_left ( fun accu d -> match d with | State (p, defp) ->
+ { accu with cont_node = (p, (fun kenv -> eval_S E p defp, eval_S D p defp,
+ eval_S X p defp))::accu.cont_node } | Junction (j, defj) -> { accu with
+ cont_junc = (j, (eval_T defj))::accu.cont_junc } ) {cont_node = [];
+ cont_junc = []} Prog.defs
+
+ let eval_prog = Transformer.(eval_cond (active [Prog.init]) (Theta.theta D
+ [Prog.init]) (Theta.theta E [Prog.init] [])) end module rec Theta :
+ ThetaType = ThetaFunctor (Evaluation) and Evaluation : EvaluationType =
+ EvaluationFunctor (Theta) end *)
end
diff --git a/src/tools/stateflow/semantics/cPS_lustre_generator.ml b/src/tools/stateflow/semantics/cPS_lustre_generator.ml
index 4d650242a376713c6194f51c3eb440582d093ee0..20c12ed7e868b303b7ba5d273123adb697e121eb 100644
--- a/src/tools/stateflow/semantics/cPS_lustre_generator.ml
+++ b/src/tools/stateflow/semantics/cPS_lustre_generator.ml
@@ -1,36 +1,41 @@
open Basetypes
open CPS_transformer
-let ff = Format.fprintf
-
-module LustrePrinter (
- Vars : sig
- val state_vars : ActiveStates.Vars.t
- val global_vars : GlobalVarDef.t list
-
- end) : TransformerType =
-struct
+let ff = Format.fprintf
+
+module LustrePrinter (Vars : sig
+ val state_vars : ActiveStates.Vars.t
+
+ val global_vars : GlobalVarDef.t list
+end) : TransformerType = struct
include TransformerStub
type name_t = string
- type t_base = { statements : Lustre_types.statement list; assert_false: bool }
- type t = name_t -> name_t -> (ActiveStates.Vars.t * t_base)
-
+ type t_base = {
+ statements : Lustre_types.statement list;
+ assert_false : bool;
+ }
+
+ type t = name_t -> name_t -> ActiveStates.Vars.t * t_base
+
let new_loc, reset_loc =
let cpt = ref 0 in
- ((fun () -> incr cpt; Format.sprintf "loc_%i" !cpt),
- (fun () -> cpt := 0))
+ ( (fun () ->
+ incr cpt;
+ Format.sprintf "loc_%i" !cpt),
+ fun () -> cpt := 0 )
let new_aut, _reset_aut =
let cpt = ref 0 in
- ((fun () -> incr cpt; Format.sprintf "aut_%i" !cpt),
- (fun () -> cpt := 0))
-
+ ( (fun () ->
+ incr cpt;
+ Format.sprintf "aut_%i" !cpt),
+ fun () -> cpt := 0 )
+
let pp_path prefix fmt path =
- Format.fprintf fmt "%s%t"
- prefix
- (fun fmt -> Utils.fprintf_list ~sep:"_" Format.pp_print_string fmt path)
+ Format.fprintf fmt "%s%t" prefix (fun fmt ->
+ Utils.fprintf_list ~sep:"_" Format.pp_print_string fmt path)
(* let pp_typed_path sin fmt path =
* Format.fprintf fmt "%a : bool" (pp_path sin) path *)
@@ -39,225 +44,220 @@ struct
* Format.fprintf fmt "%t" (fun fmt -> Utils.fprintf_list ~sep:", " (pp_path sin) fmt (ActiveStates.Vars.elements vars)) *)
(* let pp_vars_decl sin fmt vars =
* Format.fprintf fmt "%t" (fun fmt -> Utils.fprintf_list ~sep:"; " (pp_typed_path sin) fmt (ActiveStates.Vars.elements vars)) *)
-
+
let var_to_ident prefix p =
pp_path prefix Format.str_formatter p;
Format.flush_str_formatter ()
- let vars_to_ident_list ?(prefix="") vars =
- List.map (
- fun p -> var_to_ident prefix p
- ) (ActiveStates.Vars.elements vars)
+ let vars_to_ident_list ?(prefix = "") vars =
+ List.map (fun p -> var_to_ident prefix p) (ActiveStates.Vars.elements vars)
- let mkvar name typ =
+ let mkvar name typ =
let loc = Location.dummy_loc in
- Corelang.mkvar_decl
- loc
- (name, typ, Corelang.mkclock loc Lustre_types.Ckdec_any, false, None, None (*"__no_parent__" *))
+ Corelang.mkvar_decl loc
+ ( name,
+ typ,
+ Corelang.mkclock loc Lustre_types.Ckdec_any,
+ false,
+ None,
+ None (*"__no_parent__" *) )
+
+ let var_to_vdecl ?(prefix = "") var typ = mkvar (var_to_ident prefix var) typ
- let var_to_vdecl ?(prefix="") var typ = mkvar (var_to_ident prefix var) typ
- let state_vars_to_vdecl_list ?(prefix="") vars =
+ let state_vars_to_vdecl_list ?(prefix = "") vars =
let bool_type = Corelang.mktyp Location.dummy_loc Lustre_types.Tydec_bool in
- List.map
- (fun v -> var_to_vdecl ~prefix:prefix v bool_type)
+ List.map
+ (fun v -> var_to_vdecl ~prefix v bool_type)
(ActiveStates.Vars.elements vars)
let mk_locals locs =
- ActiveStates.Vars.fold (fun v accu ->
- (state_vars_to_vdecl_list ~prefix:(List.hd v) Vars.state_vars)@accu
- ) locs []
- (* TODO: declare global vars *)
+ ActiveStates.Vars.fold
+ (fun v accu ->
+ state_vars_to_vdecl_list ~prefix:(List.hd v) Vars.state_vars @ accu)
+ locs []
+ (* TODO: declare global vars *)
let mkeq = Corelang.mkeq Location.dummy_loc
+
let mkexpr = Corelang.mkexpr Location.dummy_loc
+
let mkpredef_call = Corelang.mkpredef_call Location.dummy_loc
- let expr_of_bool b = mkexpr (Lustre_types.Expr_const (Corelang.const_of_bool b))
- let mkstmt_eq lhs_vars ?(prefix_lhs="") rhs =
- { statements = [
- Lustre_types.Eq (
- mkeq (
- vars_to_ident_list ~prefix:prefix_lhs lhs_vars, (* lhs *)
- rhs (* rhs *)
- )
- )
- ];
- assert_false = false
+
+ let expr_of_bool b =
+ mkexpr (Lustre_types.Expr_const (Corelang.const_of_bool b))
+
+ let mkstmt_eq lhs_vars ?(prefix_lhs = "") rhs =
+ {
+ statements =
+ [
+ Lustre_types.Eq
+ (mkeq
+ ( vars_to_ident_list ~prefix:prefix_lhs lhs_vars,
+ (* lhs *)
+ rhs (* rhs *) ));
+ ];
+ assert_false = false;
}
+
let base_to_assert b =
if b.assert_false then
- [{Lustre_types.assert_expr = expr_of_bool false; assert_loc = Location.dummy_loc}]
- else
- []
+ [
+ {
+ Lustre_types.assert_expr = expr_of_bool false;
+ assert_loc = Location.dummy_loc;
+ };
+ ]
+ else []
-
- let var_to_expr ?(prefix="") p =
+ let var_to_expr ?(prefix = "") p =
let id = var_to_ident prefix p in
Corelang.expr_of_ident id Location.dummy_loc
- let vars_to_exprl ?(prefix="") vars =
- List.map
- (fun p -> var_to_expr ~prefix:prefix p)
- (ActiveStates.Vars.elements vars)
-
+ let vars_to_exprl ?(prefix = "") vars =
+ List.map (fun p -> var_to_expr ~prefix p) (ActiveStates.Vars.elements vars)
(* Events *)
let event_type_decl =
Corelang.mktop
- (
- Lustre_types.TypeDef {
- Lustre_types.tydef_id = "event_type";
- tydef_desc = Lustre_types.Tydec_int
- }
- )
-
- let event_type = {
- Lustre_types.ty_dec_desc = Lustre_types.Tydec_const "event_type";
- Lustre_types.ty_dec_loc = Location.dummy_loc;
- }
-
- let event_var = mkvar "event" event_type
+ (Lustre_types.TypeDef
+ {
+ Lustre_types.tydef_id = "event_type";
+ tydef_desc = Lustre_types.Tydec_int;
+ })
+ let event_type =
+ {
+ Lustre_types.ty_dec_desc = Lustre_types.Tydec_const "event_type";
+ Lustre_types.ty_dec_loc = Location.dummy_loc;
+ }
+
+ let event_var = mkvar "event" event_type
let const_map : (event_base_t, int) Hashtbl.t = Hashtbl.create 13
+
let get_event_const e =
try Hashtbl.find const_map e
- with Not_found -> (
+ with Not_found ->
let nb = Hashtbl.length const_map in
Hashtbl.add const_map e nb;
- nb
- )
+ nb
-
-
let null sin sout =
let expr_list = vars_to_exprl ~prefix:sin Vars.state_vars in
- ActiveStates.Vars.empty,
- (
+ ( ActiveStates.Vars.empty,
(* Nothing happen here: out_vars = in_vars *)
- let rhs = mkexpr (Lustre_types.Expr_tuple expr_list) in
- mkstmt_eq ~prefix_lhs:sout Vars.state_vars rhs
- )
-
+ let rhs = mkexpr (Lustre_types.Expr_tuple expr_list) in
+ mkstmt_eq ~prefix_lhs:sout Vars.state_vars rhs )
+
let bot sin sout =
let _, tr = null sin sout in
- (
- ActiveStates.Vars.empty,
- { tr with assert_false = true }
- )
-
+ ActiveStates.Vars.empty, { tr with assert_false = true }
+
let ( >> ) tr1 tr2 sin sout =
let l = new_loc () in
let vars1, tr1 = tr1 sin l in
let vars2, tr2 = tr2 l sout in
- (ActiveStates.Vars.add [l] (ActiveStates.Vars.union vars1 vars2),
- {
- statements = tr1.statements @ tr2.statements;
- assert_false = tr1.assert_false || tr2.assert_false
- }
- )
-
- let pp_name :
- type c. c call_t -> c -> unit =
- fun call ->
- match call with
- | Ecall -> (fun (p, p', f) ->
- Format.fprintf Format.str_formatter "theta%a%a%a_%a"
- pp_call call
- (pp_path "_from_") p
- (pp_path "_to_") p'
- pp_frontier f)
- | Dcall -> (fun p ->
- Format.fprintf Format.str_formatter "theta%a%a"
- pp_call call
- (pp_path "_from_") p)
- | Xcall -> (fun (p, f) ->
- Format.fprintf Format.str_formatter "theta%a%a_%a"
- pp_call call
- (pp_path "_from_") p
- pp_frontier f)
-
-
- let mkcall' :
- type c. name_t -> name_t -> c call_t -> c -> t_base =
- fun sin sout call arg ->
- pp_name call arg;
- let funname = Format.flush_str_formatter () in
- let args = (Corelang.expr_of_vdecl event_var)::(vars_to_exprl ~prefix:sin Vars.state_vars) in
- let rhs = mkpredef_call funname args in
- mkstmt_eq ~prefix_lhs:sout Vars.state_vars rhs
-
+ ( ActiveStates.Vars.add [ l ] (ActiveStates.Vars.union vars1 vars2),
+ {
+ statements = tr1.statements @ tr2.statements;
+ assert_false = tr1.assert_false || tr2.assert_false;
+ } )
+
+ let pp_name : type c. c call_t -> c -> unit =
+ fun call ->
+ match call with
+ | Ecall ->
+ fun (p, p', f) ->
+ Format.fprintf Format.str_formatter "theta%a%a%a_%a" pp_call call
+ (pp_path "_from_") p (pp_path "_to_") p' pp_frontier f
+ | Dcall ->
+ fun p ->
+ Format.fprintf Format.str_formatter "theta%a%a" pp_call call
+ (pp_path "_from_") p
+ | Xcall ->
+ fun (p, f) ->
+ Format.fprintf Format.str_formatter "theta%a%a_%a" pp_call call
+ (pp_path "_from_") p pp_frontier f
+
+ let mkcall' : type c. name_t -> name_t -> c call_t -> c -> t_base =
+ fun sin sout call arg ->
+ pp_name call arg;
+ let funname = Format.flush_str_formatter () in
+ let args =
+ Corelang.expr_of_vdecl event_var
+ :: vars_to_exprl ~prefix:sin Vars.state_vars
+ in
+ let rhs = mkpredef_call funname args in
+ mkstmt_eq ~prefix_lhs:sout Vars.state_vars rhs
+
let mkact' action sin sout =
match action with
- | Action.Call (c, a) -> mkcall' sin sout c a
- | Action.Quote a ->
- (* TODO: check. This seems to be innappropriate *)
- (* let funname = "action_" ^ a.ident in
- let args = vars_to_exprl ~prefix:sin Vars.state_vars in
- let rhs = mkpredef_call funname args in
- mkstmt_eq ~prefix_lhs:sout Vars.state_vars rhs
- *)
- {
- statements = a.defs;
- assert_false = false
- }
- | Action.Open p ->
- let vars' = ActiveStates.Vars.remove p Vars.state_vars in
- (* eq1: sout_p = true *)
- let eq1 = mkeq ([var_to_ident sout p] , expr_of_bool true) in
- (* eq2: sout_xx = sin_xx *)
- let expr_list = vars_to_exprl ~prefix:sin vars' in
- let rhs = mkexpr (Lustre_types.Expr_tuple expr_list) in
- let eq2 = mkeq (vars_to_ident_list ~prefix:sout vars', rhs) in
- {
- statements = [
- Lustre_types.Eq (eq1);
- Lustre_types.Eq (eq2);
- ];
- assert_false = false
- }
-
- | Action.Close p ->
- let vars' = ActiveStates.Vars.remove p Vars.state_vars in
- (* eq1: sout_p = false *)
- let eq1 = mkeq ([var_to_ident sout p] , expr_of_bool false) in
- (* eq2: sout_xx = sin_xx *)
- let expr_list = vars_to_exprl ~prefix:sin vars' in
- let rhs = mkexpr (Lustre_types.Expr_tuple expr_list) in
- let eq2 = mkeq (vars_to_ident_list ~prefix:sout vars', rhs) in
- {
- statements = [
- Lustre_types.Eq (eq1);
- Lustre_types.Eq (eq2);
- ];
- assert_false = false
- }
-
- | Action.Nil ->
- let expr_list = vars_to_exprl ~prefix:sin Vars.state_vars in
- let rhs = mkexpr (Lustre_types.Expr_tuple expr_list) in
- mkstmt_eq ~prefix_lhs:sout Vars.state_vars rhs
-
- let eval_act _kenv (action : act_t) =
- (*Format.printf "----- action = %a@." Action.pp_act action;*)
- (fun sin sout -> (ActiveStates.Vars.empty,
- mkact' action sin sout ))
+ | Action.Call (c, a) ->
+ mkcall' sin sout c a
+ | Action.Quote a ->
+ (* TODO: check. This seems to be innappropriate *)
+ (* let funname = "action_" ^ a.ident in let args = vars_to_exprl
+ ~prefix:sin Vars.state_vars in let rhs = mkpredef_call funname args in
+ mkstmt_eq ~prefix_lhs:sout Vars.state_vars rhs *)
+ { statements = a.defs; assert_false = false }
+ | Action.Open p ->
+ let vars' = ActiveStates.Vars.remove p Vars.state_vars in
+ (* eq1: sout_p = true *)
+ let eq1 = mkeq ([ var_to_ident sout p ], expr_of_bool true) in
+ (* eq2: sout_xx = sin_xx *)
+ let expr_list = vars_to_exprl ~prefix:sin vars' in
+ let rhs = mkexpr (Lustre_types.Expr_tuple expr_list) in
+ let eq2 = mkeq (vars_to_ident_list ~prefix:sout vars', rhs) in
+ {
+ statements = [ Lustre_types.Eq eq1; Lustre_types.Eq eq2 ];
+ assert_false = false;
+ }
+ | Action.Close p ->
+ let vars' = ActiveStates.Vars.remove p Vars.state_vars in
+ (* eq1: sout_p = false *)
+ let eq1 = mkeq ([ var_to_ident sout p ], expr_of_bool false) in
+ (* eq2: sout_xx = sin_xx *)
+ let expr_list = vars_to_exprl ~prefix:sin vars' in
+ let rhs = mkexpr (Lustre_types.Expr_tuple expr_list) in
+ let eq2 = mkeq (vars_to_ident_list ~prefix:sout vars', rhs) in
+ {
+ statements = [ Lustre_types.Eq eq1; Lustre_types.Eq eq2 ];
+ assert_false = false;
+ }
+ | Action.Nil ->
+ let expr_list = vars_to_exprl ~prefix:sin Vars.state_vars in
+ let rhs = mkexpr (Lustre_types.Expr_tuple expr_list) in
+ mkstmt_eq ~prefix_lhs:sout Vars.state_vars rhs
+
+ let eval_act _kenv (action : act_t)
+ (*Format.printf "----- action = %a@." Action.pp_act action;*)
+ sin sout =
+ ActiveStates.Vars.empty, mkact' action sin sout
let rec mkcond' sin condition =
(*Format.printf "----- cond = %a@." Condition.pp_cond condition;*)
match condition with
- | Condition.True -> expr_of_bool true
- | Condition.Active p -> var_to_expr ~prefix:sin p
- | Condition.Event e ->
- mkpredef_call "=" [
- Corelang.expr_of_vdecl event_var;
- mkexpr (Lustre_types.Expr_const (Lustre_types.Const_int (get_event_const e)))
- ]
- | Condition.Neg cond -> mkpredef_call "not" [mkcond' sin cond]
- | Condition.And (cond1, cond2) -> mkpredef_call "&&" [mkcond' sin cond1;
- mkcond' sin cond2]
- | Condition.Quote c -> c.expr (* TODO: shall we prefix with sin ? *)
-
- let eval_cond condition (ok:t) ko sin sout =
+ | Condition.True ->
+ expr_of_bool true
+ | Condition.Active p ->
+ var_to_expr ~prefix:sin p
+ | Condition.Event e ->
+ mkpredef_call "="
+ [
+ Corelang.expr_of_vdecl event_var;
+ mkexpr
+ (Lustre_types.Expr_const
+ (Lustre_types.Const_int (get_event_const e)));
+ ]
+ | Condition.Neg cond ->
+ mkpredef_call "not" [ mkcond' sin cond ]
+ | Condition.And (cond1, cond2) ->
+ mkpredef_call "&&" [ mkcond' sin cond1; mkcond' sin cond2 ]
+ | Condition.Quote c ->
+ c.expr
+ (* TODO: shall we prefix with sin ? *)
+
+ let eval_cond condition (ok : t) ko sin sout =
let open Lustre_types in
let loc = Location.dummy_loc in
(*Format.printf "----- cond = %a@." Condition.pp_cond condition;*)
@@ -265,151 +265,179 @@ struct
let vars2, tr2 = ko sin sout in
let _, tr0 = bot sin sout in
let aut = new_aut () in
- (ActiveStates.Vars.empty,
- {
- statements = [
- let handler_default_mode = (* Default mode : CenterPoint *)
- let handler_default_mode_unless = [
- (loc, mkcond' sin condition, true (* restart *), "Cond_" ^ aut);
- (loc, mkcond' sin (Condition.Neg condition), true (* restart *), "NotCond_" ^ aut);
- ]
- in
- Automata.mkhandler
- loc (* location *)
- ("CenterPoint_" ^ aut) (* state name *)
- handler_default_mode_unless (* unless *)
- [] (* until *)
- [] (* locals *)
- (tr0.statements, base_to_assert tr0, []) (* stmts, asserts, annots *)
- in
- let handler_cond_mode = (* Cond mode *)
- let handler_cond_mode_until = [
- (loc, expr_of_bool true, true (* restart *), "CenterPoint_" ^ aut);
- ]
- in
- Automata.mkhandler
- loc (* location *)
- ("Cond_" ^ aut) (* state name *)
- [] (* unless *)
- handler_cond_mode_until (* until *)
- (mk_locals vars1) (* locals *)
- (tr1.statements, base_to_assert tr1, []) (* stmts, asserts, annots *)
- in
- let handler_notcond_mode = (* NotCond mode *)
- let handler_notcond_mode_until = [
- (loc, expr_of_bool true, true (* restart *), "CenterPoint_" ^ aut);
- ]
- in
- Automata.mkhandler
- loc (* location *)
- ("NotCond_" ^ aut) (* state name *)
- [] (* unless *)
- handler_notcond_mode_until (* until *)
- (mk_locals vars2) (* locals *)
- (tr2.statements, base_to_assert tr2, []) (* stmts, asserts, annots *)
- in
- let handlers = [ handler_default_mode; handler_cond_mode; handler_notcond_mode ] in
- Aut (Automata.mkautomata loc aut handlers)
- ];
- assert_false = false
- }
- )
-
+ ( ActiveStates.Vars.empty,
+ {
+ statements =
+ [
+ (let handler_default_mode =
+ (* Default mode : CenterPoint *)
+ let handler_default_mode_unless =
+ [
+ loc, mkcond' sin condition, true (* restart *), "Cond_" ^ aut;
+ ( loc,
+ mkcond' sin (Condition.Neg condition),
+ true (* restart *),
+ "NotCond_" ^ aut );
+ ]
+ in
+ Automata.mkhandler loc
+ (* location *)
+ ("CenterPoint_" ^ aut)
+ (* state name *)
+ handler_default_mode_unless (* unless *) [] (* until *) []
+ (* locals *)
+ (tr0.statements, base_to_assert tr0, [])
+ (* stmts, asserts, annots *)
+ in
+ let handler_cond_mode =
+ (* Cond mode *)
+ let handler_cond_mode_until =
+ [
+ ( loc,
+ expr_of_bool true,
+ true (* restart *),
+ "CenterPoint_" ^ aut );
+ ]
+ in
+ Automata.mkhandler loc
+ (* location *)
+ ("Cond_" ^ aut)
+ (* state name *)
+ [] (* unless *) handler_cond_mode_until
+ (* until *)
+ (mk_locals vars1)
+ (* locals *)
+ (tr1.statements, base_to_assert tr1, [])
+ (* stmts, asserts, annots *)
+ in
+ let handler_notcond_mode =
+ (* NotCond mode *)
+ let handler_notcond_mode_until =
+ [
+ ( loc,
+ expr_of_bool true,
+ true (* restart *),
+ "CenterPoint_" ^ aut );
+ ]
+ in
+ Automata.mkhandler loc
+ (* location *)
+ ("NotCond_" ^ aut)
+ (* state name *)
+ [] (* unless *) handler_notcond_mode_until
+ (* until *)
+ (mk_locals vars2)
+ (* locals *)
+ (tr2.statements, base_to_assert tr2, [])
+ (* stmts, asserts, annots *)
+ in
+ let handlers =
+ [ handler_default_mode; handler_cond_mode; handler_notcond_mode ]
+ in
+ Aut (Automata.mkautomata loc aut handlers));
+ ];
+ assert_false = false;
+ } )
+
(* let mktransformer tr =
* let _, tr = tr "sin_" "sout_"
- * in tr *)
-
- let mkcomponent :
- type c. c call_t -> c -> t -> Lustre_types.program_t =
- fun call args ->
- fun tr ->
- reset_loc ();
- let (vars', tr') = tr "sin_" "sout_" in
- pp_name call args;
- let funname = Format.flush_str_formatter () in
- let inputs = event_var :: state_vars_to_vdecl_list ~prefix:"sin_" Vars.state_vars in
- let outputs = state_vars_to_vdecl_list ~prefix:"sout_" Vars.state_vars in
- let node =
- Corelang.mktop (
- Lustre_types.Node {Lustre_types.node_id = funname;
- node_type = Types.new_var ();
- node_clock = Clocks.new_var true;
- node_inputs = inputs;
- node_outputs = outputs;
- node_locals = mk_locals vars'; (* TODO: add global vars *)
- node_gencalls = [];
- node_checks = [];
- node_stmts = tr'.statements;
- node_asserts = base_to_assert tr';
- node_dec_stateless = false;
- node_stateless = None;
- node_spec = None;
- node_annot = [];
- node_iscontract = false}
- )
- in
- [node]
-
-
-
- (* TODO
- C'est pas evident.
-Il faut faire les choses suivantes:
-- rajouter dans un ensemble les variables manipulées localement
-- on doit comprendre comment les variables globales sont injectées dans le modele final:
- - le node principal doit uniquement les afficher. Il peut les initialiser avec les valeurs init définies. Puis appeller la fcn thetacallD_from_principal.
- - elles peuvent/doivent etre dans input et output de ce node thetacallD
- *)
-
-
+ * in tr *)
+
+ let mkcomponent : type c. c call_t -> c -> t -> Lustre_types.program_t =
+ fun call args tr ->
+ reset_loc ();
+ let vars', tr' = tr "sin_" "sout_" in
+ pp_name call args;
+ let funname = Format.flush_str_formatter () in
+ let inputs =
+ event_var :: state_vars_to_vdecl_list ~prefix:"sin_" Vars.state_vars
+ in
+ let outputs = state_vars_to_vdecl_list ~prefix:"sout_" Vars.state_vars in
+ let node =
+ Corelang.mktop
+ (Lustre_types.Node
+ {
+ Lustre_types.node_id = funname;
+ node_type = Types.new_var ();
+ node_clock = Clocks.new_var true;
+ node_inputs = inputs;
+ node_outputs = outputs;
+ node_locals = mk_locals vars';
+ (* TODO: add global vars *)
+ node_gencalls = [];
+ node_checks = [];
+ node_stmts = tr'.statements;
+ node_asserts = base_to_assert tr';
+ node_dec_stateless = false;
+ node_stateless = None;
+ node_spec = None;
+ node_annot = [];
+ node_iscontract = false;
+ })
+ in
+ [ node ]
+
+ (* TODO C'est pas evident. Il faut faire les choses suivantes: - rajouter dans
+ un ensemble les variables manipulées localement - on doit comprendre
+ comment les variables globales sont injectées dans le modele final: - le
+ node principal doit uniquement les afficher. Il peut les initialiser avec
+ les valeurs init définies. Puis appeller la fcn thetacallD_from_principal.
+ - elles peuvent/doivent etre dans input et output de ce node thetacallD *)
+
let mk_main_loop () =
(* let loc = Location.dummy_loc in *)
-
let call_stmt =
(* (%t) -> pre (thetaCallD_from_principal (event, %a)) *)
let init =
- let init_state_false =
- List.map (fun _ -> expr_of_bool false) (ActiveStates.Vars.elements Vars.state_vars) in
- let init_globals =
- List.map (fun v -> v.GlobalVarDef.init_val) Vars.global_vars in
- mkexpr (Lustre_types.Expr_tuple (init_state_false @ init_globals))
+ let init_state_false =
+ List.map
+ (fun _ -> expr_of_bool false)
+ (ActiveStates.Vars.elements Vars.state_vars)
+ in
+ let init_globals =
+ List.map (fun v -> v.GlobalVarDef.init_val) Vars.global_vars
+ in
+ mkexpr (Lustre_types.Expr_tuple (init_state_false @ init_globals))
in
- let args = (Corelang.expr_of_vdecl event_var)::
- (vars_to_exprl ~prefix:"sout_" Vars.state_vars)
+ let args =
+ Corelang.expr_of_vdecl event_var
+ :: vars_to_exprl ~prefix:"sout_" Vars.state_vars
in
let call_expr = mkpredef_call "thetaCallD_from_principal" args in
- let pre_call_expr = mkexpr (Lustre_types.Expr_pre (call_expr)) in
+ let pre_call_expr = mkexpr (Lustre_types.Expr_pre call_expr) in
let rhs = mkexpr (Lustre_types.Expr_arrow (init, pre_call_expr)) in
mkstmt_eq Vars.state_vars ~prefix_lhs:"sout_" rhs
in
- let inputs = List.map Corelang.copy_var_decl [event_var] in
+ let inputs = List.map Corelang.copy_var_decl [ event_var ] in
let outputs = state_vars_to_vdecl_list ~prefix:"sout_" Vars.state_vars in
(* TODO add the globals as sout_data_x entry values *)
let node_principal =
- Corelang.mktop (
- Lustre_types.Node {Lustre_types.node_id = "principal_loop";
- node_type = Types.new_var ();
- node_clock = Clocks.new_var true;
- node_inputs = inputs;
- node_outputs = outputs;
- node_locals = []; (* TODO: add global vars *)
- node_gencalls = [];
- node_checks = [];
- node_asserts = base_to_assert call_stmt;
- node_stmts = call_stmt.statements;
- node_dec_stateless = false;
- node_stateless = None;
- node_spec = None;
- node_annot = [];
- node_iscontract = false;}
- )
+ Corelang.mktop
+ (Lustre_types.Node
+ {
+ Lustre_types.node_id = "principal_loop";
+ node_type = Types.new_var ();
+ node_clock = Clocks.new_var true;
+ node_inputs = inputs;
+ node_outputs = outputs;
+ node_locals = [];
+ (* TODO: add global vars *)
+ node_gencalls = [];
+ node_checks = [];
+ node_asserts = base_to_assert call_stmt;
+ node_stmts = call_stmt.statements;
+ node_dec_stateless = false;
+ node_stateless = None;
+ node_spec = None;
+ node_annot = [];
+ node_iscontract = false;
+ })
in
node_principal
-
let mkprincipal tr =
- event_type_decl :: mkcomponent Dcall ["principal"] tr @ [mk_main_loop ()]
-
+ event_type_decl :: mkcomponent Dcall [ "principal" ] tr
+ @ [ mk_main_loop () ]
end
(* Local Variables: *)
diff --git a/src/tools/stateflow/semantics/cPS_transformer.ml b/src/tools/stateflow/semantics/cPS_transformer.ml
index a1082dc7df9bfb5db3213795cb974471277b587c..cd347e681d5d65eb791638b293ef08442c0afab3 100644
--- a/src/tools/stateflow/semantics/cPS_transformer.ml
+++ b/src/tools/stateflow/semantics/cPS_transformer.ml
@@ -1,88 +1,112 @@
open Basetypes
-type mode_t =
- | Outer
- | Inner
- | Enter
-
+type mode_t = Outer | Inner | Enter
type 't success_t = path_t -> 't
-type 't fail_t = { local: 't; global: 't }
+
+type 't fail_t = { local : 't; global : 't }
+
type 't wrapper_t = path_t -> 't -> 't
type ('a, 'b, 't) tag_t =
| E : (path_t, path_t -> frontier_t -> 't, 't) tag_t
| D : (path_t, 't, 't) tag_t
| X : (path_t, frontier_t -> 't, 't) tag_t
- | J : (junction_name_t, 't wrapper_t -> 't success_t -> 't fail_t -> 't, 't) tag_t
-
+ | J
+ : ( junction_name_t,
+ 't wrapper_t -> 't success_t -> 't fail_t -> 't,
+ 't )
+ tag_t
type ('a, 'b, 't) theta_t = ('a, 'b, 't) tag_t -> 'a -> 'b
-module type ThetaType =
-sig
+module type ThetaType = sig
type t
+
val theta : ('a, 'b, t) theta_t
end
let pp_mode fmt mode =
match mode with
- | Outer -> Format.fprintf fmt "Outer"
- | Inner -> Format.fprintf fmt "Inner"
- | Enter -> Format.fprintf fmt "Enter"
-
+ | Outer ->
+ Format.fprintf fmt "Outer"
+ | Inner ->
+ Format.fprintf fmt "Inner"
+ | Enter ->
+ Format.fprintf fmt "Enter"
let pp_tag : type a b t. Format.formatter -> (a, b, t) tag_t -> unit =
- fun fmt tag ->
- match tag with
- | E -> Format.fprintf fmt "e"
- | D -> Format.fprintf fmt "d"
- | X -> Format.fprintf fmt "x"
- | J -> Format.fprintf fmt "j"
-
-
-module TransformerStub =
-struct
+ fun fmt tag ->
+ match tag with
+ | E ->
+ Format.fprintf fmt "e"
+ | D ->
+ Format.fprintf fmt "d"
+ | X ->
+ Format.fprintf fmt "x"
+ | J ->
+ Format.fprintf fmt "j"
+
+module TransformerStub = struct
type act_t = Action.t
+
type cond_t = Condition.t
let nil = Action.nil
+
let aquote = Action.aquote
+
let open_path = Action.open_path
+
let close_path = Action.close_path
+
let call = Action.call
+
let pp_act = Action.pp_act
let cquote = Condition.cquote
+
let tru = Condition.tru
+
let event = Condition.event
+
let active = Condition.active
+
let ( && ) = Condition.( && )
+
let neg = Condition.neg
+
let pp_cond = Condition.pp_cond
end
-module type TransformerType =
-sig
+module type TransformerType = sig
type act_t = Action.t
+
type cond_t = Condition.t
+
type t
include ActionType with type t := act_t
+
include ConditionType with type t := cond_t
val null : t
+
val bot : t
+
val ( >> ) : t -> t -> t
+
val eval_act : (module ThetaType with type t = t) -> act_t -> t
+
val eval_cond : cond_t -> t -> t -> t
+
(* val mktransformer : t -> unit *)
val mkprincipal : t -> Lustre_types.program_t
+
val mkcomponent : 'c call_t -> 'c -> t -> Lustre_types.program_t
end
-module type ComparableTransformerType =
-sig
+module type ComparableTransformerType = sig
include TransformerType
val ( == ) : t -> t -> bool
diff --git a/src/tools/stateflow/semantics/memo.ml b/src/tools/stateflow/semantics/memo.ml
index 2b289b4e227385cd69b73c3b432cb9fa7423fa51..d7fd7d25531a44c6d5e7359a6cb43c1675323e7b 100644
--- a/src/tools/stateflow/semantics/memo.ml
+++ b/src/tools/stateflow/semantics/memo.ml
@@ -1,54 +1,39 @@
open Basetypes
-
-type ('a, 'b) t = Memo : ('a, 'b) Hashtbl.t -> ('a, 'b) t;;
-let create () = Memo (Hashtbl.create 97);;
+type ('a, 'b) t = Memo : ('a, 'b) Hashtbl.t -> ('a, 'b) t
-let reset (Memo hashf) =
- begin
- Hashtbl.reset hashf
- end
+let create () = Memo (Hashtbl.create 97)
-let fold (Memo hashf) f e =
- begin
- Hashtbl.fold f hashf e
- end;;
+let reset (Memo hashf) = Hashtbl.reset hashf
-let apply (Memo hashf) f =
- fun x ->
- try
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "lookup 1@.");
- Hashtbl.find hashf x
- with Not_found ->
- let res = f x in
- begin
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "hashing 1@.");
- Hashtbl.add hashf x res;
- res
- end;;
+let fold (Memo hashf) f e = Hashtbl.fold f hashf e
-let apply2 (Memo hashf) f =
- fun x y ->
- try
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "lookup 2@.");
- Hashtbl.find hashf (x, y)
- with Not_found ->
- let res = f x y in
- begin
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "hashing 2@.");
- Hashtbl.add hashf (x, y) res;
- res
- end;;
+let apply (Memo hashf) f x =
+ try
+ Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "lookup 1@.");
+ Hashtbl.find hashf x
+ with Not_found ->
+ let res = f x in
+ Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "hashing 1@.");
+ Hashtbl.add hashf x res;
+ res
-let apply3 (Memo hashf) f =
- fun x y z ->
- try
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "lookup 3@.");
- Hashtbl.find hashf (x, y, z)
- with Not_found ->
- let res = f x y z in
- begin
- Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "hashing 3@.");
- Hashtbl.add hashf (x, y, z) res;
- res
- end;;
+let apply2 (Memo hashf) f x y =
+ try
+ Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "lookup 2@.");
+ Hashtbl.find hashf (x, y)
+ with Not_found ->
+ let res = f x y in
+ Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "hashing 2@.");
+ Hashtbl.add hashf (x, y) res;
+ res
+
+let apply3 (Memo hashf) f x y z =
+ try
+ Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "lookup 3@.");
+ Hashtbl.find hashf (x, y, z)
+ with Not_found ->
+ let res = f x y z in
+ Log.report ~level:sf_level (fun fmt -> Format.fprintf fmt "hashing 3@.");
+ Hashtbl.add hashf (x, y, z) res;
+ res
diff --git a/src/tools/stateflow/semantics/memo.mli b/src/tools/stateflow/semantics/memo.mli
index 74478c5afc3255ef228d2b2cd7b2edb866cb13da..4327d0e3b8f0b064161d204e5e7caf0c18ebbd40 100644
--- a/src/tools/stateflow/semantics/memo.mli
+++ b/src/tools/stateflow/semantics/memo.mli
@@ -1,10 +1,8 @@
-
(* Le type abstrait des tables utilisées dans la memoization des fonctions. *)
(* Permet de mémoriser des appels de fonctions efficacement sous la forme *)
(* de couples (argument de type 'a, résultat de type 'b). *)
(* Chaque table devra être associée à une fonction unique. *)
-type ('a, 'b) t;;
-
+type ('a, 'b) t
(* Création d'une table vide. *)
(* Paramètres : *)
@@ -12,9 +10,9 @@ type ('a, 'b) t;;
(* Résultat : *)
(* - une table vide destinée à mémoriser uniquement les appels *)
(* d'une fonction quelconque. *)
-val create : unit -> ('a, 'b) t;;
+val create : unit -> ('a, 'b) t
-val reset : ('a, 'b) t -> unit;;
+val reset : ('a, 'b) t -> unit
(* Utilisation d'une version "memoizée" d'une fonction à un paramètre. *)
(* Paramètres : *)
@@ -30,7 +28,7 @@ val reset : ('a, 'b) t -> unit;;
(* Erreur : *)
(* - exception Failure levée en cas d'utilisation d'une même table *)
(* avec plusieurs fonctions différentes. *)
-val apply : ('a, 'b) t -> ('a -> 'b) -> ('a -> 'b);;
+val apply : ('a, 'b) t -> ('a -> 'b) -> 'a -> 'b
(* Utilisation d'une version "memoizée" d'une fonction à deux paramètres. *)
(* Paramètres : *)
@@ -43,8 +41,9 @@ val apply : ('a, 'b) t -> ('a -> 'b) -> ('a -> 'b);;
(* Erreur : *)
(* - exception Failure levée en cas d'utilisation d'une même table *)
(* avec plusieurs fonctions différentes. *)
-val apply2 : ('a * 'b, 'c) t -> ('a -> 'b -> 'c) -> ('a -> 'b -> 'c);;
+val apply2 : ('a * 'b, 'c) t -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c
-val apply3 : ('a * 'b * 'c, 'd) t -> ('a -> 'b -> 'c -> 'd) -> ('a -> 'b -> 'c -> 'd);;
+val apply3 :
+ ('a * 'b * 'c, 'd) t -> ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd
-val fold : ('a, 'b) t -> ('a -> 'b -> 'c -> 'c) -> 'c -> 'c;;
+val fold : ('a, 'b) t -> ('a -> 'b -> 'c -> 'c) -> 'c -> 'c
diff --git a/src/tools/stateflow/semantics/theta.ml b/src/tools/stateflow/semantics/theta.ml
index 6108d032204f4eaeb06c61b2dab55c79ceb2fb9a..0e69c4f7f32b582c0bf3bebdd0ad5a61521ffacc 100644
--- a/src/tools/stateflow/semantics/theta.ml
+++ b/src/tools/stateflow/semantics/theta.ml
@@ -1,160 +1,201 @@
- open Basetypes
+open Basetypes
+
(* open ActiveEnv *)
-open CPS_transformer
+open CPS_transformer
+
(* open Datatype *)
(* open Simulink *)
-(* Theta functions interfaces including memoization when using modular calls
-
- parametrized by the transformer specifying the type of the
- continuation. Evaluation of actions is also continuation dependent.
-*)
+(* Theta functions interfaces including memoization when using modular calls
-module KenvTheta (T : TransformerType) =
-struct
+ parametrized by the transformer specifying the type of the continuation.
+ Evaluation of actions is also continuation dependent. *)
+module KenvTheta (T : TransformerType) = struct
type kenv_t = {
- cont_node : (
- path_t * (
- (kenv_t -> path_t -> frontier_t -> T.t) *
- (kenv_t -> T.t) *
- (kenv_t -> frontier_t -> T.t)
- )
- ) list;
- cont_junc : (
- junction_name_t * (
- kenv_t -> T.t wrapper_t -> T.t success_t -> T.t fail_t -> T.t)
- ) list
+ cont_node :
+ (path_t
+ * ((kenv_t -> path_t -> frontier_t -> T.t)
+ * (kenv_t -> T.t)
+ * (kenv_t -> frontier_t -> T.t)))
+ list;
+ cont_junc :
+ (junction_name_t
+ * (kenv_t -> T.t wrapper_t -> T.t success_t -> T.t fail_t -> T.t))
+ list;
}
-
let init_env src =
- List.fold_left (fun accu d ->
- match d with
- | Datatype.State (p, _) -> ActiveStates.Env.add p false accu
- | _ -> accu)
- ActiveStates.Env.empty
- src
-
- module type KenvType =
- sig
+ List.fold_left
+ (fun accu d ->
+ match d with
+ | Datatype.State (p, _) ->
+ ActiveStates.Env.add p false accu
+ | _ ->
+ accu)
+ ActiveStates.Env.empty src
+
+ module type KenvType = sig
val kenv : kenv_t
end
- module type MemoThetaTablesType =
- sig
+ module type MemoThetaTablesType = sig
val tables : 'c call_t -> ('c, T.t) Memo.t
end
- module type MemoThetaType =
- sig
+ module type MemoThetaType = sig
include ThetaType with type t = T.t
+
val components : 'c call_t -> ('c * t) list
end
- module type ModularType =
- sig
+ module type ModularType = sig
val modular : (path_t, 'b, bool) tag_t -> path_t -> 'b
end
- module MemoThetaTables : functor () -> MemoThetaTablesType = functor () ->
- struct
- let table_theta_e = (Memo.create () : (path_t * path_t * frontier_t, T.t) Memo.t)
- let table_theta_d = (Memo.create () : (path_t, T.t) Memo.t)
- let table_theta_x = (Memo.create () : (path_t * frontier_t, T.t) Memo.t)
-
- let tables : type c. c call_t -> (c, T.t) Memo.t =
- fun call ->
- match call with
- | Ecall -> table_theta_e
- | Dcall -> table_theta_d
- | Xcall -> table_theta_x
- end
-
- module Memoize (Tables : MemoThetaTablesType) (Theta : ThetaType with type t = T.t) : MemoThetaType =
- struct
+ module MemoThetaTables : functor () -> MemoThetaTablesType =
+ functor
+ ()
+ ->
+ struct
+ let table_theta_e =
+ (Memo.create () : (path_t * path_t * frontier_t, T.t) Memo.t)
+
+ let table_theta_d = (Memo.create () : (path_t, T.t) Memo.t)
+
+ let table_theta_x = (Memo.create () : (path_t * frontier_t, T.t) Memo.t)
+
+ let tables : type c. c call_t -> (c, T.t) Memo.t =
+ fun call ->
+ match call with
+ | Ecall ->
+ table_theta_e
+ | Dcall ->
+ table_theta_d
+ | Xcall ->
+ table_theta_x
+ end
+
+ module Memoize
+ (Tables : MemoThetaTablesType)
+ (Theta : ThetaType with type t = T.t) : MemoThetaType = struct
type t = Theta.t
let components call =
- Memo.fold (Tables.tables call) (fun k v res -> (k, v)::res) []
+ Memo.fold (Tables.tables call) (fun k v res -> (k, v) :: res) []
let theta : type a b. (a, b, t) theta_t =
- fun tag ->
+ fun tag ->
match tag with
- | J -> Theta.theta J
- | E -> Memo.apply3 (Tables.tables Ecall) (Theta.theta E)
- | D -> Memo.apply (Tables.tables Dcall) (Theta.theta D)
- | X -> Memo.apply2 (Tables.tables Xcall) (Theta.theta X)
+ | J ->
+ Theta.theta J
+ | E ->
+ Memo.apply3 (Tables.tables Ecall) (Theta.theta E)
+ | D ->
+ Memo.apply (Tables.tables Dcall) (Theta.theta D)
+ | X ->
+ Memo.apply2 (Tables.tables Xcall) (Theta.theta X)
end
-
- module Modularize (Mod : ModularType) (Theta : MemoThetaType) : MemoThetaType =
- struct
+
+ module Modularize (Mod : ModularType) (Theta : MemoThetaType) :
+ MemoThetaType = struct
type t = Theta.t
let mod_theta = (module Theta : ThetaType with type t = T.t)
let components : type c. c call_t -> (c * t) list =
- fun call ->
+ fun call ->
match call with
- | Ecall -> List.filter (fun ((p, p', f), _) -> Mod.modular E p p' f) (Theta.components Ecall)
- | Dcall -> List.filter (fun (p , _) -> Mod.modular D p) (Theta.components Dcall)
- | Xcall -> List.filter (fun ((p, f) , _) -> Mod.modular X p f) (Theta.components Xcall)
+ | Ecall ->
+ List.filter
+ (fun ((p, p', f), _) -> Mod.modular E p p' f)
+ (Theta.components Ecall)
+ | Dcall ->
+ List.filter (fun (p, _) -> Mod.modular D p) (Theta.components Dcall)
+ | Xcall ->
+ List.filter
+ (fun ((p, f), _) -> Mod.modular X p f)
+ (Theta.components Xcall)
let theta : type a b. (a, b, t) theta_t =
- fun tag ->
+ fun tag ->
match tag with
- | J -> Theta.theta tag
- | E -> (fun p p' f -> let theta_e = Theta.theta tag p p' f in
- if Mod.modular E p p' f
- then T.(eval_act mod_theta (call Ecall (p, p', f)))
- else theta_e)
- | D -> (fun p -> let theta_d = Theta.theta tag p in
- if Mod.modular D p
- then T.(eval_act mod_theta (call Dcall p))
- else theta_d)
- | X -> (fun p f -> let theta_x = Theta.theta tag p f in
- if Mod.modular X p f
- then T.(eval_act mod_theta (call Xcall (p, f)))
- else theta_x)
+ | J ->
+ Theta.theta tag
+ | E ->
+ fun p p' f ->
+ let theta_e = Theta.theta tag p p' f in
+ if Mod.modular E p p' f then
+ T.(eval_act mod_theta (call Ecall (p, p', f)))
+ else theta_e
+ | D ->
+ fun p ->
+ let theta_d = Theta.theta tag p in
+ if Mod.modular D p then T.(eval_act mod_theta (call Dcall p))
+ else theta_d
+ | X ->
+ fun p f ->
+ let theta_x = Theta.theta tag p f in
+ if Mod.modular X p f then T.(eval_act mod_theta (call Xcall (p, f)))
+ else theta_x
end
module type ThetaifyType = functor (Kenv : KenvType) -> MemoThetaType
- module BasicThetaify : ThetaifyType = functor (Kenv : KenvType) ->
- struct
- type t = T.t
-
- let theta_ify : type a b. kenv_t -> (a, b, T.t) theta_t =
- fun kenv tag ->
- match tag with
- | J -> (fun j ->
- try List.assoc j kenv.cont_junc kenv
- with Not_found ->
- Format.eprintf "Lost junction %a@ " pp_junction_name j;
- assert false)
- | E -> (fun p ->
- try
- let (e, _, _) = List.assoc p kenv.cont_node in e kenv
- with Not_found ->
- Format.eprintf "Entering lost path [%a]@." pp_path p; assert false)
- | D -> (fun p ->
- try
- let (_, d, _) = List.assoc p kenv.cont_node in d kenv
- with Not_found ->
- Format.eprintf "During lost path [%a]@." pp_path p; assert false)
- | X -> (fun p ->
- try
- let (_, _, x) = List.assoc p kenv.cont_node in x kenv
- with Not_found ->
- Format.eprintf "Exiting lost path [%a]@." pp_path p; assert false)
-
- let theta tag = theta_ify Kenv.kenv tag
-
- let components _call = []
- end
-
- module ModularThetaify : functor (Tables : MemoThetaTablesType) (Mod : ModularType) -> ThetaifyType =
- functor (Tables : MemoThetaTablesType) (Mod : ModularType) (Kenv : KenvType) ->
- Modularize (Mod) (Memoize (Tables) (BasicThetaify (Kenv)))
-
+ module BasicThetaify : ThetaifyType =
+ functor
+ (Kenv : KenvType)
+ ->
+ struct
+ type t = T.t
+
+ let theta_ify : type a b. kenv_t -> (a, b, T.t) theta_t =
+ fun kenv tag ->
+ match tag with
+ | J -> (
+ fun j ->
+ try List.assoc j kenv.cont_junc kenv
+ with Not_found ->
+ Format.eprintf "Lost junction %a@ " pp_junction_name j;
+ assert false)
+ | E -> (
+ fun p ->
+ try
+ let e, _, _ = List.assoc p kenv.cont_node in
+ e kenv
+ with Not_found ->
+ Format.eprintf "Entering lost path [%a]@." pp_path p;
+ assert false)
+ | D -> (
+ fun p ->
+ try
+ let _, d, _ = List.assoc p kenv.cont_node in
+ d kenv
+ with Not_found ->
+ Format.eprintf "During lost path [%a]@." pp_path p;
+ assert false)
+ | X -> (
+ fun p ->
+ try
+ let _, _, x = List.assoc p kenv.cont_node in
+ x kenv
+ with Not_found ->
+ Format.eprintf "Exiting lost path [%a]@." pp_path p;
+ assert false)
+
+ let theta tag = theta_ify Kenv.kenv tag
+
+ let components _call = []
+ end
+
+ module ModularThetaify : functor
+ (Tables : MemoThetaTablesType)
+ (Mod : ModularType)
+ -> ThetaifyType =
+ functor
+ (Tables : MemoThetaTablesType)
+ (Mod : ModularType)
+ (Kenv : KenvType)
+ ->
+ Modularize (Mod) (Memoize (Tables) (BasicThetaify (Kenv)))
end
diff --git a/src/tools/stateflow/sf_sem.ml b/src/tools/stateflow/sf_sem.ml
index 45eab193e83ade312e7d70cc440071be8eb16100..f82109a9e46993b9731329bac69ff605b820b2dd 100644
--- a/src/tools/stateflow/sf_sem.ml
+++ b/src/tools/stateflow/sf_sem.ml
@@ -1,99 +1,117 @@
-
-
type backend = GenLus | GenImp
(* Model choice *)
let model_name = ref "simple"
-let models = [(module Model_simple : Datatype.MODEL_T);
- (module Model_stopwatch : Datatype.MODEL_T);
- (* (module Model_medium : Datatype.MODEL_T)*)
- ]
-let get_model_name m = let module M = (val m : Datatype.MODEL_T) in M.name
-let set_model name =
+let models =
+ [
+ (module Model_simple : Datatype.MODEL_T);
+ (module Model_stopwatch : Datatype.MODEL_T);
+ (* (module Model_medium : Datatype.MODEL_T)*)
+ ]
+
+let get_model_name m =
+ let module M = (val m : Datatype.MODEL_T) in
+ M.name
+
+let set_model name =
if List.exists (fun n -> get_model_name n = name) models then
model_name := name
- else failwith ("incorrect model name. Use " ^
- (List.fold_left (fun r n -> r ^ " or " ^ get_model_name n) "" models))
+ else
+ failwith
+ ("incorrect model name. Use "
+ ^ List.fold_left (fun r n -> r ^ " or " ^ get_model_name n) "" models)
(* Backend selection *)
let modular = ref 0
+
let set_modular i = modular := i
let mode = ref GenLus
-
-
-let set_mode m =
- mode := m
+
+let set_mode m = mode := m
(* Main *)
-
-let options = [
- "-verbose", Arg.Set_int Options.verbose_level, "changes verbose \x1b[4mlevel\x1b[0m <default: 1>";
- "-model", Arg.String set_model, "model in {simple, stopwatch} (default: simple)";
- (* "-eval", Arg.Int set_trace_run_mode, "execute the model on trace <int>"; *)
- (* "-eval-mode", Arg.String set_eval_mode, "select evaluator: cps"; *)
- "-gen_c", Arg.Unit (fun _ -> set_mode GenImp), "generate imperative code";
- "-gen_lustre", Arg.Unit (fun _ -> set_mode GenLus), "generate lustre model";
- "-modular", Arg.Int set_modular, "generate modular code (either for imperative or lustre backend) 0 is not modular, 1 modularize nodes, 2 modularize entry, during and exit actions (default 0)"
-]
+
+let options =
+ [
+ ( "-verbose",
+ Arg.Set_int Options.verbose_level,
+ "changes verbose \x1b[4mlevel\x1b[0m <default: 1>" );
+ ( "-model",
+ Arg.String set_model,
+ "model in {simple, stopwatch} (default: simple)" );
+ (* "-eval", Arg.Int set_trace_run_mode, "execute the model on trace <int>"; *)
+ (* "-eval-mode", Arg.String set_eval_mode, "select evaluator: cps"; *)
+ "-gen_c", Arg.Unit (fun _ -> set_mode GenImp), "generate imperative code";
+ "-gen_lustre", Arg.Unit (fun _ -> set_mode GenLus), "generate lustre model";
+ ( "-modular",
+ Arg.Int set_modular,
+ "generate modular code (either for imperative or lustre backend) 0 is \
+ not modular, 1 modularize nodes, 2 modularize entry, during and exit \
+ actions (default 0)" );
+ ]
let usage =
- "lustresf [JSON file] takes as input a stateflow model in the JSON format and a backend.\n"^
- "Backends are eother the C code generator or the lustre code generator."
+ "lustresf [JSON file] takes as input a stateflow model in the JSON format \
+ and a backend.\n"
+ ^ "Backends are eother the C code generator or the lustre code generator."
-
let _ =
Arg.parse options (fun _ -> ()) usage;
let model = List.find (fun m -> get_model_name m = !model_name) models in
let modularmode =
match !modular with
- | 2 -> true, true, true
- | 1 -> false, true, false
- | _ (* 0 *) -> false, false ,false
+ | 2 ->
+ true, true, true
+ | 1 ->
+ false, true, false
+ | _ (* 0 *) ->
+ false, false, false
in
match !mode with
- | GenImp -> (
+ | GenImp ->
let module Model = (val model) in
let module T = CPS_ccode_generator.CodeGenerator in
let module Sem = CPS.Semantics (T) (Model) in
let _ = Sem.code_gen modularmode in
()
- )
| GenLus ->
- let module Model = (val model) in
- let state_vars = Datatype.SF.states Model.model in
- let global_vars =
- List.map (fun (v,e) -> {Basetypes.GlobalVarDef.variable = v; init_val = e;})
- (Datatype.SF.global_vars Model.model) in
-
- let module T = CPS_lustre_generator.LustrePrinter (struct
- let state_vars = state_vars
- let global_vars = global_vars
- end) in
- let module Sem = CPS.Semantics (T) (Model) in
- let prog = Sem.code_gen modularmode in
- Options.print_dec_types := true;
- Format.printf "%a@." Printers.pp_prog prog;
-
- let auto_file = "sf_gen_test_auto.lus" in (* Could be changed *)
- let auto_out = open_out auto_file in
- let auto_fmt = Format.formatter_of_out_channel auto_out in
- Format.fprintf auto_fmt "%a@." Printers.pp_prog prog;
-
- let params = Backends.get_normalization_params () in
- let prog, _ = Compiler_stages.stage1 params prog "" "" ".lus" in
-
-
- Options.print_dec_types := false;
- Format.printf "%a@." Printers.pp_prog prog;
- let noauto_file = "sf_gen_test_noauto.lus" in (* Could be changed *)
- let noauto_out = open_out noauto_file in
- let noauto_fmt = Format.formatter_of_out_channel noauto_out in
- Format.fprintf noauto_fmt "%a@." Printers.pp_prog prog
-
-
-
+ let module Model = (val model) in
+ let state_vars = Datatype.SF.states Model.model in
+ let global_vars =
+ List.map
+ (fun (v, e) -> { Basetypes.GlobalVarDef.variable = v; init_val = e })
+ (Datatype.SF.global_vars Model.model)
+ in
+
+ let module T = CPS_lustre_generator.LustrePrinter (struct
+ let state_vars = state_vars
+
+ let global_vars = global_vars
+ end) in
+ let module Sem = CPS.Semantics (T) (Model) in
+ let prog = Sem.code_gen modularmode in
+ Options.print_dec_types := true;
+ Format.printf "%a@." Printers.pp_prog prog;
+
+ let auto_file = "sf_gen_test_auto.lus" in
+ (* Could be changed *)
+ let auto_out = open_out auto_file in
+ let auto_fmt = Format.formatter_of_out_channel auto_out in
+ Format.fprintf auto_fmt "%a@." Printers.pp_prog prog;
+
+ let params = Backends.get_normalization_params () in
+ let prog, _ = Compiler_stages.stage1 params prog "" "" ".lus" in
+
+ Options.print_dec_types := false;
+ Format.printf "%a@." Printers.pp_prog prog;
+ let noauto_file = "sf_gen_test_noauto.lus" in
+ (* Could be changed *)
+ let noauto_out = open_out noauto_file in
+ let noauto_fmt = Format.formatter_of_out_channel noauto_out in
+ Format.fprintf noauto_fmt "%a@." Printers.pp_prog prog
+
(* Local Variables: *)
(* compile-command: "make -C ../.. lustresf" *)
(* End: *)
diff --git a/src/tools/tiny/dune b/src/tools/tiny/dune
index 2242ea1a390cf1e676c308e61632defcadedb35e..b1c988eaad042f1b0f3f12ab45dacac46b5a6f18 100644
--- a/src/tools/tiny/dune
+++ b/src/tools/tiny/dune
@@ -9,5 +9,6 @@
(plugin
(name tiny_verifier)
(libraries lustrec.tiny_verifier)
- (site (lustrec verifiers))
+ (site
+ (lustrec verifiers))
(optional))
diff --git a/src/tools/tiny/tiny_utils.ml b/src/tools/tiny/tiny_utils.ml
index be50c1a53abe10300d1a631de6b58bb5a660b6db..912c65d09336961709f14126522a1dcb91d89175 100644
--- a/src/tools/tiny/tiny_utils.ml
+++ b/src/tools/tiny/tiny_utils.ml
@@ -1,216 +1,225 @@
-
module Ast = Tiny.Ast
let gen_loc () = Tiny.Location.dummy ()
-
-let lloc_to_tloc loc = Tiny.Location.location_of_positions loc.Location.loc_start loc.Location.loc_end
-
-let tloc_to_lloc loc = assert false (*Location.dummy_loc (*TODO*) *)
-
+let lloc_to_tloc loc =
+ Tiny.Location.location_of_positions loc.Location.loc_start
+ loc.Location.loc_end
+
+let tloc_to_lloc loc = assert false
+(*Location.dummy_loc (*TODO*) *)
+
let ltyp_to_ttyp t =
if Types.is_real_type t then Tiny.Ast.RealT
else if Types.is_int_type t then Tiny.Ast.IntT
else if Types.is_bool_type t then Tiny.Ast.BoolT
- else assert false (* not covered yet *)
+ else assert false
+(* not covered yet *)
let cst_bool loc b =
- { Ast.expr_desc =
- if b then
- Ast.Cst(Q.of_int 1, "true")
- else
- Ast.Cst(Q.of_int 0, "false");
+ {
+ Ast.expr_desc =
+ (if b then Ast.Cst (Q.of_int 1, "true")
+ else Ast.Cst (Q.of_int 0, "false"));
expr_loc = loc;
- expr_type = Ast.BoolT }
+ expr_type = Ast.BoolT;
+ }
let cst_num loc t q =
-{ Ast.expr_desc =
- Ast.Cst(q, Q.to_string q);
- expr_loc = loc;
- expr_type = t }
-
+ { Ast.expr_desc = Ast.Cst (q, Q.to_string q); expr_loc = loc; expr_type = t }
+
let rec real_to_q man exp =
- if exp = 0 then
- Q.of_string (Num.string_of_num man)
- else
- if exp > 0 then Q.div (real_to_q man (exp-1)) (Q.of_int 10)
- else (* if exp<0 then *)
- Q.mul
- (real_to_q man (exp+1))
- (Q.of_int 10)
+ if exp = 0 then Q.of_string (Num.string_of_num man)
+ else if exp > 0 then Q.div (real_to_q man (exp - 1)) (Q.of_int 10)
+ else (* if exp<0 then *)
+ Q.mul (real_to_q man (exp + 1)) (Q.of_int 10)
let instr_loc i =
match i.Machine_code_types.lustre_eq with
- | None -> gen_loc ()
- | Some eq -> lloc_to_tloc eq.eq_loc
-
+ | None ->
+ gen_loc ()
+ | Some eq ->
+ lloc_to_tloc eq.eq_loc
+
let rec lval_to_texpr loc _val =
- let build d v =
- Ast.{ expr_desc = d;
- expr_loc = gen_loc ();
- expr_type = v }
- in
+ let build d v = Ast.{ expr_desc = d; expr_loc = gen_loc (); expr_type = v } in
let new_desc =
match _val.Machine_code_types.value_desc with
- | Machine_code_types.Cst cst -> (
- match cst with
- Lustre_types.Const_int n -> Ast.Cst (Q.of_int n, string_of_int n)
- | Const_real r -> Ast.Cst (Real.to_q r, Real.to_string r)
- | _ -> assert false
- )
-
- | Var v -> Ast.Var (v.var_id)
- | Fun (op, vl) ->
- let t_arg = match vl with
- | hd::_ -> ltyp_to_ttyp hd.value_type
- | _ -> assert false
- in
- (
- match op, List.map (lval_to_texpr loc) vl with
- | "+", [v1;v2] -> Ast.Binop (Ast.Plus, v1, v2)
- | "-", [v1;v2] -> Ast.Binop (Ast.Minus, v1, v2)
- | "*", [v1;v2] -> Ast.Binop (Ast.Times, v1, v2)
- | "/", [v1;v2] -> Ast.Binop (Ast.Div, v1, v2)
- | "<", [v1;v2] ->
- Ast.Cond (build (Ast.Binop (Ast.Minus, v2, v1)) t_arg, Ast.Strict)
- | "<=", [v1;v2] ->
- Ast.Cond (build(Ast.Binop (Ast.Minus, v2, v1)) t_arg, Ast.Loose)
- | ">", [v1;v2] ->
- Ast.Cond (build(Ast.Binop (Ast.Minus, v1, v2)) t_arg, Ast.Strict)
- | ">=", [v1;v2] ->
- Ast.Cond (build (Ast.Binop (Ast.Minus, v1, v2)) t_arg, Ast.Loose)
- | "=", [v1;v2] ->
- Ast.Cond (build (Ast.Binop (Ast.Minus, v2, v1)) t_arg, Ast.Zero)
- | "!=", [v1;v2] ->
- Ast.Cond (build (Ast.Binop (Ast.Minus, v2, v1)) t_arg, Ast.NonZero)
- | "uminus", [v1] -> Ast.Binop (Ast.Minus, cst_num loc t_arg Q.zero, v1)
- | _ -> Format.eprintf "No tiny translation for operator %s@.@?" op; assert false
- )
- | _ -> assert false (* no array. access or power *)
+ | Machine_code_types.Cst cst -> (
+ match cst with
+ | Lustre_types.Const_int n ->
+ Ast.Cst (Q.of_int n, string_of_int n)
+ | Const_real r ->
+ Ast.Cst (Real.to_q r, Real.to_string r)
+ | _ ->
+ assert false)
+ | Var v ->
+ Ast.Var v.var_id
+ | Fun (op, vl) -> (
+ let t_arg =
+ match vl with
+ | hd :: _ ->
+ ltyp_to_ttyp hd.value_type
+ | _ ->
+ assert false
+ in
+ match op, List.map (lval_to_texpr loc) vl with
+ | "+", [ v1; v2 ] ->
+ Ast.Binop (Ast.Plus, v1, v2)
+ | "-", [ v1; v2 ] ->
+ Ast.Binop (Ast.Minus, v1, v2)
+ | "*", [ v1; v2 ] ->
+ Ast.Binop (Ast.Times, v1, v2)
+ | "/", [ v1; v2 ] ->
+ Ast.Binop (Ast.Div, v1, v2)
+ | "<", [ v1; v2 ] ->
+ Ast.Cond (build (Ast.Binop (Ast.Minus, v2, v1)) t_arg, Ast.Strict)
+ | "<=", [ v1; v2 ] ->
+ Ast.Cond (build (Ast.Binop (Ast.Minus, v2, v1)) t_arg, Ast.Loose)
+ | ">", [ v1; v2 ] ->
+ Ast.Cond (build (Ast.Binop (Ast.Minus, v1, v2)) t_arg, Ast.Strict)
+ | ">=", [ v1; v2 ] ->
+ Ast.Cond (build (Ast.Binop (Ast.Minus, v1, v2)) t_arg, Ast.Loose)
+ | "=", [ v1; v2 ] ->
+ Ast.Cond (build (Ast.Binop (Ast.Minus, v2, v1)) t_arg, Ast.Zero)
+ | "!=", [ v1; v2 ] ->
+ Ast.Cond (build (Ast.Binop (Ast.Minus, v2, v1)) t_arg, Ast.NonZero)
+ | "uminus", [ v1 ] ->
+ Ast.Binop (Ast.Minus, cst_num loc t_arg Q.zero, v1)
+ | _ ->
+ Format.eprintf "No tiny translation for operator %s@.@?" op;
+ assert false)
+ | _ ->
+ assert false
+ (* no array. access or power *)
in
build new_desc (ltyp_to_ttyp _val.value_type)
-
let machine_body_to_ast init m =
let init_var = ref None in
let rec guarded_expr_to_stm loc te guarded_instrs =
match guarded_instrs with
- | [] -> assert false
- | [_,il] -> instrl_to_stm il
- | (label, il)::tl ->
- let stmt = instrl_to_stm il in
- let guard= match label with
- "true" -> te
- | "false" -> Ast.neg_guard te
- | _ -> assert false (* TODO: don't deal with non boolean
- guards. Could just treturn true and
- over-approximate behavior *)
- in
- if (match !init_var, te.Ast.expr_desc with
- | Some v, Var v2 -> v = v2
- | _ -> false) then
- instrl_to_stm (
- if init then
- (List.assoc "true" guarded_instrs)
- else
- (List.assoc "false" guarded_instrs)
- )
- else
- Ast.Ite (loc, guard, stmt, guarded_expr_to_stm loc te tl)
+ | [] ->
+ assert false
+ | [ (_, il) ] ->
+ instrl_to_stm il
+ | (label, il) :: tl ->
+ let stmt = instrl_to_stm il in
+ let guard =
+ match label with
+ | "true" ->
+ te
+ | "false" ->
+ Ast.neg_guard te
+ | _ ->
+ assert false
+ (* TODO: don't deal with non boolean guards. Could just treturn true and
+ over-approximate behavior *)
+ in
+ if
+ match !init_var, te.Ast.expr_desc with
+ | Some v, Var v2 ->
+ v = v2
+ | _ ->
+ false
+ then
+ instrl_to_stm
+ (if init then List.assoc "true" guarded_instrs
+ else List.assoc "false" guarded_instrs)
+ else Ast.Ite (loc, guard, stmt, guarded_expr_to_stm loc te tl)
and instr_to_stm i =
let loc = instr_loc i in
match i.instr_desc with
| MLocalAssign (v, e) | MStateAssign (v, e) ->
- Ast.Asn (loc, v.var_id, (lval_to_texpr loc) e)
- | MBranch (e, guarded_instrs) -> (
+ Ast.Asn (loc, v.var_id, (lval_to_texpr loc) e)
+ | MBranch (e, guarded_instrs) ->
let te = lval_to_texpr loc e in
guarded_expr_to_stm loc te guarded_instrs
- )
| MStep (ol, id, args) ->
- if List.mem_assoc id m.Machine_code_types.minstances then
- let fun_name, _ = List.assoc id m.minstances in
- match Corelang.node_name fun_name, ol with
- | "_arrow", [o] -> (
- init_var := Some o.var_id;
- Ast.Nop (loc);
- (* Ast.Asn (loc, o.var_id,
- * { expr_desc = if init then Ast.Cst(Q.of_int 1, "true") else Ast.Cst(Q.of_int 0, "false");
- * expr_loc = loc;
- * expr_type = Ast.BoolT }
- * ) *)
- )
- | name, _ ->
- (
- Format.eprintf "No tiny translation for node call %s@.@?" name;
- assert false
- )
- else (
- Format.eprintf "No tiny translation for node call %s@.@?" id;
- assert false
- )
- | MReset id
- | MNoReset id -> assert false (* no more calls or functions, ie. no reset *)
- | MComment s
- | MSpec s -> assert false
+ if List.mem_assoc id m.Machine_code_types.minstances then (
+ let fun_name, _ = List.assoc id m.minstances in
+ match Corelang.node_name fun_name, ol with
+ | "_arrow", [ o ] ->
+ init_var := Some o.var_id;
+ Ast.Nop loc
+ (* Ast.Asn (loc, o.var_id, * { expr_desc = if init then Ast.Cst(Q.of_int
+ 1, "true") else Ast.Cst(Q.of_int 0, "false"); * expr_loc = loc; *
+ expr_type = Ast.BoolT } * ) *)
+ | name, _ ->
+ Format.eprintf "No tiny translation for node call %s@.@?" name;
+ assert false)
+ else (
+ Format.eprintf "No tiny translation for node call %s@.@?" id;
+ assert false)
+ | MReset id | MNoReset id ->
+ assert false (* no more calls or functions, ie. no reset *)
+ | MComment s | MSpec s ->
+ assert false
and instrl_to_stm il =
match il with
- [] -> assert false
- | [i] -> instr_to_stm i
- | i::il ->
- let i' = instr_to_stm i in
- Ast.Seq (gen_loc (), i', (instrl_to_stm il))
+ | [] ->
+ assert false
+ | [ i ] ->
+ instr_to_stm i
+ | i :: il ->
+ let i' = instr_to_stm i in
+ Ast.Seq (gen_loc (), i', instrl_to_stm il)
in
- instrl_to_stm m.Machine_code_types.mstep.step_instrs
+ instrl_to_stm m.Machine_code_types.mstep.step_instrs
let read_var bounds_opt v =
let min, max =
match bounds_opt with
- Some (min,max) -> min, max
- | None -> (Q.of_int (-1), "-1"), (Q.of_int 1, "1")
+ | Some (min, max) ->
+ min, max
+ | None ->
+ (Q.of_int (-1), "-1"), (Q.of_int 1, "1")
in
- let range = {
- Ast.expr_desc = Ast.Rand (min,max);
+ let range =
+ {
+ Ast.expr_desc = Ast.Rand (min, max);
expr_loc = gen_loc ();
- expr_type = ltyp_to_ttyp (v.Lustre_types.var_type)
+ expr_type = ltyp_to_ttyp v.Lustre_types.var_type;
}
in
Ast.Asn (gen_loc (), v.var_id, range)
-
+
let rec read_vars bounds_inputs vl =
match vl with
- [] -> Ast.Nop (gen_loc ())
- | [v] -> read_var
- (if List.mem_assoc v.Lustre_types.var_id bounds_inputs then
- Some (List.assoc v.Lustre_types.var_id bounds_inputs)
- else
- None)
- v
- | v::tl ->
- Ast.Seq (gen_loc (),
- read_var
- (if List.mem_assoc v.Lustre_types.var_id bounds_inputs then
- Some (List.assoc v.Lustre_types.var_id bounds_inputs)
- else
- None)
- v,
- read_vars bounds_inputs tl
- )
-
+ | [] ->
+ Ast.Nop (gen_loc ())
+ | [ v ] ->
+ read_var
+ (if List.mem_assoc v.Lustre_types.var_id bounds_inputs then
+ Some (List.assoc v.Lustre_types.var_id bounds_inputs)
+ else None)
+ v
+ | v :: tl ->
+ Ast.Seq
+ ( gen_loc (),
+ read_var
+ (if List.mem_assoc v.Lustre_types.var_id bounds_inputs then
+ Some (List.assoc v.Lustre_types.var_id bounds_inputs)
+ else None)
+ v,
+ read_vars bounds_inputs tl )
+
let machine_to_ast bounds_input m =
- let read_vars = read_vars bounds_input m.Machine_code_types.mstep.step_inputs in
+ let read_vars =
+ read_vars bounds_input m.Machine_code_types.mstep.step_inputs
+ in
let ast_loop_first = machine_body_to_ast true m in
let ast_loop_run = machine_body_to_ast false m in
let ast_loop_body = Ast.Seq (gen_loc (), read_vars, ast_loop_run) in
- let loop = Ast.While(gen_loc (), cst_bool (gen_loc ()) true, ast_loop_body) in
- Ast.Seq (gen_loc (), read_vars, (Ast.Seq (gen_loc (), ast_loop_first, loop)))
-
+ let loop =
+ Ast.While (gen_loc (), cst_bool (gen_loc ()) true, ast_loop_body)
+ in
+ Ast.Seq (gen_loc (), read_vars, Ast.Seq (gen_loc (), ast_loop_first, loop))
+
let machine_to_env m =
-
- List.fold_left (fun accu v ->
- let typ =
- ltyp_to_ttyp (v.Lustre_types.var_type)
- in
+ List.fold_left
+ (fun accu v ->
+ let typ = ltyp_to_ttyp v.Lustre_types.var_type in
Ast.VarSet.add (v.var_id, typ) accu)
Ast.VarSet.empty
(Machine_code_common.machine_vars m)
-
diff --git a/src/tools/tiny/tiny_verifier.ml b/src/tools/tiny/tiny_verifier.ml
index 071e1430295b1acd7401fac0dbea2ab449dfbf99..709e79b513c3bd8d323910af2d80085e3dc0e2fb 100644
--- a/src/tools/tiny/tiny_verifier.ml
+++ b/src/tools/tiny/tiny_verifier.ml
@@ -1,141 +1,143 @@
-
let active = ref false
+
let tiny_debug = ref false
+
let tiny_help = ref false
+
let descending = ref 1
-let unrolling = ref 0
+let unrolling = ref 0
-
let quiet () = Tiny.Report.verbosity := 0
-
+
let print_tiny_help () =
let open Format in
- Format.eprintf "@[Tiny verifier plugin produces a simple imperative code \
- output for the provided main node, inlining all calls. This \
- code can then be analyzed using tiny analyzer options.@]";
+ Format.eprintf
+ "@[Tiny verifier plugin produces a simple imperative code output for the \
+ provided main node, inlining all calls. This code can then be analyzed \
+ using tiny analyzer options.@]";
Format.eprintf "@.@?";
flush stdout
-
let tiny_run ~basename prog machines =
- if !tiny_help then (
- let _ = print_tiny_help () in
- exit 0
- );
+ (if !tiny_help then
+ let _ = print_tiny_help () in
+ exit 0);
let node_name =
match !Options.main_node with
- | "" -> (
+ | "" ->
Format.eprintf "Tiny verifier requires a main node.@.";
Format.eprintf "@[<v 2>Available ones are:@ %a@]@.@?"
- (Utils.fprintf_list ~sep:"@ "
- (fun fmt m ->
- Format.fprintf fmt "%s" m.Machine_code_types.mname.node_id
- )
- )
- machines;
+ (Utils.fprintf_list ~sep:"@ " (fun fmt m ->
+ Format.fprintf fmt "%s" m.Machine_code_types.mname.node_id))
+ machines;
exit 1
- )
- | s -> ( (* should have been addessed before *)
+ | s -> (
+ (* should have been addessed before *)
match Machine_code_common.get_machine_opt machines s with
- | None -> begin
- Global.main_node := s;
- Format.eprintf "Code generation error: %a@." Error.pp_error_msg Error.Main_not_found;
- raise (Error.Error (Location.dummy_loc, Error.Main_not_found))
- end
- | Some _ -> s
- )
+ | None ->
+ Global.main_node := s;
+ Format.eprintf "Code generation error: %a@." Error.pp_error_msg
+ Error.Main_not_found;
+ raise (Error.Error (Location.dummy_loc, Error.Main_not_found))
+ | Some _ ->
+ s)
in
let m = Machine_code_common.get_machine machines node_name in
- let env = (* We add each variables of the node the Tiny env *)
- Tiny_utils.machine_to_env m in
+ let env =
+ (* We add each variables of the node the Tiny env *)
+ Tiny_utils.machine_to_env m
+ in
let nd = m.mname in
(* Building preamble with some bounds on inputs *)
(* TODO: deal woth contracts, asserts, ... *)
let bounds_inputs = [] in
let ast = Tiny_utils.machine_to_ast bounds_inputs m in
let mems = m.mmemory in
-
- Format.printf "%a@." Tiny.Ast.fprint_stm ast;
-
- let dom =
- let open Tiny.Load_domains in
- prepare_domains (List.map get_domain !domains)
- in
- let results = Tiny.Analyze.analyze dom !descending !unrolling env ast in
- let module Results = (val results: Tiny.Analyze.Results) in
- let module Dom = Results.Dom in
- let module PrintResults = Tiny.PrintResults.Make (Dom) in
- let m = Results.results in
- (* if !Tiny.Report.verbosity > 1 then *)
- PrintResults.print m ast None (* no !output_file *);
- (* else PrintResults.print_invariants m ast !output_file *)
-
- ()
-
-
-module Verifier =
- (struct
- include VerifierType.Default
- let name = "tiny"
- let options =
- [
- "-debug", Arg.Set tiny_debug, "tiny debug";
- ("-abstract-domain", Arg.String Tiny.Load_domains.decl_domain,
- "<domain> Use abstract domain <domain> " ^ Tiny.Domains.available_domains_str);
- (* ("-a", Arg.String Tiny.Load_domains.decl_domain,
- * "<domain> Use abstract domain <domain> " ^ Tiny.Domains.available_domains_str); *)
- ("-param", Arg.String Tiny.Load_domains.set_param,
- "<p> Send <p> to the abstract domain, syntax <dom>:<p> can be used \
- to target the (sub)domain <dom>");
- (* ("-p", Arg.String Tiny.Load_domains.set_param,
- * "<p> Send <p> to the abstract domain, syntax <dom>:<p> can be used \
- * to target the (sub)domain <dom>"); *)
- ("-help-domain", Arg.String Tiny.Load_domains.help_domain,
- "<domain> Print params of <domain>");
- (* ("-h", Arg.String Tiny.Load_domains.help_domain, "<domain> Print params of <domain>"); *)
- (* ("--compile", Arg.Set compile_mode, " Compilation mode: compile to C");
- ("-c", Arg.Set compile_mode, " Compilation mode: compile to C");*)
-
- ("-quiet", Arg.Unit quiet, " Quiet mode");
- (* ("-q", Arg.Unit quiet, " Quiet mode"); *)
- ("-verbose", Arg.Set_int Tiny.Report.verbosity,
- "<n> Verbosity level (default is 1)");
- (* ("-v", Arg.Set_int Tiny.Report.verbosity, "<n> Verbosity level (default is 1)"); *)
- (* ("--output", Arg.String set_output_file,
- "<filename> Output results to file <filename> (default is \
- standard ouput)");
- ("-o", Arg.String set_output_file,
- "<filename> Output results to file <filename> (default is standard ouput)");
- *)
- ("-descending", Arg.Set_int descending,
- "<n> Perform <n> descending iterations after fixpoint of a loop \
- is reached (default is 1)");
- (* ("-d", Arg.Set_int descending,
- * "<n> Perform <n> descending iterations after fixpoint of a loop \
- * is reached (default is 1)"); *)
- ("-unrolling", Arg.Set_int unrolling,
- "<n> Unroll loops <n> times before computing fixpoint (default is 0)");
+
+ Format.printf "%a@." Tiny.Ast.fprint_stm ast;
+
+ let dom =
+ let open Tiny.Load_domains in
+ prepare_domains (List.map get_domain !domains)
+ in
+ let results = Tiny.Analyze.analyze dom !descending !unrolling env ast in
+ let module Results = (val results : Tiny.Analyze.Results) in
+ let module Dom = Results.Dom in
+ let module PrintResults = Tiny.PrintResults.Make (Dom) in
+ let m = Results.results in
+ (* if !Tiny.Report.verbosity > 1 then *)
+ PrintResults.print m ast None (* no !output_file *);
+
+ (* else PrintResults.print_invariants m ast !output_file *)
+ ()
+
+module Verifier : VerifierType.S = struct
+ include VerifierType.Default
+
+ let name = "tiny"
+
+ let options =
+ [
+ "-debug", Arg.Set tiny_debug, "tiny debug";
+ ( "-abstract-domain",
+ Arg.String Tiny.Load_domains.decl_domain,
+ "<domain> Use abstract domain <domain> "
+ ^ Tiny.Domains.available_domains_str );
+ (* ("-a", Arg.String Tiny.Load_domains.decl_domain,
+ * "<domain> Use abstract domain <domain> " ^ Tiny.Domains.available_domains_str); *)
+ ( "-param",
+ Arg.String Tiny.Load_domains.set_param,
+ "<p> Send <p> to the abstract domain, syntax <dom>:<p> can be used to \
+ target the (sub)domain <dom>" );
+ (* ("-p", Arg.String Tiny.Load_domains.set_param,
+ * "<p> Send <p> to the abstract domain, syntax <dom>:<p> can be used \
+ * to target the (sub)domain <dom>"); *)
+ ( "-help-domain",
+ Arg.String Tiny.Load_domains.help_domain,
+ "<domain> Print params of <domain>" );
+ (* ("-h", Arg.String Tiny.Load_domains.help_domain, "<domain> Print params
+ of <domain>"); *)
+ (* ("--compile", Arg.Set compile_mode, " Compilation mode: compile to C");
+ ("-c", Arg.Set compile_mode, " Compilation mode: compile to C");*)
+ "-quiet", Arg.Unit quiet, " Quiet mode";
+ (* ("-q", Arg.Unit quiet, " Quiet mode"); *)
+ ( "-verbose",
+ Arg.Set_int Tiny.Report.verbosity,
+ "<n> Verbosity level (default is 1)" );
+ (* ("-v", Arg.Set_int Tiny.Report.verbosity, "<n> Verbosity level (default
+ is 1)"); *)
+ (* ("--output", Arg.String set_output_file, "<filename> Output results to
+ file <filename> (default is \ standard ouput)"); ("-o", Arg.String
+ set_output_file, "<filename> Output results to file <filename> (default
+ is standard ouput)"); *)
+ ( "-descending",
+ Arg.Set_int descending,
+ "<n> Perform <n> descending iterations after fixpoint of a loop is \
+ reached (default is 1)" );
+ (* ("-d", Arg.Set_int descending,
+ * "<n> Perform <n> descending iterations after fixpoint of a loop \
+ * is reached (default is 1)"); *)
+ ( "-unrolling",
+ Arg.Set_int unrolling,
+ "<n> Unroll loops <n> times before computing fixpoint (default is 0)" );
(* (\* ("-u", Arg.Set_int unrolling,
* * "<n> Unroll loops <n> times before computing fixpoint (default is 0)"); *\) *)
- "-help", Arg.Set tiny_help, "tiny help and usage";
-
-
- ]
-
- let activate () =
- active := true;
- (* Options.global_inline := true;
- * Options.optimization := 0;
- * Options.const_unfold := true; *)
- ()
-
- let is_active () = !active
- let run = tiny_run
-
-
- end: VerifierType.S)
+ "-help", Arg.Set tiny_help, "tiny help and usage";
+ ]
+
+ let activate () =
+ active := true;
+ (* Options.global_inline := true;
+ * Options.optimization := 0;
+ * Options.const_unfold := true; *)
+ ()
+
+ let is_active () = !active
+
+ let run = tiny_run
+end
let () =
- VerifierList.registered := (module Verifier : VerifierType.S) ::
- !VerifierList.registered
+ VerifierList.registered :=
+ (module Verifier : VerifierType.S) :: !VerifierList.registered
diff --git a/src/tools/zustre/dune b/src/tools/zustre/dune
index 0b5140f99df3b3aadbe815b0be83723674eb7e7c..a023cb4237dae063a197c2719e45fd15241b538d 100644
--- a/src/tools/zustre/dune
+++ b/src/tools/zustre/dune
@@ -11,5 +11,6 @@
(plugin
(name zustre_verifier)
(libraries lustrec.zustre_verifier)
- (site (lustrec verifiers))
+ (site
+ (lustrec verifiers))
(optional))
diff --git a/src/tools/zustre/zustre_analyze.ml b/src/tools/zustre/zustre_analyze.ml
index cf039268710ea8cdea754c8addafbab167c220bf..9a7c08afb8e1540ee0812aaaf50acfb6861f6d44 100644
--- a/src/tools/zustre/zustre_analyze.ml
+++ b/src/tools/zustre/zustre_analyze.ml
@@ -1,65 +1,62 @@
(* This module takes a main node (reset and step) and a property. It assumes
- that the system is properly defined and check that the property is valid.
+ that the system is properly defined and check that the property is valid.
When valid, it returns a set of local invariants. Otherwise, it returns a cex
- expressed as a sequence of input values.
-
-*)
+ expressed as a sequence of input values. *)
open Lustre_types
open Machine_code_types
open Machine_code_common
open Zustre_common
open Zustre_data
-let idx_0 = Z3.Arithmetic.Integer.mk_numeral_i !ctx 0
-let uid_0 = Z3.Z3List.nil uid_sort
-
-let check machines node =
+let idx_0 = Z3.Arithmetic.Integer.mk_numeral_i !ctx 0
+
+let uid_0 = Z3.Z3List.nil uid_sort
+let check machines node =
let machine = get_machine machines node in
let node_id = machine.mname.node_id in
+
(* Declaring collecting semantics *)
-
- let main_output =
- rename_machine_list node_id machine.mstep.step_outputs
- in
+ let main_output = rename_machine_list node_id machine.mstep.step_outputs in
let main_output_dummy =
rename_machine_list ("dummy" ^ node_id) machine.mstep.step_outputs
in
- let main_input =
- rename_machine_list node_id machine.mstep.step_inputs
- in
- let main_input_dummy =
+ let main_input = rename_machine_list node_id machine.mstep.step_inputs in
+ let main_input_dummy =
rename_machine_list ("dummy" ^ node_id) machine.mstep.step_inputs
- in
+ in
let main_memory_next =
- main_input @ (rename_next_list (* machine.mname.node_id *) (full_memory_vars machines machine)) @
- main_output
+ main_input
+ @ rename_next_list
+ (* machine.mname.node_id *)
+ (full_memory_vars machines machine)
+ @ main_output
in
let main_memory_current =
- main_input_dummy @ (rename_current_list (* machine.mname.node_id *) (full_memory_vars machines machine)) @
- main_output_dummy
+ main_input_dummy
+ @ rename_current_list
+ (* machine.mname.node_id *)
+ (full_memory_vars machines machine)
+ @ main_output_dummy
in
- (* TODO: push/pop? donner un nom different par instance pour les garder dans le buffer ?
- Faut-il declarer les "rel" dans la hashtbl ?
- *)
-
+ (* TODO: push/pop? donner un nom different par instance pour les garder dans
+ le buffer ? Faut-il declarer les "rel" dans la hashtbl ? *)
let main_name node_id = "MAIN" ^ "_" ^ node_id in
-
+
let decl_main =
- decl_rel ~no_additional_vars:true
- (main_name node_id)
- (int_sort::(List.map (fun v -> type_to_sort v.var_type) (main_memory_next))) in
+ decl_rel ~no_additional_vars:true (main_name node_id)
+ (int_sort :: List.map (fun v -> type_to_sort v.var_type) main_memory_next)
+ in
-
-
(* Init case *)
let decl_init = decl_rel ~no_additional_vars:true "INIT_STATE" [] in
(* (special) rule INIT_STATE *)
let init_expr = Z3.Expr.mk_app !ctx decl_init [] in
Z3.Fixedpoint.add_rule !fp init_expr None;
+
(* let _ = add_rule [] (Z3.Expr.mk_app *)
(* !ctx *)
(* decl_init *)
@@ -69,163 +66,167 @@ let check machines node =
(* Re-declaring variables *)
let _ = List.map decl_var main_memory_next in
- let horn_head =
- Z3.Expr.mk_app
- !ctx
- decl_main
- (idx_0::(* uid_0:: *)(List.map horn_var_to_expr main_memory_next))
+ let horn_head =
+ Z3.Expr.mk_app !ctx decl_main
+ (idx_0 :: (* uid_0:: *)
+ List.map horn_var_to_expr main_memory_next)
in
(* Special case when the main node is stateless *)
let _ =
if Machine_code_common.is_stateless machine then
- begin
-
- (* Initial set: One Step(m,x) -- Stateless node *)
- (* rule => (INIT_STATE and step(mid, next)) MAIN(next) *)
-
- (* Note that vars here contains main_memory_next *)
- let vars = step_vars_m_x machines machine in
- (* Re-declaring variables *)
- let _ = List.map decl_var vars in
-
- let horn_body =
- Z3.Boolean.mk_and !ctx
- [
- Z3.Expr.mk_app !ctx decl_init [];
- Z3.Expr.mk_app !ctx
- (get_fdecl (machine_stateless_name node))
- (idx_0::uid_0::(List.map horn_var_to_expr vars))
- ]
- in
- add_rule vars (Z3.Boolean.mk_implies !ctx horn_body horn_head)
-
-
- end
+ (* Initial set: One Step(m,x) -- Stateless node *)
+ (* rule => (INIT_STATE and step(mid, next)) MAIN(next) *)
+
+ (* Note that vars here contains main_memory_next *)
+ let vars = step_vars_m_x machines machine in
+ (* Re-declaring variables *)
+ let _ = List.map decl_var vars in
+
+ let horn_body =
+ Z3.Boolean.mk_and !ctx
+ [
+ Z3.Expr.mk_app !ctx decl_init [];
+ Z3.Expr.mk_app !ctx
+ (get_fdecl (machine_stateless_name node))
+ (idx_0 :: uid_0 :: List.map horn_var_to_expr vars);
+ ]
+ in
+ add_rule vars (Z3.Boolean.mk_implies !ctx horn_body horn_head)
else
- begin
- (* Initial set: Reset(c,m) + One Step(m,x) @. *)
-
- (* Re-declaring variables *)
- let vars_reset = reset_vars machines machine in
- let vars_step = step_vars_m_x machines machine in
- let vars_step_all = step_vars_c_m_x machines machine in
- let _ = List.map decl_var (vars_reset @ vars_step @ vars_step_all ) in
-
- (* rule => (INIT_STATE and reset(mid) and step(mid, next)) MAIN(next) *)
- let horn_body =
- Z3.Boolean.mk_and !ctx
- [
- Z3.Expr.mk_app !ctx decl_init [];
- Z3.Expr.mk_app !ctx
- (get_fdecl (machine_reset_name node))
- (idx_0::uid_0::List.map horn_var_to_expr (reset_vars machines machine));
- Z3.Expr.mk_app !ctx
- (get_fdecl (machine_step_name node))
- (idx_0::uid_0::List.map horn_var_to_expr (step_vars_m_x machines machine))
- ]
- in
-
- (* Vars contains all vars: in_out, current, mid, neXt memories *)
- let vars = step_vars_c_m_x machines machine in
- add_rule vars (Z3.Boolean.mk_implies !ctx horn_body horn_head)
-
-
- end
+ (* Initial set: Reset(c,m) + One Step(m,x) @. *)
+
+ (* Re-declaring variables *)
+ let vars_reset = reset_vars machines machine in
+ let vars_step = step_vars_m_x machines machine in
+ let vars_step_all = step_vars_c_m_x machines machine in
+ let _ = List.map decl_var (vars_reset @ vars_step @ vars_step_all) in
+
+ (* rule => (INIT_STATE and reset(mid) and step(mid, next)) MAIN(next) *)
+ let horn_body =
+ Z3.Boolean.mk_and !ctx
+ [
+ Z3.Expr.mk_app !ctx decl_init [];
+ Z3.Expr.mk_app !ctx
+ (get_fdecl (machine_reset_name node))
+ (idx_0
+ ::
+ uid_0 :: List.map horn_var_to_expr (reset_vars machines machine));
+ Z3.Expr.mk_app !ctx
+ (get_fdecl (machine_step_name node))
+ (idx_0
+ ::
+ uid_0
+ :: List.map horn_var_to_expr (step_vars_m_x machines machine));
+ ]
+ in
+
+ (* Vars contains all vars: in_out, current, mid, neXt memories *)
+ let vars = step_vars_c_m_x machines machine in
+ add_rule vars (Z3.Boolean.mk_implies !ctx horn_body horn_head)
in
-
- let step_name =
- if Machine_code_common.is_stateless machine then
- machine_stateless_name
- else
- machine_step_name
+
+ let step_name =
+ if Machine_code_common.is_stateless machine then machine_stateless_name
+ else machine_step_name
in
-
- (* ; Inductive def@. *)
+ (* ; Inductive def@. *)
List.iter (fun x -> ignore (decl_var x)) (main_output_dummy @ main_input_dummy);
-
- (* (Utils.fprintf_list ~sep:" " (fun fmt v -> fprintf fmt "%a@." pp_decl_var v)) fmt main_output_dummy; *)
+
+ (* (Utils.fprintf_list ~sep:" " (fun fmt v -> fprintf fmt "%a@." pp_decl_var
+ v)) fmt main_output_dummy; *)
(* fprintf fmt *)
- (* "@[<v 2>(rule (=> @ (and @[<v 0>(MAIN %a)@ (@[<v 0>%a %a@])@]@ )@ (MAIN %a)@]@.))@.@." *)
+ (* "@[<v 2>(rule (=> @ (and @[<v 0>(MAIN %a)@ (@[<v 0>%a %a@])@]@ )@ (MAIN
+ %a)@]@.))@.@." *)
(* (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) main_memory_current *)
(* step_name node *)
- (* (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) (step_vars machines machine) *)
-
- let k = Corelang.dummy_var_decl "k" Type_predef.type_int (*Corelang.mktyp Location.dummy_loc Types.type_int*) in
+ (* (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) (step_vars machines
+ machine) *)
+ let k =
+ Corelang.dummy_var_decl "k" Type_predef.type_int
+ (*Corelang.mktyp Location.dummy_loc Types.type_int*)
+ in
let k_var = Z3.Expr.mk_const_f !ctx (decl_var k) in
-
- let horn_head =
- Z3.Expr.mk_app
- !ctx
- decl_main
- ((Z3.Arithmetic.mk_add
- !ctx
- [k_var; Z3.Arithmetic.Integer.mk_numeral_i !ctx 1]
- )::(List.map horn_var_to_expr main_memory_next))
+
+ let horn_head =
+ Z3.Expr.mk_app !ctx decl_main
+ (Z3.Arithmetic.mk_add !ctx
+ [ k_var; Z3.Arithmetic.Integer.mk_numeral_i !ctx 1 ]
+ :: List.map horn_var_to_expr main_memory_next)
in
let horn_body =
Z3.Boolean.mk_and !ctx
[
- Z3.Expr.mk_app !ctx decl_main (k_var::(List.map horn_var_to_expr main_memory_current));
- Z3.Expr.mk_app !ctx (get_fdecl (step_name node)) (k_var::uid_0::List.map horn_var_to_expr (step_vars machines machine))
+ Z3.Expr.mk_app !ctx decl_main
+ (k_var :: List.map horn_var_to_expr main_memory_current);
+ Z3.Expr.mk_app !ctx
+ (get_fdecl (step_name node))
+ (k_var
+ :: uid_0 :: List.map horn_var_to_expr (step_vars machines machine));
]
in
(* Vars contains all vars: in_out, current, mid, neXt memories *)
- let vars = (step_vars_c_m_x machines machine) @ main_output_dummy @ main_input_dummy in
+ let vars =
+ step_vars_c_m_x machines machine @ main_output_dummy @ main_input_dummy
+ in
let _ =
- add_rule ~dont_touch:[decl_main] (k::vars) (Z3.Boolean.mk_implies !ctx horn_body horn_head)
-
+ add_rule ~dont_touch:[ decl_main ] (k :: vars)
+ (Z3.Boolean.mk_implies !ctx horn_body horn_head)
in
-
(* Property def *)
let decl_err = decl_rel ~no_additional_vars:true "ERR" [] in
- let prop =
- Z3.Boolean.mk_and !ctx (List.map horn_var_to_expr main_output)
- in
- let not_prop =
- Z3.Boolean.mk_not !ctx prop
- in
- add_rule (*~dont_touch:[decl_main;decl_err]*) (k::main_memory_next) (Z3.Boolean.mk_implies !ctx
- (
- Z3.Boolean.mk_and !ctx
- [not_prop;
- Z3.Expr.mk_app !ctx decl_main (k_var::List.map horn_var_to_expr main_memory_next);
- ]
- )
- (Z3.Expr.mk_app !ctx decl_err []))
- ;
-
- (* fprintf fmt "@[<v 2>(rule (=> @ (and @[<v 0>(not %a)@ (MAIN %a)@])@ ERR))@." *)
- (* (pp_conj (pp_horn_var machine)) main_output *)
- (* (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) main_memory_next *)
- (* ; *)
- (* if !Options.horn_query then fprintf fmt "(query ERR)@." *)
-
- (* Debug instructions *)
+ let prop = Z3.Boolean.mk_and !ctx (List.map horn_var_to_expr main_output) in
+ let not_prop = Z3.Boolean.mk_not !ctx prop in
+ add_rule
+ (*~dont_touch:[decl_main;decl_err]*)
+ (k :: main_memory_next)
+ (Z3.Boolean.mk_implies !ctx
+ (Z3.Boolean.mk_and !ctx
+ [
+ not_prop;
+ Z3.Expr.mk_app !ctx decl_main
+ (k_var :: List.map horn_var_to_expr main_memory_next);
+ ])
+ (Z3.Expr.mk_app !ctx decl_err []));
+
+ (* fprintf fmt "@[<v 2>(rule (=> @ (and @[<v 0>(not %a)@ (MAIN %a)@])@
+ ERR))@." *)
+ (* (pp_conj (pp_horn_var machine)) main_output *)
+ (* (Utils.fprintf_list ~sep:" " (pp_horn_var machine)) main_memory_next *)
+ (* ; *)
+ (* if !Options.horn_query then fprintf fmt "(query ERR)@." *)
+
+ (* Debug instructions *)
let rules_expr = Z3.Fixedpoint.get_rules !fp in
if !debug then
Format.eprintf "@[<v 2>Registered rules:@ %a@ @]@."
- (Utils.fprintf_list ~sep:"@ "
- (fun fmt e -> Format.pp_print_string fmt (Z3.Expr.to_string e)) )
+ (Utils.fprintf_list ~sep:"@ " (fun fmt e ->
+ Format.pp_print_string fmt (Z3.Expr.to_string e)))
rules_expr;
try
- let res_status = Z3.Fixedpoint.query_r !fp [decl_err] in
-
+ let res_status = Z3.Fixedpoint.query_r !fp [ decl_err ] in
+
Format.eprintf "Status: %s@." (Z3.Solver.string_of_status res_status);
match res_status with
- | Z3.Solver.SATISFIABLE -> Zustre_cex.build_cex machine machines decl_err
-
- | Z3.Solver.UNSATISFIABLE -> (*build_inv*) (
+ | Z3.Solver.SATISFIABLE ->
+ Zustre_cex.build_cex machine machines decl_err
+ | Z3.Solver.UNSATISFIABLE -> (
+ (*build_inv*)
let expr_opt = Z3.Fixedpoint.get_answer !fp in
match expr_opt with
- None -> if !debug then Format.eprintf "Unsat No feedback@."
- | Some e -> if !debug then Format.eprintf "Unsat Result: %s@." (Z3.Expr.to_string e)
- )
- | Z3.Solver.UNKNOWN -> ()
- with Z3.Error msg -> Format.eprintf "Z3 failure: %s@." msg; ()
+ | None ->
+ if !debug then Format.eprintf "Unsat No feedback@."
+ | Some e ->
+ if !debug then Format.eprintf "Unsat Result: %s@." (Z3.Expr.to_string e)
+ )
+ | Z3.Solver.UNKNOWN ->
+ ()
+ with Z3.Error msg ->
+ Format.eprintf "Z3 failure: %s@." msg;
+ ()
(* Local Variables: *)
(* compile-command:"make -C ../.. lustrev" *)
(* End: *)
diff --git a/src/tools/zustre/zustre_cex.ml b/src/tools/zustre/zustre_cex.ml
index 9556e1023cbb238be6dde137a5a2caed6e9023ee..e5af5889805b48223f147304a3f35cf3580095ea 100644
--- a/src/tools/zustre/zustre_cex.ml
+++ b/src/tools/zustre/zustre_cex.ml
@@ -1,43 +1,43 @@
(* Rebuilding Cex *)
(* In order to properly rebuild the Cex, one needsthe unsliced model. Otherwise
- some input or state variables are removed.
-
-*)
-
+ some input or state variables are removed. *)
open Lustre_types
open Machine_code_types
+
(* open Machine_code_common *)
open Zustre_common
-
open Zustre_data
let get_conjuncts e =
assert (Z3.Boolean.is_bool e);
- if Z3.Boolean.is_and e then
- Z3.Expr.get_args e
- else
- [e]
+ if Z3.Boolean.is_and e then Z3.Expr.get_args e else [ e ]
let build_cex machine machines _decl_err =
- (* Recovering associated top machine (to build full traces) and property *)
+ (* Recovering associated top machine (to build full traces) and property *)
(* TODO: for example extract top node and ok prop. We may have multiple
MAIN/ERR loaded at the same time. Each of them should be assocaited with a
CEX/Inv/Timeout.*)
-
let node_id = machine.mname.node_id in
- let cex = match Z3.Fixedpoint.get_answer !fp with Some e -> e | None -> raise Not_found in
- (* Original code used the function Z3.Fixedpoint.get_ground_sat_answer !fp *)
+ let cex =
+ match Z3.Fixedpoint.get_answer !fp with
+ | Some e ->
+ e
+ | None ->
+ raise Not_found
+ in
+ (* Original code used the function Z3.Fixedpoint.get_ground_sat_answer !fp *)
let stats = Z3.Fixedpoint.get_statistics !fp in
-
+
let conjuncts = List.rev (get_conjuncts cex) in
- Format.eprintf "cex: %s@.%i conjuncts: @[<v 0>%a@]@."
- (Z3.Expr.to_string cex)
+ Format.eprintf "cex: %s@.%i conjuncts: @[<v 0>%a@]@." (Z3.Expr.to_string cex)
(List.length conjuncts)
- (Utils.fprintf_list ~sep:"@ " (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e))) conjuncts;
+ (Utils.fprintf_list ~sep:"@ " (fun fmt e ->
+ Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
+ conjuncts;
(* Checking size *)
let inputs = machine.mstep.step_inputs in
@@ -45,78 +45,92 @@ let build_cex machine machines _decl_err =
let outputs = machine.mstep.step_outputs in
let nb_outputs = List.length inputs in
let nb_mems = List.length (full_memory_vars machines machine) in
-
+
let main, _ =
- List.fold_left (fun (main, funs) conj ->
- (* Filtering out non MAIN decls *)
- let func_decl = Z3.Expr.get_func_decl conj in
- let node_name = Z3.Symbol.get_string (Z3.FuncDecl.get_name func_decl) in
- (* Focusing only on MAIN_nodeid predicates *)
- if node_name = "MAIN_" ^ node_id then
- (* Extracting info *)
- (* Recall that MAIN args are in@mems@out *)
- let args = Z3.Expr.get_args conj in
- if List.length args = 1 + nb_inputs + nb_mems + nb_outputs then
- (* Should be done with get_int but that function vanished from the opam Z3 API *)
- let id = Z.to_int (Z3.Arithmetic.Integer.get_big_int (List.hd args)) in
- let input_values = Utils.List.extract args 1 (1 + nb_inputs) in
- let output_values = Utils.List.extract args (1+nb_inputs+nb_mems) (1 + nb_inputs + nb_mems + nb_outputs) in
- (id, (input_values, output_values))::main, funs
- else
- assert false
- else
- let reg = Str.regexp_string "[a-z]*_step" in
- if Str.string_match reg node_name 0 then (
- let actual_name = Str.matched_group 0 node_name in
- Format.eprintf "Name %s@." actual_name;
- main, funs
- )
- else (
- Format.eprintf "pas matché %s@." node_name;
- main, funs
- )
- ) ((* main*) [],(* other functions *) []) conjuncts
+ List.fold_left
+ (fun (main, funs) conj ->
+ (* Filtering out non MAIN decls *)
+ let func_decl = Z3.Expr.get_func_decl conj in
+ let node_name = Z3.Symbol.get_string (Z3.FuncDecl.get_name func_decl) in
+ (* Focusing only on MAIN_nodeid predicates *)
+ if node_name = "MAIN_" ^ node_id then
+ (* Extracting info *)
+ (* Recall that MAIN args are in@mems@out *)
+ let args = Z3.Expr.get_args conj in
+ if List.length args = 1 + nb_inputs + nb_mems + nb_outputs then
+ (* Should be done with get_int but that function vanished from the
+ opam Z3 API *)
+ let id =
+ Z.to_int (Z3.Arithmetic.Integer.get_big_int (List.hd args))
+ in
+ let input_values = Utils.List.extract args 1 (1 + nb_inputs) in
+ let output_values =
+ Utils.List.extract args
+ (1 + nb_inputs + nb_mems)
+ (1 + nb_inputs + nb_mems + nb_outputs)
+ in
+ (id, (input_values, output_values)) :: main, funs
+ else assert false
+ else
+ let reg = Str.regexp_string "[a-z]*_step" in
+ if Str.string_match reg node_name 0 then (
+ let actual_name = Str.matched_group 0 node_name in
+ Format.eprintf "Name %s@." actual_name;
+ main, funs)
+ else (
+ Format.eprintf "pas matché %s@." node_name;
+ main, funs))
+ ((* main*)
+ [], (* other functions *)
+ [])
+ conjuncts
in
let main = List.sort (fun (id1, _) (id2, _) -> compare id1 id2) main in
- List.iter (
- fun (id, expr) ->
- Format.eprintf "Id %i: %a@."
- (id)
- (Utils.fprintf_list ~sep:", "
- (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
- (fst expr)
- ) main;
- (* let ground_val = List.map (fun e -> Z3.Expr.to_string e) (Z3.Expr.get_args conj) in *)
-
- (* We recover the Zustre XML format, projecting each cex on each input/output
- signal *)
+ List.iter
+ (fun (id, expr) ->
+ Format.eprintf "Id %i: %a@." id
+ (Utils.fprintf_list ~sep:", " (fun fmt e ->
+ Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
+ (fst expr))
+ main;
+
+ (* let ground_val = List.map (fun e -> Z3.Expr.to_string e) (Z3.Expr.get_args
+ conj) in *)
+
+ (* We recover the Zustre XML format, projecting each cex on each input/output
+ signal *)
let in_signals, _ =
- List.fold_right (
- fun (id, (sigs_in, sigs_out)) (res_sigs_in, res_sigs_out) ->
- let add l1 l2 = List.map2 (fun e1 e2 -> fst e2, ((id, e1)::(snd e2))) l1 l2 in
- let sigs_in_id = add sigs_in res_sigs_in in
- let sigs_out_id = add sigs_out res_sigs_out in
- sigs_in_id, sigs_out_id
- ) main (List.map (fun v -> v, []) inputs, List.map (fun v -> v, []) outputs)
+ List.fold_right
+ (fun (id, (sigs_in, sigs_out)) (res_sigs_in, res_sigs_out) ->
+ let add l1 l2 =
+ List.map2 (fun e1 e2 -> fst e2, (id, e1) :: snd e2) l1 l2
+ in
+ let sigs_in_id = add sigs_in res_sigs_in in
+ let sigs_out_id = add sigs_out res_sigs_out in
+ sigs_in_id, sigs_out_id)
+ main
+ (List.map (fun v -> v, []) inputs, List.map (fun v -> v, []) outputs)
in
(* let _ = List.mapi (fun k conj -> *)
(* (\* k-iterate *\) *)
- (* let ground_val = List.map (fun e -> Z3.Expr.to_string e) (Z3.Expr.get_args conj) in *)
- (* let func_decl = Z3.Expr.get_func_decl conj in *)
- (* if !debug then Format.eprintf "FuncDecl %s@." (Z3.FuncDecl.to_string func_decl); *)
- (* let node_name = Z3.Symbol.get_string (Z3.FuncDecl.get_name func_decl) in *)
-
-
- (* if !debug then Format.eprintf "Node %s, args %a@." node_name (Utils.fprintf_list ~sep:", " (Format.pp_print_string)) ground_val; *)
-
+ (* let ground_val = List.map (fun e -> Z3.Expr.to_string e) (Z3.Expr.get_args
+ conj) in *)
+ (* let func_decl = Z3.Expr.get_func_decl conj in *)
+ (* if !debug then Format.eprintf "FuncDecl %s@." (Z3.FuncDecl.to_string
+ func_decl); *)
+ (* let node_name = Z3.Symbol.get_string (Z3.FuncDecl.get_name func_decl) in *)
+
+ (* if !debug then Format.eprintf "Node %s, args %a@." node_name
+ (Utils.fprintf_list ~sep:", " (Format.pp_print_string)) ground_val; *)
+
(* () *)
(* (\* ground_pair = [] *)
(* try: *)
(* ground_vars = pred_dict[node_name] *)
(* ground_pair = zip(ground_vars,ground_val) *)
(* if "_reset" in node_name: *)
- (* # this condition is to remove the node nodename_reset added by lustrec *)
+ (* # this condition is to remove the node nodename_reset added by lustrec *)
(* continue *)
(* # node = node_name.split("_reset")[0] *)
(* # cex_dict.update({node:{k:ground_pair}}) *)
@@ -125,7 +139,8 @@ let build_cex machine machines _decl_err =
(* try: *)
(* # case in which we already have the node in dict *)
(* d = cex_dict[node] *)
- (* max_key = max(k for k, v in d.iteritems() if v != 0) #get the maximum key value and add 1 *)
+ (* max_key = max(k for k, v in d.iteritems() if v != 0) #get the maximum key
+ value and add 1 *)
(* d.update({(max_key+1):ground_pair}) *)
(* except Exception as e: *)
(* self._log.warning("Adding a new node cex " + str(e)) *)
@@ -134,14 +149,15 @@ let build_cex machine machines _decl_err =
(* node = node_name *)
(* try: *)
(* d = cex_dict[node] *)
- (* max_key = max(k for k, v in d.iteritems() if v != 0) #get the maximum key value and add 1 *)
+ (* max_key = max(k for k, v in d.iteritems() if v != 0) #get the maximum key
+ value and add 1 *)
(* d.update({(max_key+1):ground_pair}) *)
(* except Exception as e: *)
(* if node not in ["MAIN", "ERR"]: *)
- (* self._log.warning("Adding a new node cex " + str(e)) *)
+ (* self._log.warning("Adding a new node cex " + str(e)) *)
(* cex_dict.update({node:{k:ground_pair}}) *)
(* except Exception as e: *)
- (* self._log.warning("Problem with getting a node name: " + str(e)) *)
+ (* self._log.warning("Problem with getting a node name: " + str(e)) *)
(* *\) *)
(* ) conjuncts in *)
(* let rules_expr = Z3.Fixedpoint.get_rules !fp in *)
@@ -156,62 +172,84 @@ let build_cex machine machines _decl_err =
(* let _ (*stats_entries*) = Z3.Statistics.get_entries stats in *)
(* List.iter (fun e -> Format.eprintf "%s@.@?" *)
(* (Z3.Statistics.Entry.to_string e) *)
-
+
(* ) stats_entries; *)
let json : Yojson.t =
- `Assoc [
- "Results",
- `Assoc [
- "Property",
- `Assoc [
- "name", `String node_id;
- "date", `String (Utils.get_date ());
- "query", `Assoc ["unit", `String "sec";
- "value", `Float (
- let time_opt = Z3.Statistics.get stats "time.spacer.solve" in
- match time_opt with None -> -1.
- | Some f -> Z3.Statistics.Entry.get_float f)
- ];
- "answer", `String "CEX";
- "counterexample",
- `Assoc [
- node_id, `Assoc
- (
- List.map (fun (vardecl, values) ->
- vardecl.var_id,
- `Assoc [
- "type", (let _ = Format.fprintf Format.str_formatter "%a" Printers.pp_var_type vardecl in
- let s = Format.flush_str_formatter () in
- `String s);
- "values", `Assoc (List.map (fun (id, v) ->
- string_of_int id, `String (Z3.Expr.to_string v))
- values)
- ]
- ) in_signals
- )
- ]
- ]
+ `Assoc
+ [
+ ( "Results",
+ `Assoc
+ [
+ ( "Property",
+ `Assoc
+ [
+ "name", `String node_id;
+ "date", `String (Utils.get_date ());
+ ( "query",
+ `Assoc
+ [
+ "unit", `String "sec";
+ ( "value",
+ `Float
+ (let time_opt =
+ Z3.Statistics.get stats "time.spacer.solve"
+ in
+ match time_opt with
+ | None ->
+ -1.
+ | Some f ->
+ Z3.Statistics.Entry.get_float f) );
+ ] );
+ "answer", `String "CEX";
+ ( "counterexample",
+ `Assoc
+ [
+ ( node_id,
+ `Assoc
+ (List.map
+ (fun (vardecl, values) ->
+ ( vardecl.var_id,
+ `Assoc
+ [
+ ( "type",
+ let _ =
+ Format.fprintf Format.str_formatter
+ "%a" Printers.pp_var_type vardecl
+ in
+ let s =
+ Format.flush_str_formatter ()
+ in
+ `String s );
+ ( "values",
+ `Assoc
+ (List.map
+ (fun (id, v) ->
+ ( string_of_int id,
+ `String
+ (Z3.Expr.to_string v) ))
+ values) );
+ ] ))
+ in_signals) );
+ ] );
+ ] );
+ ] );
]
- ]
in
- Format.eprintf "JSON: %s@."
- (Yojson.to_string json);
+ Format.eprintf "JSON: %s@." (Yojson.to_string json);
()
- (* Results *)
- (* Property *)
- (* Date *)
- (* Query time *)
- (* Answer CEX *)
- (* Counterexample *)
- (* Node name="nodeid" *)
- (* Stream name="opt.x" type="unk" *)
- (* Value instant="0">xxx</Value> *)
- (* () *)
- (* ordered_by_signal = self.reorder(cex_dict) *)
- (* return self.mk_cex_xml(ordered_by_signal) *)
+(* Results *)
+(* Property *)
+(* Date *)
+(* Query time *)
+(* Answer CEX *)
+(* Counterexample *)
+(* Node name="nodeid" *)
+(* Stream name="opt.x" type="unk" *)
+(* Value instant="0">xxx</Value> *)
+(* () *)
+(* ordered_by_signal = self.reorder(cex_dict) *)
+(* return self.mk_cex_xml(ordered_by_signal) *)
(* Local Variables: *)
(* compile-command:"make -C ../.. lustrev" *)
(* End: *)
-
-
diff --git a/src/tools/zustre/zustre_common.ml b/src/tools/zustre/zustre_common.ml
index 959c5b91a18fcec31a6908be82f5397284f213a2..e8f78011b5457c9f45a38e70a7121f3283849ea0 100644
--- a/src/tools/zustre/zustre_common.ml
+++ b/src/tools/zustre/zustre_common.ml
@@ -1,101 +1,125 @@
open Lustre_types
open Machine_code_types
open Machine_code_common
+
(* open Horn_backend_common
* open Horn_backend *)
open Zustre_data
-
+
let report = Log.report ~plugin:"z3 interface"
-
+
module HBC = Horn_backend_common
+
let node_name = HBC.node_name
let concat = HBC.concat
let rename_machine = HBC.rename_machine
+
let rename_machine_list = HBC.rename_machine_list
let rename_next = HBC.rename_next
+
let rename_mid = HBC.rename_mid
+
let rename_current = HBC.rename_current
let rename_current_list = HBC.rename_current_list
+
let rename_mid_list = HBC.rename_mid_list
+
let rename_next_list = HBC.rename_next_list
let full_memory_vars = HBC.full_memory_vars
+
let inout_vars = HBC.inout_vars
+
let reset_vars = HBC.reset_vars
+
let step_vars = HBC.step_vars
+
let local_memory_vars = HBC.local_memory_vars
+
let step_vars_m_x = HBC.step_vars_m_x
+
let step_vars_c_m_x = HBC.step_vars_c_m_x
-
-let machine_reset_name = HBC.machine_reset_name
-let machine_step_name = HBC.machine_step_name
-let machine_stateless_name = HBC.machine_stateless_name
+
+let machine_reset_name = HBC.machine_reset_name
+
+let machine_step_name = HBC.machine_step_name
+
+let machine_stateless_name = HBC.machine_stateless_name
let preprocess = Horn_backend.preprocess
-
exception UnknownFunction of (string * (Format.formatter -> unit))
(** Sorts
-A sort is introduced for each basic type and each enumerated type.
+ A sort is introduced for each basic type and each enumerated type.
-A hashtbl records these and allow easy access to sort values, when
- provided with a enumerated type name.
+ A hashtbl records these and allow easy access to sort values, when provided
+ with a enumerated type name. *)
-*)
-
let bool_sort = Z3.Boolean.mk_sort !ctx
+
let int_sort = Z3.Arithmetic.Integer.mk_sort !ctx
+
let real_sort = Z3.Arithmetic.Real.mk_sort !ctx
+let get_const_sort = Hashtbl.find const_sorts
-let get_const_sort = Hashtbl.find const_sorts
let get_sort_elems = Hashtbl.find sort_elems
-let get_tag_sort id = try Hashtbl.find const_tags id with _ -> Format.eprintf "Unable to find sort for tag=%s@." id; assert false
-
-
+let get_tag_sort id =
+ try Hashtbl.find const_tags id
+ with _ ->
+ Format.eprintf "Unable to find sort for tag=%s@." id;
+ assert false
+
let decl_sorts () =
- Hashtbl.iter (fun typ decl ->
- match typ with
- | Tydec_const var ->
- (match decl.top_decl_desc with
- | TypeDef tdef -> (
- match tdef.tydef_desc with
- | Tydec_enum tl ->
- let new_sort = Z3.Enumeration.mk_sort_s !ctx var tl in
- Hashtbl.add const_sorts var new_sort;
- Hashtbl.add sort_elems new_sort tl;
- List.iter (fun t -> Hashtbl.add const_tags t new_sort) tl
-
- | _ -> Format.eprintf "Unknown type : %a@.@?" Printers.pp_var_type_dec_desc typ; assert false
- )
- | _ -> assert false
- )
- | _ -> ()) Corelang.type_table
-
-
-let rec type_to_sort t =
- if Types.is_bool_type t then bool_sort else
- if Types.is_int_type t then int_sort else
- if Types.is_real_type t then real_sort else
- match (Types.repr t).Types.tdesc with
- | Types.Tconst ty -> get_const_sort ty
- | Types.Tclock t -> type_to_sort t
- | Types.Tarray(_, ty) -> Z3.Z3Array.mk_sort !ctx int_sort (type_to_sort ty)
- | Types.Tstatic(_, ty) -> type_to_sort ty
- | Types.Tarrow _
- | _ -> Format.eprintf "internal error: pp_type %a@."
- Types.print_ty t; assert false
+ Hashtbl.iter
+ (fun typ decl ->
+ match typ with
+ | Tydec_const var -> (
+ match decl.top_decl_desc with
+ | TypeDef tdef -> (
+ match tdef.tydef_desc with
+ | Tydec_enum tl ->
+ let new_sort = Z3.Enumeration.mk_sort_s !ctx var tl in
+ Hashtbl.add const_sorts var new_sort;
+ Hashtbl.add sort_elems new_sort tl;
+ List.iter (fun t -> Hashtbl.add const_tags t new_sort) tl
+ | _ ->
+ Format.eprintf "Unknown type : %a@.@?" Printers.pp_var_type_dec_desc
+ typ;
+ assert false)
+ | _ ->
+ assert false)
+ | _ ->
+ ())
+ Corelang.type_table
+let rec type_to_sort t =
+ if Types.is_bool_type t then bool_sort
+ else if Types.is_int_type t then int_sort
+ else if Types.is_real_type t then real_sort
+ else
+ match (Types.repr t).Types.tdesc with
+ | Types.Tconst ty ->
+ get_const_sort ty
+ | Types.Tclock t ->
+ type_to_sort t
+ | Types.Tarray (_, ty) ->
+ Z3.Z3Array.mk_sort !ctx int_sort (type_to_sort ty)
+ | Types.Tstatic (_, ty) ->
+ type_to_sort ty
+ | Types.Tarrow _ | _ ->
+ Format.eprintf "internal error: pp_type %a@." Types.print_ty t;
+ assert false
(* let idx_var = *)
(* Z3.FuncDecl.mk_func_decl_s !ctx "__idx__" [] idx_sort *)
-
+
(* let uid_var = *)
(* Z3.FuncDecl.mk_func_decl_s !ctx "__uid__" [] uid_sort *)
@@ -103,29 +127,30 @@ let rec type_to_sort t =
Similarly fun_decls are registerd, by their name, into a hashtbl. The
proposed encoding introduces a 0-ary fun_decl to model variables and
- fun_decl with arguments to declare reset and step predicates.
-
-
-
-*)
+ fun_decl with arguments to declare reset and step predicates. *)
let register_fdecl id fd = Hashtbl.add decls id fd
+
let get_fdecl id =
- try
- Hashtbl.find decls id
- with Not_found -> (report ~level:3 (fun fmt -> Format.fprintf fmt "Unable to find func_decl %s@.@?" id); raise Not_found)
+ try Hashtbl.find decls id
+ with Not_found ->
+ report ~level:3 (fun fmt ->
+ Format.fprintf fmt "Unable to find func_decl %s@.@?" id);
+ raise Not_found
let pp_fdecls fmt =
Format.fprintf fmt "Registered fdecls: @[%a@]@ "
- (Utils.fprintf_list ~sep:"@ " Format.pp_print_string) (Hashtbl.fold (fun id _ accu -> id::accu) decls [])
+ (Utils.fprintf_list ~sep:"@ " Format.pp_print_string)
+ (Hashtbl.fold (fun id _ accu -> id :: accu) decls [])
-
let decl_var id =
(* Format.eprintf "Declaring var %s@." id.var_id; *)
- let fdecl = Z3.FuncDecl.mk_func_decl_s !ctx id.var_id [] (type_to_sort id.var_type) in
+ let fdecl =
+ Z3.FuncDecl.mk_func_decl_s !ctx id.var_id [] (type_to_sort id.var_type)
+ in
register_fdecl id.var_id fdecl;
fdecl
-(* Declaring the function used in expr *)
+(* Declaring the function used in expr *)
let decl_fun op args typ =
let args = List.map type_to_sort args in
let fdecl = Z3.FuncDecl.mk_func_decl_s !ctx op args (type_to_sort typ) in
@@ -133,216 +158,185 @@ let decl_fun op args typ =
fdecl
let idx_sort = int_sort
-let uid_sort = Z3.Z3List.mk_sort !ctx (Z3.Symbol.mk_string !ctx "uid_list") int_sort
-let uid_conc =
+
+let uid_sort =
+ Z3.Z3List.mk_sort !ctx (Z3.Symbol.mk_string !ctx "uid_list") int_sort
+
+let uid_conc =
let fd = Z3.Z3List.get_cons_decl uid_sort in
- fun head tail -> Z3.FuncDecl.apply fd [head;tail]
+ fun head tail -> Z3.FuncDecl.apply fd [ head; tail ]
let get_instance_uid =
let hash : (string, int) Hashtbl.t = Hashtbl.create 13 in
let cpt = ref 0 in
fun i ->
let id =
- if Hashtbl.mem hash i then
- Hashtbl.find hash i
+ if Hashtbl.mem hash i then Hashtbl.find hash i
else (
- incr cpt;
- Hashtbl.add hash i !cpt;
- !cpt
- )
+ incr cpt;
+ Hashtbl.add hash i !cpt;
+ !cpt)
in
Z3.Arithmetic.Integer.mk_numeral_i !ctx id
-
-
-let decl_rel ?(no_additional_vars=false) name args_sorts =
- (* Enriching arg_sorts with two new variables: a counting index and an
- uid *)
+let decl_rel ?(no_additional_vars = false) name args_sorts =
+ (* Enriching arg_sorts with two new variables: a counting index and an uid *)
let args_sorts =
- if no_additional_vars then args_sorts else idx_sort::uid_sort::args_sorts in
-
+ if no_additional_vars then args_sorts
+ else idx_sort :: uid_sort :: args_sorts
+ in
+
(* let args_sorts = List.map (fun v -> type_to_sort v.var_type) args in *)
if !debug then
- Format.eprintf "Registering fdecl %s (%a)@."
- name
- (Utils.fprintf_list ~sep:"@ "
- (fun fmt sort -> Format.fprintf fmt "%s" (Z3.Sort.to_string sort)))
- args_sorts
- ;
+ Format.eprintf "Registering fdecl %s (%a)@." name
+ (Utils.fprintf_list ~sep:"@ " (fun fmt sort ->
+ Format.fprintf fmt "%s" (Z3.Sort.to_string sort)))
+ args_sorts;
let fdecl = Z3.FuncDecl.mk_func_decl_s !ctx name args_sorts bool_sort in
Z3.Fixedpoint.register_relation !fp fdecl;
register_fdecl name fdecl;
fdecl
-
-
(* Shared variables to describe counter and uid *)
let idx = Corelang.dummy_var_decl "__idx__" Type_predef.type_int
-let idx_var = Z3.Expr.mk_const_f !ctx (decl_var idx)
-let uid = Corelang.dummy_var_decl "__uid__" Type_predef.type_int
-let uid_fd = Z3.FuncDecl.mk_func_decl_s !ctx "__uid__" [] uid_sort
-let _ = register_fdecl "__uid__" uid_fd
-let uid_var = Z3.Expr.mk_const_f !ctx uid_fd
-(** Conversion functions
+let idx_var = Z3.Expr.mk_const_f !ctx (decl_var idx)
- The following is similar to the Horn backend. Each printing function is
- rephrased from pp_xx to xx_to_expr and produces a Z3 value.
+let uid = Corelang.dummy_var_decl "__uid__" Type_predef.type_int
-*)
+let uid_fd = Z3.FuncDecl.mk_func_decl_s !ctx "__uid__" [] uid_sort
+let _ = register_fdecl "__uid__" uid_fd
-(* Returns the f_decl associated to the variable v *)
-let horn_var_to_expr v =
- Z3.Expr.mk_const_f !ctx (get_fdecl v.var_id)
+let uid_var = Z3.Expr.mk_const_f !ctx uid_fd
+(** Conversion functions
+ The following is similar to the Horn backend. Each printing function is
+ rephrased from pp_xx to xx_to_expr and produces a Z3 value. *)
+(* Returns the f_decl associated to the variable v *)
+let horn_var_to_expr v = Z3.Expr.mk_const_f !ctx (get_fdecl v.var_id)
- (* Used to print boolean constants *)
+(* Used to print boolean constants *)
let horn_tag_to_expr t =
- if t = tag_true then
- Z3.Boolean.mk_true !ctx
- else if t = tag_false then
- Z3.Boolean.mk_false !ctx
+ if t = tag_true then Z3.Boolean.mk_true !ctx
+ else if t = tag_false then Z3.Boolean.mk_false !ctx
else
(* Finding the associated sort *)
let sort = get_tag_sort t in
- let elems = get_sort_elems sort in
+ let elems = get_sort_elems sort in
let res : Z3.Expr.expr option =
- List.fold_left2 (fun res cst expr ->
+ List.fold_left2
+ (fun res cst expr ->
match res with
- | Some _ -> res
- | None -> if t = cst then Some (expr:Z3.Expr.expr) else None
- ) None elems (Z3.Enumeration.get_consts sort)
+ | Some _ ->
+ res
+ | None ->
+ if t = cst then Some (expr : Z3.Expr.expr) else None)
+ None elems
+ (Z3.Enumeration.get_consts sort)
in
match res with None -> assert false | Some s -> s
-
+
(* Prints a constant value *)
let horn_const_to_expr c =
match c with
- | Const_int i -> Z3.Arithmetic.Integer.mk_numeral_i !ctx i
- | Const_real r -> Z3.Arithmetic.Real.mk_numeral_s !ctx (Real.to_string r)
- | Const_tag t -> horn_tag_to_expr t
- | _ -> assert false
-
-
+ | Const_int i ->
+ Z3.Arithmetic.Integer.mk_numeral_i !ctx i
+ | Const_real r ->
+ Z3.Arithmetic.Real.mk_numeral_s !ctx (Real.to_string r)
+ | Const_tag t ->
+ horn_tag_to_expr t
+ | _ ->
+ assert false
(* Default value for each type, used when building arrays. Eg integer array
[2;7] is defined as (store (store (0) 1 7) 0 2) where 0 is this default value
- for the type integer (arrays).
-*)
+ for the type integer (arrays). *)
let horn_default_val t =
let t = Types.dynamic_type t in
- if Types.is_bool_type t then Z3.Boolean.mk_true !ctx else
- if Types.is_int_type t then Z3.Arithmetic.Integer.mk_numeral_i !ctx 0 else
- if Types.is_real_type t then Z3.Arithmetic.Real.mk_numeral_i !ctx 0 else
- (* match (Types.dynamic_type t).Types.tdesc with
- * | Types.Tarray(dim, l) -> (\* TODO PL: this strange code has to be (heavily) checked *\)
- * let valt = Types.array_element_type t in
- * fprintf fmt "((as const (Array Int %a)) %a)"
- * pp_type valt
- * pp_default_val valt
- * | Types.Tstruct(l) -> assert false
- * | Types.Ttuple(l) -> assert false
- * |_ -> *) assert false
+ if Types.is_bool_type t then Z3.Boolean.mk_true !ctx
+ else if Types.is_int_type t then Z3.Arithmetic.Integer.mk_numeral_i !ctx 0
+ else if Types.is_real_type t then Z3.Arithmetic.Real.mk_numeral_i !ctx 0
+ else
+ (* match (Types.dynamic_type t).Types.tdesc with
+ * | Types.Tarray(dim, l) -> (\* TODO PL: this strange code has to be (heavily) checked *\)
+ * let valt = Types.array_element_type t in
+ * fprintf fmt "((as const (Array Int %a)) %a)"
+ * pp_type valt
+ * pp_default_val valt
+ * | Types.Tstruct(l) -> assert false
+ * | Types.Ttuple(l) -> assert false
+ * |_ -> *)
+ assert false
(* Conversion of basic library functions *)
-
+
let horn_basic_app i vl (vltyp, typ) =
match i, vl with
- | "ite", [v1; v2; v3] -> Z3.Boolean.mk_ite !ctx v1 v2 v3
- | "uminus", [v] -> Z3.Arithmetic.mk_unary_minus
- !ctx v
- | "not", [v] ->
- Z3.Boolean.mk_not
- !ctx v
- | "=", [v1; v2] ->
- Z3.Boolean.mk_eq
- !ctx v1 v2
- | "&&", [v1; v2] ->
- Z3.Boolean.mk_and
- !ctx
- [v1; v2]
- | "||", [v1; v2] ->
- Z3.Boolean.mk_or
- !ctx
- [v1;
- v2]
-
- | "impl", [v1; v2] ->
- Z3.Boolean.mk_implies
- !ctx v1 v2
- | "mod", [v1; v2] ->
- Z3.Arithmetic.Integer.mk_mod
- !ctx v1 v2
- | "equi", [v1; v2] ->
- Z3.Boolean.mk_eq
- !ctx
- v1 v2
- | "xor", [v1; v2] ->
- Z3.Boolean.mk_xor
- !ctx v1 v2
- | "!=", [v1; v2] ->
- Z3.Boolean.mk_not
- !ctx
- (
- Z3.Boolean.mk_eq
- !ctx v1 v2
- )
- | "/", [v1; v2] ->
- Z3.Arithmetic.mk_div
- !ctx v1 v2
-
- | "+", [v1; v2] ->
- Z3.Arithmetic.mk_add
- !ctx
- [v1; v2]
- | "-", [v1; v2] ->
- Z3.Arithmetic.mk_sub
- !ctx
- [v1 ; v2]
-
- | "*", [v1; v2] ->
- Z3.Arithmetic.mk_mul
- !ctx
- [ v1; v2]
-
-
- | "<", [v1; v2] ->
- Z3.Arithmetic.mk_lt
- !ctx v1 v2
- | "<=", [v1; v2] ->
- Z3.Arithmetic.mk_le
- !ctx v1 v2
- | ">", [v1; v2] ->
- Z3.Arithmetic.mk_gt
- !ctx v1 v2
- | ">=", [v1; v2] ->
- Z3.Arithmetic.mk_ge
- !ctx v1 v2
- | "int_to_real", [v1] ->
- Z3.Arithmetic.Integer.mk_int2real
- !ctx v1
+ | "ite", [ v1; v2; v3 ] ->
+ Z3.Boolean.mk_ite !ctx v1 v2 v3
+ | "uminus", [ v ] ->
+ Z3.Arithmetic.mk_unary_minus !ctx v
+ | "not", [ v ] ->
+ Z3.Boolean.mk_not !ctx v
+ | "=", [ v1; v2 ] ->
+ Z3.Boolean.mk_eq !ctx v1 v2
+ | "&&", [ v1; v2 ] ->
+ Z3.Boolean.mk_and !ctx [ v1; v2 ]
+ | "||", [ v1; v2 ] ->
+ Z3.Boolean.mk_or !ctx [ v1; v2 ]
+ | "impl", [ v1; v2 ] ->
+ Z3.Boolean.mk_implies !ctx v1 v2
+ | "mod", [ v1; v2 ] ->
+ Z3.Arithmetic.Integer.mk_mod !ctx v1 v2
+ | "equi", [ v1; v2 ] ->
+ Z3.Boolean.mk_eq !ctx v1 v2
+ | "xor", [ v1; v2 ] ->
+ Z3.Boolean.mk_xor !ctx v1 v2
+ | "!=", [ v1; v2 ] ->
+ Z3.Boolean.mk_not !ctx (Z3.Boolean.mk_eq !ctx v1 v2)
+ | "/", [ v1; v2 ] ->
+ Z3.Arithmetic.mk_div !ctx v1 v2
+ | "+", [ v1; v2 ] ->
+ Z3.Arithmetic.mk_add !ctx [ v1; v2 ]
+ | "-", [ v1; v2 ] ->
+ Z3.Arithmetic.mk_sub !ctx [ v1; v2 ]
+ | "*", [ v1; v2 ] ->
+ Z3.Arithmetic.mk_mul !ctx [ v1; v2 ]
+ | "<", [ v1; v2 ] ->
+ Z3.Arithmetic.mk_lt !ctx v1 v2
+ | "<=", [ v1; v2 ] ->
+ Z3.Arithmetic.mk_le !ctx v1 v2
+ | ">", [ v1; v2 ] ->
+ Z3.Arithmetic.mk_gt !ctx v1 v2
+ | ">=", [ v1; v2 ] ->
+ Z3.Arithmetic.mk_ge !ctx v1 v2
+ | "int_to_real", [ v1 ] ->
+ Z3.Arithmetic.Integer.mk_int2real !ctx v1
| _ ->
- let fd =
- try
- get_fdecl i
- with Not_found -> begin
- report ~level:3 (fun fmt -> Format.fprintf fmt "Registering function %s as uninterpreted function in Z3@.%s: (%a) -> %a" i i (Utils.fprintf_list ~sep:"," Types.print_ty) vltyp Types.print_ty typ);
- decl_fun i vltyp typ
- end
- in
- Z3.FuncDecl.apply fd vl
-
-
- (* | _, [v1; v2] -> Z3.Boolean.mk_and
- * !ctx
- * (val_to_expr v1)
- * (val_to_expr v2)
- *
- * Format.fprintf fmt "(%s %a %a)" i val_to_exprr v1 val_to_expr v2 *)
+ let fd =
+ try get_fdecl i
+ with Not_found ->
+ report ~level:3 (fun fmt ->
+ Format.fprintf fmt
+ "Registering function %s as uninterpreted function in Z3@.%s: \
+ (%a) -> %a"
+ i i
+ (Utils.fprintf_list ~sep:"," Types.print_ty)
+ vltyp Types.print_ty typ);
+ decl_fun i vltyp typ
+ in
+ Z3.FuncDecl.apply fd vl
+
+(* | _, [v1; v2] -> Z3.Boolean.mk_and
+ * !ctx
+ * (val_to_expr v1)
+ * (val_to_expr v2)
+ *
+ * Format.fprintf fmt "(%s %a %a)" i val_to_exprr v1 val_to_expr v2 *)
(* | _ -> (
* let msg fmt = Format.fprintf fmt
@@ -352,116 +346,95 @@ let horn_basic_app i vl (vltyp, typ) =
* raise (UnknownFunction(i, msg))
* ) *)
-
-(* Convert a value expression [v], with internal function calls only. [pp_var]
+(* Convert a value expression [v], with internal function calls only. [pp_var]
is a printer for variables (typically [pp_c_var_read]), but an offset suffix
- may be added for array variables
-*)
-let rec horn_val_to_expr ?(is_lhs=false) m self v =
+ may be added for array variables *)
+let rec horn_val_to_expr ?(is_lhs = false) m self v =
(* Format.eprintf "h_v2e %a@." (Machine_code_common.pp_val m) v ; *)
match v.value_desc with
- | Cst c -> horn_const_to_expr c
-
+ | Cst c ->
+ horn_const_to_expr c
(* Code specific for arrays *)
- | Array il ->
- (* An array definition:
- (store (
- ...
- (store (
- store (
- default_val
- )
- idx_n val_n
- )
- idx_n-1 val_n-1)
- ...
- idx_1 val_1
- ) *)
- let rec build_array (tab, x) =
- match tab with
- | [] -> horn_default_val v.value_type(* (get_type v) *)
- | h::t ->
- Z3.Z3Array.mk_store
- !ctx
- (build_array (t, (x+1)))
- (Z3.Arithmetic.Integer.mk_numeral_i !ctx x)
- (horn_val_to_expr ~is_lhs:is_lhs m self h)
- in
- build_array (il, 0)
-
- | Access(tab,index) ->
- Z3.Z3Array.mk_select !ctx
- (horn_val_to_expr ~is_lhs:is_lhs m self tab)
- (horn_val_to_expr ~is_lhs:is_lhs m self index)
-
+ | Array il ->
+ (* An array definition: (store ( ... (store ( store ( default_val ) idx_n
+ val_n ) idx_n-1 val_n-1) ... idx_1 val_1 ) *)
+ let rec build_array (tab, x) =
+ match tab with
+ | [] ->
+ horn_default_val v.value_type (* (get_type v) *)
+ | h :: t ->
+ Z3.Z3Array.mk_store !ctx
+ (build_array (t, x + 1))
+ (Z3.Arithmetic.Integer.mk_numeral_i !ctx x)
+ (horn_val_to_expr ~is_lhs m self h)
+ in
+ build_array (il, 0)
+ | Access (tab, index) ->
+ Z3.Z3Array.mk_select !ctx
+ (horn_val_to_expr ~is_lhs m self tab)
+ (horn_val_to_expr ~is_lhs m self index)
(* Code specific for arrays *)
-
- | Power _ -> assert false
- | Var v ->
- if is_memory m v then
- if Types.is_array_type v.var_type
- then assert false
- else horn_var_to_expr (rename_machine self ((if is_lhs then rename_next else rename_current) (* self *) v))
-
- else
- horn_var_to_expr
- (rename_machine
- self
- v)
- | Fun (n, vl) -> horn_basic_app n (List.map (horn_val_to_expr m self) vl) (List.map (fun v -> v.value_type) vl, v.value_type)
+ | Power _ ->
+ assert false
+ | Var v ->
+ if is_memory m v then
+ if Types.is_array_type v.var_type then assert false
+ else
+ horn_var_to_expr
+ (rename_machine self
+ ((if is_lhs then rename_next else rename_current (* self *)) v))
+ else horn_var_to_expr (rename_machine self v)
+ | Fun (n, vl) ->
+ horn_basic_app n
+ (List.map (horn_val_to_expr m self) vl)
+ (List.map (fun v -> v.value_type) vl, v.value_type)
let no_reset_to_exprs machines m i =
- let (n,_) = List.assoc i m.minstances in
- let target_machine = List.find (fun m -> m.mname.node_id = (Corelang.node_name n)) machines in
+ let n, _ = List.assoc i m.minstances in
+ let target_machine =
+ List.find (fun m -> m.mname.node_id = Corelang.node_name n) machines
+ in
- let m_list =
- rename_machine_list
- (concat m.mname.node_id i)
+ let m_list =
+ rename_machine_list (concat m.mname.node_id i)
(rename_mid_list (full_memory_vars machines target_machine))
in
let c_list =
- rename_machine_list
- (concat m.mname.node_id i)
+ rename_machine_list (concat m.mname.node_id i)
(rename_current_list (full_memory_vars machines target_machine))
in
match c_list, m_list with
- | [chd], [mhd] ->
- let expr =
- Z3.Boolean.mk_eq !ctx
- (horn_var_to_expr mhd)
- (horn_var_to_expr chd)
- in
- [expr]
- | _ -> (
+ | [ chd ], [ mhd ] ->
+ let expr =
+ Z3.Boolean.mk_eq !ctx (horn_var_to_expr mhd) (horn_var_to_expr chd)
+ in
+ [ expr ]
+ | _ ->
let exprs =
- List.map2 (fun mhd chd ->
- Z3.Boolean.mk_eq !ctx
- (horn_var_to_expr mhd)
- (horn_var_to_expr chd)
- )
- m_list
- c_list
+ List.map2
+ (fun mhd chd ->
+ Z3.Boolean.mk_eq !ctx (horn_var_to_expr mhd) (horn_var_to_expr chd))
+ m_list c_list
in
exprs
- )
let instance_reset_to_exprs machines m i =
- let (n,_) = List.assoc i m.minstances in
- let target_machine = List.find (fun m -> m.mname.node_id = (Corelang.node_name n)) machines in
+ let n, _ = List.assoc i m.minstances in
+ let target_machine =
+ List.find (fun m -> m.mname.node_id = Corelang.node_name n) machines
+ in
let vars =
- (rename_machine_list
- (concat m.mname.node_id i)
- (rename_current_list (full_memory_vars machines target_machine))@ (rename_mid_list (full_memory_vars machines target_machine))
- )
-
+ rename_machine_list (concat m.mname.node_id i)
+ (rename_current_list (full_memory_vars machines target_machine))
+ @ rename_mid_list (full_memory_vars machines target_machine)
in
+
let expr =
- Z3.Expr.mk_app
- !ctx
+ Z3.Expr.mk_app !ctx
(get_fdecl (machine_reset_name (Corelang.node_name n)))
- (List.map (horn_var_to_expr) (idx::uid::vars))
+ (List.map horn_var_to_expr (idx :: uid :: vars))
in
- [expr]
+ [ expr ]
let instance_call_to_exprs machines reset_instances m i inputs outputs =
let self = m.mname.node_id in
@@ -471,509 +444,434 @@ let instance_call_to_exprs machines reset_instances m i inputs outputs =
(* Additional input to register step counters, and uid *)
let idx = horn_var_to_expr idx in
let uid = uid_conc (get_instance_uid i) (horn_var_to_expr uid) in
- let inout =
+ let inout =
List.map (horn_val_to_expr m self)
- (inputs @ (List.map (fun v -> mk_val (Var v) v.var_type) outputs))
+ (inputs @ List.map (fun v -> mk_val (Var v) v.var_type) outputs)
in
- idx::uid::inout
+ idx :: uid :: inout
in
-
- try (* stateful node instance *)
- begin
- let (n,_) = List.assoc i m.minstances in
- let target_machine = List.find (fun m -> m.mname.node_id = Corelang.node_name n) machines in
-
- (* Checking whether this specific instances has been reset yet *)
- let reset_exprs =
- if not (List.mem i reset_instances) then
- (* If not, declare mem_m = mem_c *)
- no_reset_to_exprs machines m i
- else
- [] (* Nothing to add yet *)
- in
-
- let mems = full_memory_vars machines target_machine in
- let rename_mems f = rename_machine_list (concat m.mname.node_id i) (f mems) in
- let mid_mems = rename_mems rename_mid_list in
- let next_mems = rename_mems rename_next_list in
-
- let call_expr =
- match Corelang.node_name n, inputs, outputs, mid_mems, next_mems with
- | "_arrow", [i1; i2], [o], [mem_m], [mem_x] -> begin
- let stmt1 = (* out = ite mem_m then i1 else i2 *)
- Z3.Boolean.mk_eq !ctx
- ( (* output var *)
- horn_val_to_expr
- ~is_lhs:true
- m self
- (mk_val (Var o) o.var_type)
- )
- (
- Z3.Boolean.mk_ite !ctx
- (horn_var_to_expr mem_m)
- (horn_val_to_expr m self i1)
- (horn_val_to_expr m self i2)
- )
- in
- let stmt2 = (* mem_X = false *)
- Z3.Boolean.mk_eq !ctx
- (horn_var_to_expr mem_x)
- (Z3.Boolean.mk_false !ctx)
- in
- [stmt1; stmt2]
- end
-
- | _ ->
- let expr =
- Z3.Expr.mk_app
- !ctx
- (get_fdecl (machine_step_name (node_name n)))
- ( (* Arguments are input, output, mid_mems, next_mems *)
- idx_uid_inout @ List.map (horn_var_to_expr) (mid_mems@next_mems)
-
- )
- in
- [expr]
- in
- reset_exprs@call_expr
- end
- with Not_found -> ( (* stateless node instance *)
- let (n,_) = List.assoc i m.mcalls in
- let expr =
- Z3.Expr.mk_app
- !ctx
- (get_fdecl (machine_stateless_name (node_name n)))
- idx_uid_inout (* Arguments are inputs, outputs *)
+ try
+ (* stateful node instance *)
+ let n, _ = List.assoc i m.minstances in
+ let target_machine =
+ List.find (fun m -> m.mname.node_id = Corelang.node_name n) machines
in
- [expr]
- )
+ (* Checking whether this specific instances has been reset yet *)
+ let reset_exprs =
+ if not (List.mem i reset_instances) then
+ (* If not, declare mem_m = mem_c *)
+ no_reset_to_exprs machines m i
+ else []
+ (* Nothing to add yet *)
+ in
+
+ let mems = full_memory_vars machines target_machine in
+ let rename_mems f =
+ rename_machine_list (concat m.mname.node_id i) (f mems)
+ in
+ let mid_mems = rename_mems rename_mid_list in
+ let next_mems = rename_mems rename_next_list in
+
+ let call_expr =
+ match Corelang.node_name n, inputs, outputs, mid_mems, next_mems with
+ | "_arrow", [ i1; i2 ], [ o ], [ mem_m ], [ mem_x ] ->
+ let stmt1 =
+ (* out = ite mem_m then i1 else i2 *)
+ Z3.Boolean.mk_eq !ctx
+ ((* output var *)
+ horn_val_to_expr ~is_lhs:true m self
+ (mk_val (Var o) o.var_type))
+ (Z3.Boolean.mk_ite !ctx (horn_var_to_expr mem_m)
+ (horn_val_to_expr m self i1)
+ (horn_val_to_expr m self i2))
+ in
+ let stmt2 =
+ (* mem_X = false *)
+ Z3.Boolean.mk_eq !ctx (horn_var_to_expr mem_x)
+ (Z3.Boolean.mk_false !ctx)
+ in
+ [ stmt1; stmt2 ]
+ | _ ->
+ let expr =
+ Z3.Expr.mk_app !ctx
+ (get_fdecl (machine_step_name (node_name n)))
+ ((* Arguments are input, output, mid_mems, next_mems *)
+ idx_uid_inout
+ @ List.map horn_var_to_expr (mid_mems @ next_mems))
+ in
+ [ expr ]
+ in
+
+ reset_exprs @ call_expr
+ with Not_found ->
+ (* stateless node instance *)
+ let n, _ = List.assoc i m.mcalls in
+ let expr =
+ Z3.Expr.mk_app !ctx
+ (get_fdecl (machine_stateless_name (node_name n)))
+ idx_uid_inout
+ (* Arguments are inputs, outputs *)
+ in
+ [ expr ]
-
(* (\* Prints a [value] indexed by the suffix list [loop_vars] *\) *)
(* let rec value_suffix_to_expr self value = *)
(* match value.value_desc with *)
(* | Fun (n, vl) -> *)
(* horn_basic_app n (horn_val_to_expr self) (value_suffix_to_expr self vl) *)
-
+
(* | _ -> *)
(* horn_val_to_expr self value *)
-
-(* type_directed assignment: array vs. statically sized type
- - [var_type]: type of variable to be assigned
- - [var_name]: name of variable to be assigned
- - [value]: assigned value
- - [pp_var]: printer for variables
-*)
+(* type_directed assignment: array vs. statically sized type - [var_type]: type
+ of variable to be assigned - [var_name]: name of variable to be assigned -
+ [value]: assigned value - [pp_var]: printer for variables *)
let assign_to_exprs m var_name value =
let self = m.mname.node_id in
let e =
- Z3.Boolean.mk_eq
- !ctx
+ Z3.Boolean.mk_eq !ctx
(horn_val_to_expr ~is_lhs:true m self var_name)
(horn_val_to_expr m self value)
- (* was: TODO deal with array accesses (value_suffix_to_expr self value) *)
+ (* was: TODO deal with array accesses (value_suffix_to_expr self value) *)
in
- [e]
+ [ e ]
-
(* Convert instruction to Z3.Expr and update the set of reset instances *)
-let rec instr_to_exprs machines reset_instances (m: machine_t) instr : Z3.Expr.expr list * ident list =
+let rec instr_to_exprs machines reset_instances (m : machine_t) instr :
+ Z3.Expr.expr list * ident list =
match Corelang.get_instr_desc instr with
- | MComment _ -> [], reset_instances
- | MNoReset i -> (* we assign middle_mem with mem_m. And declare i as reset *)
- no_reset_to_exprs machines m i,
- i::reset_instances
- | MReset i -> (* we assign middle_mem with reset: reset(mem_m) *)
- instance_reset_to_exprs machines m i,
- i::reset_instances
- | MLocalAssign (i,v) ->
- assign_to_exprs
- m
- (mk_val (Var i) i.var_type) v,
- reset_instances
- | MStateAssign (i,v) ->
- assign_to_exprs
- m
- (mk_val (Var i) i.var_type) v,
- reset_instances
- | MStep ([_], i, vl) when Basic_library.is_internal_fun i (List.map (fun v -> v.value_type) vl) ->
+ | MComment _ ->
+ [], reset_instances
+ | MNoReset i ->
+ (* we assign middle_mem with mem_m. And declare i as reset *)
+ no_reset_to_exprs machines m i, i :: reset_instances
+ | MReset i ->
+ (* we assign middle_mem with reset: reset(mem_m) *)
+ instance_reset_to_exprs machines m i, i :: reset_instances
+ | MLocalAssign (i, v) ->
+ assign_to_exprs m (mk_val (Var i) i.var_type) v, reset_instances
+ | MStateAssign (i, v) ->
+ assign_to_exprs m (mk_val (Var i) i.var_type) v, reset_instances
+ | MStep ([ _ ], i, vl)
+ when Basic_library.is_internal_fun i (List.map (fun v -> v.value_type) vl)
+ ->
assert false (* This should not happen anymore *)
| MStep (il, i, vl) ->
- (* if reset instance, just print the call over mem_m , otherwise declare mem_m =
- mem_c and print the call to mem_m *)
- instance_call_to_exprs machines reset_instances m i vl il,
- reset_instances (* Since this instance call will only happen once, we
- don't have to update reset_instances *)
-
- | MBranch (g,hl) -> (* (g = tag1 => expr1) and (g = tag2 => expr2) ...
- should not be produced yet. Later, we will have to
- compare the reset_instances of each branch and
- introduced the mem_m = mem_c for branches to do not
- address it while other did. Am I clear ? *)
+ (* if reset instance, just print the call over mem_m , otherwise declare
+ mem_m = mem_c and print the call to mem_m *)
+ instance_call_to_exprs machines reset_instances m i vl il, reset_instances
+ (* Since this instance call will only happen once, we don't have to update
+ reset_instances *)
+ | MBranch (g, hl) ->
+ (* (g = tag1 => expr1) and (g = tag2 => expr2) ... should not be produced
+ yet. Later, we will have to compare the reset_instances of each branch
+ and introduced the mem_m = mem_c for branches to do not address it while
+ other did. Am I clear ? *)
(* For each branch we obtain the logical encoding, and the information
whether a sub node has been reset or not. If a node has been reset in one
- of the branch, then all others have to have the mem_m = mem_c
- statement. *)
+ of the branch, then all others have to have the mem_m = mem_c statement. *)
let self = m.mname.node_id in
let branch_to_expr (tag, instrs) =
- let branch_def, branch_resets = instrs_to_expr machines reset_instances m instrs in
+ let branch_def, branch_resets =
+ instrs_to_expr machines reset_instances m instrs
+ in
let e =
- Z3.Boolean.mk_implies !ctx
- (Z3.Boolean.mk_eq !ctx
+ Z3.Boolean.mk_implies !ctx
+ (Z3.Boolean.mk_eq !ctx
(horn_val_to_expr m self g)
- (horn_tag_to_expr tag))
- branch_def in
+ (horn_tag_to_expr tag))
+ branch_def
+ in
- [e], branch_resets
-
+ [ e ], branch_resets
in
- List.fold_left (fun (instrs, resets) b ->
- let b_instrs, b_resets = branch_to_expr b in
- instrs@b_instrs, resets@b_resets
- ) ([], reset_instances) hl
- | MSpec _ -> assert false
-and instrs_to_expr machines reset_instances m instrs =
+ List.fold_left
+ (fun (instrs, resets) b ->
+ let b_instrs, b_resets = branch_to_expr b in
+ instrs @ b_instrs, resets @ b_resets)
+ ([], reset_instances) hl
+ | MSpec _ ->
+ assert false
+
+and instrs_to_expr machines reset_instances m instrs =
let instr_to_exprs rs i = instr_to_exprs machines rs m i in
- let e_list, rs =
+ let e_list, rs =
match instrs with
- | [x] -> instr_to_exprs reset_instances x
- | _::_ -> (* TODO: check whether we should compuyte a AND on the exprs (expr list) built here. It was performed in the printer setting but seems to be useless here since the output is a list of exprs *)
-
- List.fold_left (fun (exprs, rs) i ->
- let exprs_i, rs_i = instr_to_exprs rs i in
- exprs@exprs_i, rs@rs_i
- )
- ([], reset_instances) instrs
-
-
- | [] -> [], reset_instances
+ | [ x ] ->
+ instr_to_exprs reset_instances x
+ | _ :: _ ->
+ (* TODO: check whether we should compuyte a AND on the exprs (expr list)
+ built here. It was performed in the printer setting but seems to be
+ useless here since the output is a list of exprs *)
+ List.fold_left
+ (fun (exprs, rs) i ->
+ let exprs_i, rs_i = instr_to_exprs rs i in
+ exprs @ exprs_i, rs @ rs_i)
+ ([], reset_instances) instrs
+ | [] ->
+ [], reset_instances
in
- let e =
+ let e =
match e_list with
- | [e] -> e
- | [] -> Z3.Boolean.mk_true !ctx
- | _ -> Z3.Boolean.mk_and !ctx e_list
+ | [ e ] ->
+ e
+ | [] ->
+ Z3.Boolean.mk_true !ctx
+ | _ ->
+ Z3.Boolean.mk_and !ctx e_list
in
e, rs
-
(*********************************************************)
(* Quantifiying universally all occuring variables *)
-let add_rule ?(dont_touch=[]) vars expr =
+let add_rule ?(dont_touch = []) vars expr =
(* let fds = Z3.Expr.get_args expr in *)
(* Format.eprintf "Expr %s: args: [%a]@." *)
(* (Z3.Expr.to_string expr) *)
- (* (Utils.fprintf_list ~sep:", " (fun fmt e -> Format.pp_print_string fmt (Z3.Expr.to_string e))) fds; *)
+ (* (Utils.fprintf_list ~sep:", " (fun fmt e -> Format.pp_print_string fmt
+ (Z3.Expr.to_string e))) fds; *)
(* (\* Old code relying on provided vars *\) *)
(* let sorts = (List.map (fun id -> type_to_sort id.var_type) vars) in *)
- (* let symbols = (List.map (fun id -> Z3.FuncDecl.get_name (get_fdecl id.var_id)) vars) in *)
-
+ (* let symbols = (List.map (fun id -> Z3.FuncDecl.get_name (get_fdecl
+ id.var_id)) vars) in *)
+
(* New code: we extract vars from expr *)
let module FDSet = Set.Make (struct
- type t = Z3.FuncDecl.func_decl
- let compare = compare
- (* let hash = Hashtbl.hash *)
- end)
- in
-(* Fonction seems unused
-
- let rec get_expr_vars e =
- let open Utils in
- let nb_args = Z3.Expr.get_num_args e in
- if nb_args <= 0 then (
- let fdecl = Z3.Expr.get_func_decl e in
- (* let params = Z3.FuncDecl.get_parameters fdecl in *)
- (* Format.eprintf "Extracting info about %s: @." (Z3.Expr.to_string e); *)
- let dkind = Z3.FuncDecl.get_decl_kind fdecl in
- match dkind with Z3enums.OP_UNINTERPRETED -> (
- (* Format.eprintf "kind = %s, " (match dkind with Z3enums.OP_TRUE -> "true" | Z3enums.OP_UNINTERPRETED -> "uninter"); *)
- (* let open Z3.FuncDecl.Parameter in *)
- (* List.iter (fun p -> *)
- (* match p with *)
- (* P_Int i -> Format.eprintf "int %i" i *)
- (* | P_Dbl f -> Format.eprintf "dbl %f" f *)
- (* | P_Sym s -> Format.eprintf "symb" *)
- (* | P_Srt s -> Format.eprintf "sort" *)
- (* | P_Ast _ ->Format.eprintf "ast" *)
- (* | P_Fdl f -> Format.eprintf "fundecl" *)
- (* | P_Rat s -> Format.eprintf "rat %s" s *)
-
- (* ) params; *)
- (* Format.eprintf "]@."; *)
- FDSet.singleton fdecl
- )
- | _ -> FDSet.empty
- )
- else (*if nb_args > 0 then*)
- List.fold_left
- (fun accu e -> FDSet.union accu (get_expr_vars e))
- FDSet.empty (Z3.Expr.get_args e)
- in
- *)
- (* Unsed variable. Coul;d be reintroduced
- let extracted_vars = FDSet.elements (FDSet.diff (get_expr_vars expr) (FDSet.of_list dont_touch)) in
- let extracted_sorts = List.map Z3.FuncDecl.get_range extracted_vars in
- let extracted_symbols = List.map Z3.FuncDecl.get_name extracted_vars in
- *)
- if !debug then (
+ type t = Z3.FuncDecl.func_decl
+
+ let compare = compare
+ (* let hash = Hashtbl.hash *)
+ end) in
+ (* Fonction seems unused
+
+ let rec get_expr_vars e = let open Utils in let nb_args =
+ Z3.Expr.get_num_args e in if nb_args <= 0 then ( let fdecl =
+ Z3.Expr.get_func_decl e in (* let params = Z3.FuncDecl.get_parameters fdecl
+ in *) (* Format.eprintf "Extracting info about %s: @." (Z3.Expr.to_string
+ e); *) let dkind = Z3.FuncDecl.get_decl_kind fdecl in match dkind with
+ Z3enums.OP_UNINTERPRETED -> ( (* Format.eprintf "kind = %s, " (match dkind
+ with Z3enums.OP_TRUE -> "true" | Z3enums.OP_UNINTERPRETED -> "uninter"); *)
+ (* let open Z3.FuncDecl.Parameter in *) (* List.iter (fun p -> *) (* match
+ p with *) (* P_Int i -> Format.eprintf "int %i" i *) (* | P_Dbl f ->
+ Format.eprintf "dbl %f" f *) (* | P_Sym s -> Format.eprintf "symb" *) (* |
+ P_Srt s -> Format.eprintf "sort" *) (* | P_Ast _ ->Format.eprintf "ast" *)
+ (* | P_Fdl f -> Format.eprintf "fundecl" *) (* | P_Rat s -> Format.eprintf
+ "rat %s" s *)
+
+ (* ) params; *) (* Format.eprintf "]@."; *) FDSet.singleton fdecl ) | _ ->
+ FDSet.empty ) else (*if nb_args > 0 then*) List.fold_left (fun accu e ->
+ FDSet.union accu (get_expr_vars e)) FDSet.empty (Z3.Expr.get_args e) in *)
+ (* Unsed variable. Coul;d be reintroduced let extracted_vars = FDSet.elements
+ (FDSet.diff (get_expr_vars expr) (FDSet.of_list dont_touch)) in let
+ extracted_sorts = List.map Z3.FuncDecl.get_range extracted_vars in let
+ extracted_symbols = List.map Z3.FuncDecl.get_name extracted_vars in *)
+ if !debug then
Format.eprintf "Declaring rule: %s with variables @[<v 0>@ [%a@ ]@]@ @."
(Z3.Expr.to_string expr)
- (Utils.fprintf_list ~sep:",@ " (fun fmt e -> Format.fprintf fmt "%s" (Z3.Expr.to_string e))) (List.map horn_var_to_expr vars)
- )
- ;
- let expr = Z3.Quantifier.mk_forall_const
- !ctx (* context *)
- (List.map horn_var_to_expr vars) (* TODO provide bounded variables as expr *)
- (* sorts (\* sort list*\) *)
- (* symbols (\* symbol list *\) *)
- expr (* expression *)
- None (* quantifier weight, None means 1 *)
- [] (* pattern list ? *)
- [] (* ? *)
- None (* ? *)
- None (* ? *)
+ (Utils.fprintf_list ~sep:",@ " (fun fmt e ->
+ Format.fprintf fmt "%s" (Z3.Expr.to_string e)))
+ (List.map horn_var_to_expr vars);
+ let expr =
+ Z3.Quantifier.mk_forall_const !ctx
+ (* context *)
+ (List.map horn_var_to_expr vars)
+ (* TODO provide bounded variables as expr *)
+ (* sorts (\* sort list*\) *)
+ (* symbols (\* symbol list *\) *)
+ expr (* expression *) None (* quantifier weight, None means 1 *) []
+ (* pattern list ? *) [] (* ? *) None (* ? *) None
+ (* ? *)
in
+
(* Format.eprintf "OK@.@?"; *)
- (*
- TODO: bizarre la declaration de INIT tout seul semble poser pb.
- *)
- Z3.Fixedpoint.add_rule !fp
- (Z3.Quantifier.expr_of_quantifier expr)
- None
+ (* TODO: bizarre la declaration de INIT tout seul semble poser pb. *)
+ Z3.Fixedpoint.add_rule !fp (Z3.Quantifier.expr_of_quantifier expr) None
-
(********************************************************)
-
+
let machine_reset machines m =
let locals = local_memory_vars m in
-
+
(* print "x_m = x_c" for each local memory *)
let mid_mem_def =
- List.map (fun v ->
- Z3.Boolean.mk_eq !ctx
- (horn_var_to_expr (rename_mid v))
- (horn_var_to_expr (rename_current v))
- ) locals
+ List.map
+ (fun v ->
+ Z3.Boolean.mk_eq !ctx
+ (horn_var_to_expr (rename_mid v))
+ (horn_var_to_expr (rename_current v)))
+ locals
in
- (* print "child_reset ( associated vars _ {c,m} )" for each subnode.
- Special treatment for _arrow: _first = true
- *)
-
+ (* print "child_reset ( associated vars _ {c,m} )" for each subnode. Special
+ treatment for _arrow: _first = true *)
let reset_instances =
-
- List.map (fun (id, (n, _)) ->
- let name = node_name n in
- if name = "_arrow" then (
- Z3.Boolean.mk_eq !ctx
- (
- let vdecl = get_fdecl ((concat m.mname.node_id id) ^ "._arrow._first_m") in
- Z3.Expr.mk_const_f !ctx vdecl
- )
- (Z3.Boolean.mk_true !ctx)
-
- ) else (
- let machine_n = get_machine machines name in
-
- Z3.Expr.mk_app
- !ctx
- (get_fdecl (name ^ "_reset"))
- (List.map (horn_var_to_expr)
- (idx::uid:: (* Additional vars: counters, uid *)
- (rename_machine_list (concat m.mname.node_id id) (reset_vars machines machine_n))
- ))
-
- )
- ) m.minstances
-
-
+ List.map
+ (fun (id, (n, _)) ->
+ let name = node_name n in
+ if name = "_arrow" then
+ Z3.Boolean.mk_eq !ctx
+ (let vdecl =
+ get_fdecl (concat m.mname.node_id id ^ "._arrow._first_m")
+ in
+ Z3.Expr.mk_const_f !ctx vdecl)
+ (Z3.Boolean.mk_true !ctx)
+ else
+ let machine_n = get_machine machines name in
+
+ Z3.Expr.mk_app !ctx
+ (get_fdecl (name ^ "_reset"))
+ (List.map horn_var_to_expr
+ (idx
+ ::
+ uid
+ ::
+ (* Additional vars: counters, uid *)
+ rename_machine_list
+ (concat m.mname.node_id id)
+ (reset_vars machines machine_n))))
+ m.minstances
in
-
+
Z3.Boolean.mk_and !ctx (mid_mem_def @ reset_instances)
-
-
-(* TODO: empty list means true statement *)
+(* TODO: empty list means true statement *)
let decl_machine machines m =
- if m.mname.node_id = Arrow.arrow_id then
- (* We don't do arrow function *)
+ if m.mname.node_id = Arrow.arrow_id then (* We don't do arrow function *)
()
else
- begin
- let _ =
- List.map decl_var
- (
- (inout_vars m)@
- (rename_current_list (full_memory_vars machines m)) @
- (rename_mid_list (full_memory_vars machines m)) @
- (rename_next_list (full_memory_vars machines m)) @
- (rename_machine_list m.mname.node_id m.mstep.step_locals)
- )
+ let _ =
+ List.map decl_var
+ (inout_vars m
+ @ rename_current_list (full_memory_vars machines m)
+ @ rename_mid_list (full_memory_vars machines m)
+ @ rename_next_list (full_memory_vars machines m)
+ @ rename_machine_list m.mname.node_id m.mstep.step_locals)
+ in
+ if is_stateless m then (
+ if !debug then
+ Format.eprintf "Declaring a stateless machine: %s@." m.mname.node_id;
+
+ (* Declaring single predicate *)
+ let vars = inout_vars m in
+ let vars_types = List.map (fun v -> type_to_sort v.var_type) vars in
+ let _ = decl_rel (machine_stateless_name m.mname.node_id) vars_types in
+
+ let horn_body, _ (* don't care for reset here *) =
+ instrs_to_expr machines [] (* No reset info for stateless nodes *) m
+ m.mstep.step_instrs
+ in
+ let horn_head =
+ Z3.Expr.mk_app !ctx
+ (get_fdecl (machine_stateless_name m.mname.node_id))
+ (List.map horn_var_to_expr
+ (idx :: uid :: (* Additional vars: counters, uid *)
+ vars))
+ in
+ (* this line seems useless *)
+ let vars =
+ idx :: uid :: vars
+ @ rename_machine_list m.mname.node_id m.mstep.step_locals
+ in
+ (* Format.eprintf "useless Vars: %a@." (Utils.fprintf_list ~sep:"@ "
+ Printers.pp_var) vars; *)
+ match m.mstep.step_asserts with
+ | [] ->
+ (* Rule for single predicate : "; Stateless step rule @." *)
+ (*let vars = rename_machine_list m.mname.node_id m.mstep.step_locals in*)
+ (* TODO clean code *)
+ (* Format.eprintf "used Vars: %a@." (Utils.fprintf_list ~sep:"@ "
+ Printers.pp_var) vars; *)
+ add_rule vars (Z3.Boolean.mk_implies !ctx horn_body horn_head)
+ | assertsl ->
+ (*Rule for step "; Stateless step rule with Assertions @.";*)
+ let body_with_asserts =
+ Z3.Boolean.mk_and !ctx
+ (horn_body :: List.map (horn_val_to_expr m m.mname.node_id) assertsl)
+ in
+ let vars = rename_machine_list m.mname.node_id m.mstep.step_locals in
+ add_rule vars (Z3.Boolean.mk_implies !ctx body_with_asserts horn_head))
+ else
+ (* Rule for reset *)
+ let vars = reset_vars machines m in
+ let vars_types = List.map (fun v -> type_to_sort v.var_type) vars in
+ let _ = decl_rel (machine_reset_name m.mname.node_id) vars_types in
+ let horn_reset_body = machine_reset machines m in
+ let horn_reset_head =
+ Z3.Expr.mk_app !ctx
+ (get_fdecl (machine_reset_name m.mname.node_id))
+ (List.map horn_var_to_expr
+ (idx :: uid :: (* Additional vars: counters, uid *)
+ vars))
in
- if is_stateless m then
- begin
- if !debug then
- Format.eprintf "Declaring a stateless machine: %s@." m.mname.node_id;
-
- (* Declaring single predicate *)
- let vars = inout_vars m in
- let vars_types = List.map (fun v -> type_to_sort v.var_type) vars in
- let _ = decl_rel (machine_stateless_name m.mname.node_id) vars_types in
-
- let horn_body, _ (* don't care for reset here *) =
- instrs_to_expr
- machines
- ([] (* No reset info for stateless nodes *) )
- m
- m.mstep.step_instrs
- in
- let horn_head =
- Z3.Expr.mk_app
- !ctx
- (get_fdecl (machine_stateless_name m.mname.node_id))
- ( List.map (horn_var_to_expr) (idx::uid:: (* Additional vars: counters, uid *) vars))
- in
- (* this line seems useless *)
- let vars = idx::uid::vars@(rename_machine_list m.mname.node_id m.mstep.step_locals) in
- (* Format.eprintf "useless Vars: %a@." (Utils.fprintf_list ~sep:"@ " Printers.pp_var) vars; *)
- match m.mstep.step_asserts with
- | [] ->
- begin
- (* Rule for single predicate : "; Stateless step rule @." *)
- (*let vars = rename_machine_list m.mname.node_id m.mstep.step_locals in*)
- (* TODO clean code *)
- (* Format.eprintf "used Vars: %a@." (Utils.fprintf_list ~sep:"@ " Printers.pp_var) vars; *)
- add_rule vars (Z3.Boolean.mk_implies !ctx horn_body horn_head)
-
- end
- | assertsl ->
- begin
- (*Rule for step "; Stateless step rule with Assertions @.";*)
- let body_with_asserts =
- Z3.Boolean.mk_and !ctx (horn_body :: List.map (horn_val_to_expr m m.mname.node_id) assertsl)
- in
- let vars = rename_machine_list m.mname.node_id m.mstep.step_locals in
- add_rule vars (Z3.Boolean.mk_implies !ctx body_with_asserts horn_head)
- end
- end
- else
- begin
-
- (* Rule for reset *)
-
- let vars = reset_vars machines m in
- let vars_types = List.map (fun v -> type_to_sort v.var_type) vars in
- let _ = decl_rel (machine_reset_name m.mname.node_id) vars_types in
- let horn_reset_body = machine_reset machines m in
- let horn_reset_head =
- Z3.Expr.mk_app
- !ctx
- (get_fdecl (machine_reset_name m.mname.node_id))
- ( List.map (horn_var_to_expr) (idx::uid:: (* Additional vars: counters, uid *) vars))
- in
-
-
- let _ =
- add_rule (idx::uid::vars) (Z3.Boolean.mk_implies !ctx horn_reset_body horn_reset_head)
-
- in
-
- (* Rule for step*)
- let vars = step_vars machines m in
- let vars_types = List.map (fun v -> type_to_sort v.var_type) vars in
- let _ = decl_rel (machine_step_name m.mname.node_id) vars_types in
- let horn_step_body, _ (* don't care for reset here *) =
- instrs_to_expr
- machines
- []
- m
- m.mstep.step_instrs
- in
- let horn_step_head =
- Z3.Expr.mk_app
- !ctx
- (get_fdecl (machine_step_name m.mname.node_id))
- ( List.map (horn_var_to_expr) (idx::uid:: (* Additional vars: counters, uid *) vars))
- in
- match m.mstep.step_asserts with
- | [] ->
- begin
- (* Rule for single predicate *)
- let vars = (step_vars_c_m_x machines m) @(rename_machine_list m.mname.node_id m.mstep.step_locals) in
- add_rule (idx::uid::vars) (Z3.Boolean.mk_implies !ctx horn_step_body horn_step_head)
-
- end
- | assertsl ->
- begin
- (* Rule for step Assertions @.; *)
- let body_with_asserts =
- Z3.Boolean.mk_and !ctx
- (horn_step_body :: List.map (horn_val_to_expr m m.mname.node_id) assertsl)
- in
- let vars = (step_vars_c_m_x machines m) @(rename_machine_list m.mname.node_id m.mstep.step_locals) in
- add_rule (idx::uid::vars) (Z3.Boolean.mk_implies !ctx body_with_asserts horn_step_head)
-
- end
-
- end
- end
+ let _ =
+ add_rule (idx :: uid :: vars)
+ (Z3.Boolean.mk_implies !ctx horn_reset_body horn_reset_head)
+ in
+ (* Rule for step*)
+ let vars = step_vars machines m in
+ let vars_types = List.map (fun v -> type_to_sort v.var_type) vars in
+ let _ = decl_rel (machine_step_name m.mname.node_id) vars_types in
+ let horn_step_body, _ (* don't care for reset here *) =
+ instrs_to_expr machines [] m m.mstep.step_instrs
+ in
+ let horn_step_head =
+ Z3.Expr.mk_app !ctx
+ (get_fdecl (machine_step_name m.mname.node_id))
+ (List.map horn_var_to_expr
+ (idx :: uid :: (* Additional vars: counters, uid *)
+ vars))
+ in
+ match m.mstep.step_asserts with
+ | [] ->
+ (* Rule for single predicate *)
+ let vars =
+ step_vars_c_m_x machines m
+ @ rename_machine_list m.mname.node_id m.mstep.step_locals
+ in
+ add_rule (idx :: uid :: vars)
+ (Z3.Boolean.mk_implies !ctx horn_step_body horn_step_head)
+ | assertsl ->
+ (* Rule for step Assertions @.; *)
+ let body_with_asserts =
+ Z3.Boolean.mk_and !ctx
+ (horn_step_body
+ :: List.map (horn_val_to_expr m m.mname.node_id) assertsl)
+ in
+ let vars =
+ step_vars_c_m_x machines m
+ @ rename_machine_list m.mname.node_id m.mstep.step_locals
+ in
+ add_rule (idx :: uid :: vars)
+ (Z3.Boolean.mk_implies !ctx body_with_asserts horn_step_head)
(* Debug functions *)
-(*
-let rec extract_expr_fds e =
- (* Format.eprintf "@[<v 2>Extracting fundecls from expr %s@ " *)
- (* (Z3.Expr.to_string e); *)
-
- (* Removing quantifier is there are some *)
- let e = (* I didn't found a nicer way to do it than with an exception. My
- bad *)
- try
- let eq = Z3.Quantifier.quantifier_of_expr e in
- let e2 = Z3.Quantifier.get_body eq in
- (* Format.eprintf "Extracted quantifier body@ "; *)
- e2
-
- with _ -> Format.eprintf "No quantifier info@ "; e
- in
- let _ =
- try
- (
- let fd = Z3.Expr.get_func_decl e in
- let fd_symbol = Z3.FuncDecl.get_name fd in
- let fd_name = Z3.Symbol.to_string fd_symbol in
- if not (Hashtbl.mem decls fd_name) then
- register_fdecl fd_name fd;
- (* Format.eprintf "fdecls (%s): %s@ " *)
- (* fd_name *)
- (* (Z3.FuncDecl.to_string fd); *)
- try
- (
- let args = Z3.Expr.get_args e in
- (* Format.eprintf "@[<v>@ "; *)
- (* List.iter extract_expr_fds args; *)
- (* Format.eprintf "@]@ "; *)
- ()
- )
- with _ ->
- Format.eprintf "Impossible to extract fundecl args for expression %s@ "
- (Z3.Expr.to_string e)
- )
- with _ ->
- Format.eprintf "Impossible to extract anything from expression %s@ "
- (Z3.Expr.to_string e)
- in
- (* Format.eprintf "@]@ " *)
- ()
- *)
+(* let rec extract_expr_fds e = (* Format.eprintf "@[<v 2>Extracting fundecls
+ from expr %s@ " *) (* (Z3.Expr.to_string e); *)
+
+ (* Removing quantifier is there are some *) let e = (* I didn't found a nicer
+ way to do it than with an exception. My bad *) try let eq =
+ Z3.Quantifier.quantifier_of_expr e in let e2 = Z3.Quantifier.get_body eq in
+ (* Format.eprintf "Extracted quantifier body@ "; *) e2
+
+ with _ -> Format.eprintf "No quantifier info@ "; e in let _ = try ( let fd =
+ Z3.Expr.get_func_decl e in let fd_symbol = Z3.FuncDecl.get_name fd in let
+ fd_name = Z3.Symbol.to_string fd_symbol in if not (Hashtbl.mem decls fd_name)
+ then register_fdecl fd_name fd; (* Format.eprintf "fdecls (%s): %s@ " *) (*
+ fd_name *) (* (Z3.FuncDecl.to_string fd); *) try ( let args =
+ Z3.Expr.get_args e in (* Format.eprintf "@[<v>@ "; *) (* List.iter
+ extract_expr_fds args; *) (* Format.eprintf "@]@ "; *) () ) with _ ->
+ Format.eprintf "Impossible to extract fundecl args for expression %s@ "
+ (Z3.Expr.to_string e) ) with _ -> Format.eprintf "Impossible to extract
+ anything from expression %s@ " (Z3.Expr.to_string e) in (* Format.eprintf
+ "@]@ " *) () *)
(* Local Variables: *)
(* compile-command:"make -C ../.." *)
(* End: *)
diff --git a/src/tools/zustre/zustre_data.ml b/src/tools/zustre/zustre_data.ml
index 26c072a548bddfc356040d043d1ffbe8af8c75c5..5a8199e1a23a5eac9e24d43a6266b98564b6fe76 100644
--- a/src/tools/zustre/zustre_data.ml
+++ b/src/tools/zustre/zustre_data.ml
@@ -1,16 +1,23 @@
let ctx = ref (Z3.mk_context [])
+
let fp = ref (Z3.Fixedpoint.mk_fixedpoint !ctx)
+let const_sorts : (Lustre_types.ident, Z3.Sort.sort) Hashtbl.t =
+ Hashtbl.create 13
-let const_sorts : (Lustre_types.ident, Z3.Sort.sort) Hashtbl.t = Hashtbl.create 13
-let const_tags : (Lustre_types.ident, Z3.Sort.sort) Hashtbl.t = Hashtbl.create 13
-let sort_elems : (Z3.Sort.sort, Lustre_types.ident list) Hashtbl.t = Hashtbl.create 13
+let const_tags : (Lustre_types.ident, Z3.Sort.sort) Hashtbl.t =
+ Hashtbl.create 13
+let sort_elems : (Z3.Sort.sort, Lustre_types.ident list) Hashtbl.t =
+ Hashtbl.create 13
-let decls: (Lustre_types.ident, Z3.FuncDecl.func_decl) Hashtbl.t = Hashtbl.create 13
+let decls : (Lustre_types.ident, Z3.FuncDecl.func_decl) Hashtbl.t =
+ Hashtbl.create 13
let debug = ref false
-let timeout = ref 10000 (* default : 10 s = 10 000 ms *)
+
+let timeout = ref 10000
+(* default : 10 s = 10 000 ms *)
(* Local Variables: *)
(* compile-command:"make -C ../.." *)
diff --git a/src/tools/zustre/zustre_test.ml b/src/tools/zustre/zustre_test.ml
index 03110bff1fb2899f481b66d667cc497c9846dfc1..e7d08685fa7f9cf9d082767ca17651df064c80d4 100644
--- a/src/tools/zustre/zustre_test.ml
+++ b/src/tools/zustre/zustre_test.ml
@@ -1,51 +1,41 @@
-(* Example of a use of Z3 Fixedpoint that doesn't work
- The file is self-contained and shall be compiled as follow:
+(* Example of a use of Z3 Fixedpoint that doesn't work The file is
+ self-contained and shall be compiled as follow:
- in File _tags, add the simple line
- <**/*>: package(z3)
+ in File _tags, add the simple line <**/*>: package(z3)
- Then compile as
- ocamlbuild -use-ocamlfind zustre_test.native
+ Then compile as ocamlbuild -use-ocamlfind zustre_test.native
- We obtain the following output:
- $ ./zustre_test.native
- Registered rules:
- Rule: (forall ((x Int) (y Int)) (=> (= x y) (f x y)))
- Rule: INIT_STATE
- Rule: (forall ((x Int) (y Int)) (=> (and (f x y) INIT_STATE) (MAIN x y)))
- Rule: (forall ((x Int) (y Int)) (=> (and (not (= x y)) (MAIN x y)) ERR))
-
- Fatal error: exception Z3.Error("Uninterpreted 'y' in <null>:
- f(#0,#1) :-
- (= (:var 1) y),
- (= (:var 0) x),
- (= x y).
- ")
+ We obtain the following output: $ ./zustre_test.native Registered rules:
+ Rule: (forall ((x Int) (y Int)) (=> (= x y) (f x y))) Rule: INIT_STATE Rule:
+ (forall ((x Int) (y Int)) (=> (and (f x y) INIT_STATE) (MAIN x y))) Rule:
+ (forall ((x Int) (y Int)) (=> (and (not (= x y)) (MAIN x y)) ERR))
-*)
+ Fatal error: exception Z3.Error("Uninterpreted 'y' in <null>: f(#0,#1) :- (=
+ (:var 1) y), (= (:var 0) x), (= x y). ") *)
-
-
-let rec fprintf_list ~sep:sep f fmt = function
- | [] -> ()
- | [e] -> f fmt e
- | x::r -> Format.fprintf fmt "%a%(%)%a" f x sep (fprintf_list ~sep f) r
+let rec fprintf_list ~sep f fmt = function
+ | [] ->
+ ()
+ | [ e ] ->
+ f fmt e
+ | x :: r ->
+ Format.fprintf fmt "%a%(%)%a" f x sep (fprintf_list ~sep f) r
(* Global references to declare Z3 context and Fixedpoint engine *)
-
+
let ctx = ref (Z3.mk_context [])
+
let fp = ref (Z3.Fixedpoint.mk_fixedpoint !ctx)
(* Shortcuts to basic sorts *)
let bool_sort = Z3.Boolean.mk_sort !ctx
+
let int_sort = Z3.Arithmetic.Integer.mk_sort !ctx
+
let real_sort = Z3.Arithmetic.Real.mk_sort !ctx
-
let _ =
-
-
(* Setting up the fixed point engine *)
fp := Z3.Fixedpoint.mk_fixedpoint !ctx;
let module P = Z3.Params in
@@ -55,172 +45,152 @@ let _ =
P.add_symbol params (mks "engine") (mks "spacer");
Z3.Fixedpoint.set_parameters !fp params;
- (* Three rules
- R1: (x = y) => f(x,y)
- R2: INIT and f(x,y) => MAIN(x,y)
- R3: x!=y and MAIN(x,y) => ERR(x,y)
- INIT is assumed as the beginning
+ (* Three rules R1: (x = y) => f(x,y) R2: INIT and f(x,y) => MAIN(x,y) R3: x!=y
+ and MAIN(x,y) => ERR(x,y) INIT is assumed as the beginning
Querying ERR shall be unsat since the only valid MAIN(x,y) are x=y and
- therefore ERR is unsat.
- *)
-
+ therefore ERR is unsat. *)
+
(* Simple rule : forall x, y, (x=y => f(x,y)) *)
let x = Z3.FuncDecl.mk_func_decl_s !ctx "x" [] int_sort in
let y = Z3.FuncDecl.mk_func_decl_s !ctx "y" [] int_sort in
let x_expr = Z3.Expr.mk_const_f !ctx x in
let y_expr = Z3.Expr.mk_const_f !ctx y in
-
- let decl_f = Z3.FuncDecl.mk_func_decl_s !ctx "f" [int_sort; int_sort] bool_sort in
- Z3.Fixedpoint.register_relation !fp decl_f; (* since f appears in the rhs of a rule *)
- let f_x_y_expr = Z3.Expr.mk_app !ctx decl_f [x_expr; y_expr] in
+
+ let decl_f =
+ Z3.FuncDecl.mk_func_decl_s !ctx "f" [ int_sort; int_sort ] bool_sort
+ in
+ Z3.Fixedpoint.register_relation !fp decl_f;
+ (* since f appears in the rhs of a rule *)
+ let f_x_y_expr = Z3.Expr.mk_app !ctx decl_f [ x_expr; y_expr ] in
let x_eq_y_expr = Z3.Boolean.mk_eq !ctx x_expr y_expr in
-
- let expr_f_lhs = (* x = y *)
- x_eq_y_expr
+
+ let expr_f_lhs =
+ (* x = y *)
+ x_eq_y_expr
in
let expr_f_rhs = f_x_y_expr in
let expr_f = Z3.Boolean.mk_implies !ctx expr_f_lhs expr_f_rhs in
(* Adding forall as prefix *)
- let expr_forall_f = Z3.Quantifier.mk_forall_const
- !ctx (* context *)
- (* [int_sort; int_sort] (\* sort list*\) *)
- (* [Z3.FuncDecl.get_name x; Z3.FuncDecl.get_name y] (\* symbol list *\) *)
-(* [x_expr; y_expr] Second try with expr list "const" *)
- [Z3.Expr.mk_const_f !ctx x; Z3.Expr.mk_const_f !ctx y]
- expr_f (* expression *)
- None (* quantifier weight, None means 1 *)
- [] (* pattern list ? *)
- [] (* ? *)
- None (* ? *)
- None (* ? *)
+ let expr_forall_f =
+ Z3.Quantifier.mk_forall_const !ctx
+ (* context *)
+ (* [int_sort; int_sort] (\* sort list*\) *)
+ (* [Z3.FuncDecl.get_name x; Z3.FuncDecl.get_name y] (\* symbol list *\) *)
+ (* [x_expr; y_expr] Second try with expr list "const" *)
+ [ Z3.Expr.mk_const_f !ctx x; Z3.Expr.mk_const_f !ctx y ]
+ expr_f (* expression *) None (* quantifier weight, None means 1 *) []
+ (* pattern list ? *) [] (* ? *) None (* ? *) None
+ (* ? *)
in
let expr_forall_f = Z3.Quantifier.expr_of_quantifier expr_forall_f in
Z3.Fixedpoint.add_rule !fp expr_forall_f None;
-
-
+
(* INIT RULE *)
let decl_init = Z3.FuncDecl.mk_func_decl_s !ctx "INIT_STATE" [] bool_sort in
- Z3.Fixedpoint.register_relation !fp decl_init;
+ Z3.Fixedpoint.register_relation !fp decl_init;
let init_expr = Z3.Expr.mk_app !ctx decl_init [] in
Z3.Fixedpoint.add_rule !fp init_expr None;
(* MAIN is defined by two rules : INIT and induction *)
- let decl_main = Z3.FuncDecl.mk_func_decl_s !ctx "MAIN" [int_sort; int_sort] bool_sort in
+ let decl_main =
+ Z3.FuncDecl.mk_func_decl_s !ctx "MAIN" [ int_sort; int_sort ] bool_sort
+ in
Z3.Fixedpoint.register_relation !fp decl_main;
- let main_x_y_expr = Z3.Expr.mk_app !ctx decl_main [x_expr; y_expr] in
-
- (* Rule 1: forall x, y, INIT_STATE and f(x,y) => MAIN(x,y) : at the beginning x=y *)
- let expr_main1_lhs = (* INIT_STATE and f(x, y) *)
- Z3.Boolean.mk_and !ctx [f_x_y_expr; init_expr] in
+ let main_x_y_expr = Z3.Expr.mk_app !ctx decl_main [ x_expr; y_expr ] in
+
+ (* Rule 1: forall x, y, INIT_STATE and f(x,y) => MAIN(x,y) : at the beginning
+ x=y *)
+ let expr_main1_lhs =
+ (* INIT_STATE and f(x, y) *)
+ Z3.Boolean.mk_and !ctx [ f_x_y_expr; init_expr ]
+ in
let expr_main1_rhs = main_x_y_expr in
let expr_main1 = Z3.Boolean.mk_implies !ctx expr_main1_lhs expr_main1_rhs in
(* Adding forall as prefix *)
- let expr_forall_main1 = Z3.Quantifier.mk_forall_const
- !ctx (* context *)
- (*
- [int_sort; int_sort] (* sort list*)
- [Z3.FuncDecl.get_name x; Z3.FuncDecl.get_name y] (* symbol list *)
- *)
- (* [x_expr; y_expr] Second try with expr list "const" *)
- [Z3.Expr.mk_const_f !ctx x; Z3.Expr.mk_const_f !ctx y]
- expr_main1 (* expression *)
- None (* quantifier weight, None means 1 *)
- [] (* pattern list ? *)
- [] (* ? *)
- None (* ? *)
- None (* ? *)
+ let expr_forall_main1 =
+ Z3.Quantifier.mk_forall_const !ctx
+ (* context *)
+ (* [int_sort; int_sort] (* sort list*) [Z3.FuncDecl.get_name x;
+ Z3.FuncDecl.get_name y] (* symbol list *) *)
+ (* [x_expr; y_expr] Second try with expr list "const" *)
+ [ Z3.Expr.mk_const_f !ctx x; Z3.Expr.mk_const_f !ctx y ]
+ expr_main1 (* expression *) None (* quantifier weight, None means 1 *) []
+ (* pattern list ? *) [] (* ? *) None (* ? *) None
+ (* ? *)
in
let expr_forall_main1 = Z3.Quantifier.expr_of_quantifier expr_forall_main1 in
Z3.Fixedpoint.add_rule !fp expr_forall_main1 None;
(* Rule 2: forall x,y, MAIN(x,y) => MAIN(x+1, y+1) *)
let expr_main2_lhs = main_x_y_expr in
- let plus_one x = Z3.Arithmetic.mk_add !ctx
- [
- x;
- (* Z3.Arithmetic.Integer.mk_const_s !ctx "1" *)
- Z3.Expr.mk_numeral_int !ctx 1 int_sort
- ] in
- let main_x_y_plus_one_expr = Z3.Expr.mk_app !ctx decl_main [plus_one x_expr; plus_one y_expr] in
+ let plus_one x =
+ Z3.Arithmetic.mk_add !ctx
+ [
+ x;
+ (* Z3.Arithmetic.Integer.mk_const_s !ctx "1" *)
+ Z3.Expr.mk_numeral_int !ctx 1 int_sort;
+ ]
+ in
+ let main_x_y_plus_one_expr =
+ Z3.Expr.mk_app !ctx decl_main [ plus_one x_expr; plus_one y_expr ]
+ in
let expr_main2_rhs = main_x_y_plus_one_expr in
let expr_main2 = Z3.Boolean.mk_implies !ctx expr_main2_lhs expr_main2_rhs in
(* Adding forall as prefix *)
- let expr_forall_main2 = Z3.Quantifier.mk_forall_const
- !ctx (* context *)
- (*
- [int_sort; int_sort] (* sort list*)
- [Z3.FuncDecl.get_name x; Z3.FuncDecl.get_name y] (* symbol list *)
- *)
- (* [x_expr; y_expr] Second try with expr list "const" *)
- [Z3.Expr.mk_const_f !ctx x; Z3.Expr.mk_const_f !ctx y]
- expr_main2 (* expression *)
- None (* quantifier weight, None means 1 *)
- [] (* pattern list ? *)
- [] (* ? *)
- None (* ? *)
- None (* ? *)
+ let expr_forall_main2 =
+ Z3.Quantifier.mk_forall_const !ctx
+ (* context *)
+ (* [int_sort; int_sort] (* sort list*) [Z3.FuncDecl.get_name x;
+ Z3.FuncDecl.get_name y] (* symbol list *) *)
+ (* [x_expr; y_expr] Second try with expr list "const" *)
+ [ Z3.Expr.mk_const_f !ctx x; Z3.Expr.mk_const_f !ctx y ]
+ expr_main2 (* expression *) None (* quantifier weight, None means 1 *) []
+ (* pattern list ? *) [] (* ? *) None (* ? *) None
+ (* ? *)
in
let expr_forall_main2 = Z3.Quantifier.expr_of_quantifier expr_forall_main2 in
Z3.Fixedpoint.add_rule !fp expr_forall_main2 None;
-
-
-
+
(* TODO: not implemented yet since the error is visible without it *)
-
+
(* Query: is it possible to have MAIN(x,y) and x!=y ? *)
- (* This is performed as follow:
- rule (forall x, y, MAIN(x,y) and x!=y => ERR)
- *)
+ (* This is performed as follow: rule (forall x, y, MAIN(x,y) and x!=y => ERR) *)
let decl_err = Z3.FuncDecl.mk_func_decl_s !ctx "ERR" [] bool_sort in
- Z3.Fixedpoint.register_relation !fp decl_err;
+ Z3.Fixedpoint.register_relation !fp decl_err;
let err_expr = Z3.Expr.mk_app !ctx decl_err [] in
let x_diff_y_expr = Z3.Boolean.mk_not !ctx x_eq_y_expr in
- let expr_err_lhs =
- Z3.Boolean.mk_and !ctx [x_diff_y_expr; main_x_y_expr] in
+ let expr_err_lhs = Z3.Boolean.mk_and !ctx [ x_diff_y_expr; main_x_y_expr ] in
let expr_err_rhs = err_expr in
let expr_err = Z3.Boolean.mk_implies !ctx expr_err_lhs expr_err_rhs in
(* Adding forall as prefix *)
- let expr_forall_err = Z3.Quantifier.mk_forall_const
- !ctx (* context *)
-(* [int_sort; int_sort] (* sort list*)
- [Z3.FuncDecl.get_name x; Z3.FuncDecl.get_name y] (* symbol list *)
-*)
- (* [x_expr; y_expr] Second try with expr list "const" *)
- [Z3.Expr.mk_const_f !ctx x; Z3.Expr.mk_const_f !ctx y]
- expr_err (* expression *)
- None (* quantifier weight, None means 1 *)
- [] (* pattern list ? *)
- [] (* ? *)
- None (* ? *)
- None (* ? *)
+ let expr_forall_err =
+ Z3.Quantifier.mk_forall_const !ctx
+ (* context *)
+ (* [int_sort; int_sort] (* sort list*) [Z3.FuncDecl.get_name x;
+ Z3.FuncDecl.get_name y] (* symbol list *) *)
+ (* [x_expr; y_expr] Second try with expr list "const" *)
+ [ Z3.Expr.mk_const_f !ctx x; Z3.Expr.mk_const_f !ctx y ]
+ expr_err (* expression *) None (* quantifier weight, None means 1 *) []
+ (* pattern list ? *) [] (* ? *) None (* ? *) None
+ (* ? *)
in
let expr_forall_err = Z3.Quantifier.expr_of_quantifier expr_forall_err in
Z3.Fixedpoint.add_rule !fp expr_forall_err None;
(* Printing the rules for sanity check *)
-
let rules_expr = Z3.Fixedpoint.get_rules !fp in
Format.eprintf "@[<v 2>Registered rules:@ %a@ @]@."
- (fprintf_list ~sep:"@ "
- (fun fmt e ->
- (* let e2 = Z3.Quantifier.get_body eq in *)
- (* let fd = Z3.Expr.get_func_decl e in *)
- Format.fprintf fmt "Rule: %s@ "
- (Z3.Expr.to_string e);
- )) rules_expr;
-
+ (fprintf_list ~sep:"@ " (fun fmt e ->
+ (* let e2 = Z3.Quantifier.get_body eq in *)
+ (* let fd = Z3.Expr.get_func_decl e in *)
+ Format.fprintf fmt "Rule: %s@ " (Z3.Expr.to_string e)))
+ rules_expr;
- let res_status = Z3.Fixedpoint.query_r !fp [decl_err] in
+ let res_status = Z3.Fixedpoint.query_r !fp [ decl_err ] in
Format.eprintf "Status: %s@." (Z3.Solver.string_of_status res_status);
-
let ts = Z3.Tactic.get_tactic_names !ctx in
List.iter (fun s -> Format.printf "%s@." s) ts;
()
-
-
-
-
-
diff --git a/src/tools/zustre/zustre_verifier.ml b/src/tools/zustre/zustre_verifier.ml
index 3690f9d7085b055bf88bc5b81b972e7d817ab1e0..5f1f72cdba2d906d3d3e4f787db1e39d02b0f239 100644
--- a/src/tools/zustre/zustre_verifier.ml
+++ b/src/tools/zustre/zustre_verifier.ml
@@ -1,4 +1,3 @@
-
(*
TODO
@@ -34,241 +33,233 @@ Analysis:
*)
-
open Zustre_common
open Zustre_data
let param_stat = ref false
+
let param_eldarica = ref false
+
let param_utvpi = ref false
+
let param_tosmt = ref false
+
let param_pp = ref false
let active = ref false
-module Verifier =
- (struct
- include VerifierType.Default
- let name = "zustre"
- let options = [
- "-stat", Arg.Set param_stat, "print statistics";
- "-eldarica", Arg.Set param_eldarica, "deactivate fixedpoint extensions when printing rules";
- "-no_utvpi", Arg.Set param_utvpi, "Deactivate UTVPI strategy";
- "-tosmt", Arg.Set param_tosmt, "Print low-level (possibly unreadable) SMT2 statements";
- "-timeout", Arg.Set_int timeout, "Set timeout in ms (default 10000 = 10 s)";
- "-no-pp", Arg.Set param_pp, "No preprocessing (inlining and slicing)";
- "-debug", Arg.Set debug, "Debug mode";
- ]
-
- let activate () = (
- active := true;
- Options.output := "horn";
- )
-
- let is_active () = !active
-
- let get_normalization_params () =
- (* make sure the output is "Horn" *)
- assert(!Options.output = "horn");
- Backends.get_normalization_params ()
-
- let setup_solver () =
- fp := Z3.Fixedpoint.mk_fixedpoint !ctx;
- (* let help = Z3.Fixedpoint.get_help fp in
- * Format.eprintf "Fp help : %s@." help;
- *
- * let solver =Z3.Solver.mk_solver !ctx None in
- * let help = Z3.Solver.get_help solver in
- * Format.eprintf "Z3 help : %s@." help; *)
-
- let module P = Z3.Params in
- let module S = Z3.Symbol in
- let mks = S.mk_string !ctx in
-
- (* Fixpoint Engine parameters *)
-
- let fp_params = P.mk_params !ctx in
-
- (* (\* self.fp.set (engine='spacer') *\) *)
- P.add_symbol fp_params (mks "engine") (mks "spacer");
- (* P.add_symbol fp_params (mks "engine") (mks "pdr"); *)
-
- (* #z3.set_option(rational_to_decimal=True) *)
- (* #self.fp.set('precision',30) *)
- if !param_stat then
- (* self.fp.set('print_statistics',True) *)
- P.add_bool fp_params (mks "print_statistics") true;
-
- (* Dont know where to find this parameter *)
- (* if !param_spacer_verbose then
- * if self.args.spacer_verbose:
- * z3.set_option (verbose=1) *)
-
- (* The option is not recogined*)
- (* self.fp.set('use_heavy_mev',True) *)
- (* P.add_bool fp_params (mks "use_heavy_mev") true; *)
-
- (* self.fp.set('pdr.flexible_trace',True) *)
- P.add_bool fp_params (mks "pdr.flexible_trace") true;
-
- (* self.fp.set('reset_obligation_queue',False) *)
- P.add_bool fp_params (mks "spacer.reset_obligation_queue") false;
-
- (* self.fp.set('spacer.elim_aux',False) *)
- P.add_bool fp_params (mks "spacer.elim_aux") false;
-
- (* if self.args.eldarica:
- * self.fp.set('print_fixedpoint_extensions', False) *)
- if !param_eldarica then
- P.add_bool fp_params (mks "print_fixedpoint_extensions") false;
-
- (* if self.args.utvpi: self.fp.set('pdr.utvpi', False) *)
- if !param_utvpi then
- P.add_bool fp_params (mks "pdr.utvpi") false;
-
- (* if self.args.tosmt:
- * self.log.info("Setting low level printing")
- * self.fp.set ('print.low_level_smt2',True) *)
- if !param_tosmt then
- P.add_bool fp_params (mks "print.low_level_smt2") true;
-
- (* if not self.args.pp:
- * self.log.info("No pre-processing")
- * self.fp.set ('xform.slice', False)
- * self.fp.set ('xform.inline_linear',False)
- * self.fp.set ('xform.inline_eager',False) *\) *)
- if not !param_pp then (
- (* Mandatory to print all steps and recover cex *)
- P.add_bool fp_params (mks "xform.slice") false;
- P.add_bool fp_params (mks "xform.inline_linear") false;
- P.add_bool fp_params (mks "xform.inline_eager") false
- );
-
-
- (* Ploc's options. Do not seem to have any effect yet *)
- P.add_bool fp_params (mks "print_answer") true;
- (* P.add_bool fp_params (mks "print_certificate") true; *)
- P.add_bool fp_params (mks "xform.slice") false ; (* required to preserve signatures *)
-
- (* P.add_bool fp_params (mks "print_statistics") true; *)
- (* P.add_bool fp_params (mks "print_certificate") true; *)
-
- (* Adding a timeout *)
- P.add_int fp_params (mks "timeout") !timeout;
-
- Z3.Fixedpoint.set_parameters !fp fp_params
-
- let run ~basename _prog machines =
- let machines = Machine_code_common.arrow_machine::machines in
- let machines = preprocess machines in
- setup_solver ();
-
-
- (* TODO
- load deps: cf print_dep in horn_backend.ml
-
-
- if false then (
-
- let queries = Z3.Fixedpoint.parse_file !fp "nstep.smt2" in
-
- (* Debug instructions *)
-
-
-
- let rules_expr = Z3.Fixedpoint.get_rules !fp in
- Format.eprintf "@[<v 2>Registered rules:@ %a@ @]@."
- (Utils.fprintf_list ~sep:"@ "
- (fun fmt e ->
- (* let e2 = Z3.Quantifier.get_body eq in *)
- (* let fd = Z3.Expr.get_func_decl e in *)
- Format.fprintf fmt "Rule: %s@."
- (Z3.Expr.to_string e);
- )) rules_expr;
-
- let _ = List.map extract_expr_fds rules_expr in
- Format.eprintf "%t" pp_fdecls;
-
- let decl_err = List.hd queries in
- let res_status = Z3.Fixedpoint.query !fp decl_err in
-
- Format.eprintf "Status: %s@." (Z3.Solver.string_of_status res_status);
- (* let _ = *)
- (* match res_status with *)
- (* | Z3.Solver.SATISFIABLE -> Zustre_cex.build_cex machine machines decl_err *)
- (* | _ -> () *)
- (* in *)
- exit 0
- )
- else if false then (
-
- (* No queries here *)
- let _ = Z3.Fixedpoint.parse_file !fp "mini_decl.smt2" in
-
- (* Debug instructions *)
-
-
-
- let rules_expr = Z3.Fixedpoint.get_rules !fp in
- Format.eprintf "@[<v 2>Registered rules:@ %a@ @]@."
- (Utils.fprintf_list ~sep:"@ "
- (fun fmt e ->
- (* let e2 = Z3.Quantifier.get_body eq in *)
- (* let fd = Z3.Expr.get_func_decl e in *)
- Format.fprintf fmt "Rule: %s@."
- (Z3.Expr.to_string e);
- )) rules_expr;
-
- let _ = List.map extract_expr_fds rules_expr in
- Format.eprintf "%t" pp_fdecls;
-
- if !Options.main_node <> "" then
- begin
- Zustre_analyze.check machines !Options.main_node
-
- end
- else
- failwith "Require main node";
-
- ()
- )
- else
-
- *)
-
- (
-
-
- decl_sorts ();
-
- List.iter (decl_machine machines) (List.rev machines);
-
-
- (* (\* Debug instructions *\) *)
- (* let rules_expr = Z3.Fixedpoint.get_rules !fp in *)
- (* Format.eprintf "@[<v 2>Registered rules:@ %a@ @]@." *)
- (* (Utils.fprintf_list ~sep:"@ " *)
- (* (fun fmt e -> Format.pp_print_string fmt (Z3.Expr.to_string e)) ) *)
- (* rules_expr; *)
-
- if !Options.main_node <> "" then
- begin
- Zustre_analyze.check machines !Options.main_node
-
- end
- else
- failwith "Require main node";
-
- ()
- )
-
-
- end: VerifierType.S)
+module Verifier : VerifierType.S = struct
+ include VerifierType.Default
+
+ let name = "zustre"
+
+ let options =
+ [
+ "-stat", Arg.Set param_stat, "print statistics";
+ ( "-eldarica",
+ Arg.Set param_eldarica,
+ "deactivate fixedpoint extensions when printing rules" );
+ "-no_utvpi", Arg.Set param_utvpi, "Deactivate UTVPI strategy";
+ ( "-tosmt",
+ Arg.Set param_tosmt,
+ "Print low-level (possibly unreadable) SMT2 statements" );
+ ( "-timeout",
+ Arg.Set_int timeout,
+ "Set timeout in ms (default 10000 = 10 s)" );
+ "-no-pp", Arg.Set param_pp, "No preprocessing (inlining and slicing)";
+ "-debug", Arg.Set debug, "Debug mode";
+ ]
+
+ let activate () =
+ active := true;
+ Options.output := "horn"
+
+ let is_active () = !active
+
+ let get_normalization_params () =
+ (* make sure the output is "Horn" *)
+ assert (!Options.output = "horn");
+ Backends.get_normalization_params ()
+
+ let setup_solver () =
+ fp := Z3.Fixedpoint.mk_fixedpoint !ctx;
+
+ (* let help = Z3.Fixedpoint.get_help fp in
+ * Format.eprintf "Fp help : %s@." help;
+ *
+ * let solver =Z3.Solver.mk_solver !ctx None in
+ * let help = Z3.Solver.get_help solver in
+ * Format.eprintf "Z3 help : %s@." help; *)
+ let module P = Z3.Params in
+ let module S = Z3.Symbol in
+ let mks = S.mk_string !ctx in
+
+ (* Fixpoint Engine parameters *)
+ let fp_params = P.mk_params !ctx in
+
+ (* (\* self.fp.set (engine='spacer') *\) *)
+ P.add_symbol fp_params (mks "engine") (mks "spacer");
+
+ (* P.add_symbol fp_params (mks "engine") (mks "pdr"); *)
+
+ (* #z3.set_option(rational_to_decimal=True) *)
+ (* #self.fp.set('precision',30) *)
+ if !param_stat then
+ (* self.fp.set('print_statistics',True) *)
+ P.add_bool fp_params (mks "print_statistics") true;
+
+ (* Dont know where to find this parameter *)
+ (* if !param_spacer_verbose then
+ * if self.args.spacer_verbose:
+ * z3.set_option (verbose=1) *)
+
+ (* The option is not recogined*)
+ (* self.fp.set('use_heavy_mev',True) *)
+ (* P.add_bool fp_params (mks "use_heavy_mev") true; *)
+
+ (* self.fp.set('pdr.flexible_trace',True) *)
+ P.add_bool fp_params (mks "pdr.flexible_trace") true;
+
+ (* self.fp.set('reset_obligation_queue',False) *)
+ P.add_bool fp_params (mks "spacer.reset_obligation_queue") false;
+
+ (* self.fp.set('spacer.elim_aux',False) *)
+ P.add_bool fp_params (mks "spacer.elim_aux") false;
+
+ (* if self.args.eldarica:
+ * self.fp.set('print_fixedpoint_extensions', False) *)
+ if !param_eldarica then
+ P.add_bool fp_params (mks "print_fixedpoint_extensions") false;
+
+ (* if self.args.utvpi: self.fp.set('pdr.utvpi', False) *)
+ if !param_utvpi then P.add_bool fp_params (mks "pdr.utvpi") false;
+
+ (* if self.args.tosmt:
+ * self.log.info("Setting low level printing")
+ * self.fp.set ('print.low_level_smt2',True) *)
+ if !param_tosmt then P.add_bool fp_params (mks "print.low_level_smt2") true;
+
+ (* if not self.args.pp:
+ * self.log.info("No pre-processing")
+ * self.fp.set ('xform.slice', False)
+ * self.fp.set ('xform.inline_linear',False)
+ * self.fp.set ('xform.inline_eager',False) *\) *)
+ if not !param_pp then (
+ (* Mandatory to print all steps and recover cex *)
+ P.add_bool fp_params (mks "xform.slice") false;
+ P.add_bool fp_params (mks "xform.inline_linear") false;
+ P.add_bool fp_params (mks "xform.inline_eager") false);
+
+ (* Ploc's options. Do not seem to have any effect yet *)
+ P.add_bool fp_params (mks "print_answer") true;
+ (* P.add_bool fp_params (mks "print_certificate") true; *)
+ P.add_bool fp_params (mks "xform.slice") false;
+
+ (* required to preserve signatures *)
+
+ (* P.add_bool fp_params (mks "print_statistics") true; *)
+ (* P.add_bool fp_params (mks "print_certificate") true; *)
+
+ (* Adding a timeout *)
+ P.add_int fp_params (mks "timeout") !timeout;
+
+ Z3.Fixedpoint.set_parameters !fp fp_params
+
+ let run ~basename _prog machines =
+ let machines = Machine_code_common.arrow_machine :: machines in
+ let machines = preprocess machines in
+ setup_solver ();
+
+ (* TODO
+ load deps: cf print_dep in horn_backend.ml
+
+
+ if false then (
+
+ let queries = Z3.Fixedpoint.parse_file !fp "nstep.smt2" in
+
+ (* Debug instructions *)
+
+
+
+ let rules_expr = Z3.Fixedpoint.get_rules !fp in
+ Format.eprintf "@[<v 2>Registered rules:@ %a@ @]@."
+ (Utils.fprintf_list ~sep:"@ "
+ (fun fmt e ->
+ (* let e2 = Z3.Quantifier.get_body eq in *)
+ (* let fd = Z3.Expr.get_func_decl e in *)
+ Format.fprintf fmt "Rule: %s@."
+ (Z3.Expr.to_string e);
+ )) rules_expr;
+
+ let _ = List.map extract_expr_fds rules_expr in
+ Format.eprintf "%t" pp_fdecls;
+
+ let decl_err = List.hd queries in
+ let res_status = Z3.Fixedpoint.query !fp decl_err in
+
+ Format.eprintf "Status: %s@." (Z3.Solver.string_of_status res_status);
+ (* let _ = *)
+ (* match res_status with *)
+ (* | Z3.Solver.SATISFIABLE -> Zustre_cex.build_cex machine machines decl_err *)
+ (* | _ -> () *)
+ (* in *)
+ exit 0
+ )
+ else if false then (
+
+ (* No queries here *)
+ let _ = Z3.Fixedpoint.parse_file !fp "mini_decl.smt2" in
+
+ (* Debug instructions *)
+
+
+
+ let rules_expr = Z3.Fixedpoint.get_rules !fp in
+ Format.eprintf "@[<v 2>Registered rules:@ %a@ @]@."
+ (Utils.fprintf_list ~sep:"@ "
+ (fun fmt e ->
+ (* let e2 = Z3.Quantifier.get_body eq in *)
+ (* let fd = Z3.Expr.get_func_decl e in *)
+ Format.fprintf fmt "Rule: %s@."
+ (Z3.Expr.to_string e);
+ )) rules_expr;
+
+ let _ = List.map extract_expr_fds rules_expr in
+ Format.eprintf "%t" pp_fdecls;
+
+ if !Options.main_node <> "" then
+ begin
+ Zustre_analyze.check machines !Options.main_node
+
+ end
+ else
+ failwith "Require main node";
+
+ ()
+ )
+ else
+ *)
+ decl_sorts ();
+
+ List.iter (decl_machine machines) (List.rev machines);
+
+ (* (\* Debug instructions *\) *)
+ (* let rules_expr = Z3.Fixedpoint.get_rules !fp in *)
+ (* Format.eprintf "@[<v 2>Registered rules:@ %a@ @]@." *)
+ (* (Utils.fprintf_list ~sep:"@ " *)
+ (* (fun fmt e -> Format.pp_print_string fmt (Z3.Expr.to_string e)) ) *)
+ (* rules_expr; *)
+ if !Options.main_node <> "" then
+ Zustre_analyze.check machines !Options.main_node
+ else failwith "Require main node";
+ ()
+end
let () =
- VerifierList.registered := (module Verifier : VerifierType.S) ::
- !VerifierList.registered
+ VerifierList.registered :=
+ (module Verifier : VerifierType.S) :: !VerifierList.registered
(* Local Variables: *)
(* compile-command:"make -C ../.. lustrev" *)
diff --git a/src/type_predef.ml b/src/type_predef.ml
index 48fd3f06aa5e87fd0f7b3f6a097fe07ce5c55726..c550c963a3ff590a0ba54c5a11b5dae2fa8477dc 100644
--- a/src/type_predef.ml
+++ b/src/type_predef.ml
@@ -6,79 +6,85 @@
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)
(* under the terms of the GNU Lesser General Public License *)
(* version 2.1. *)
-(* *)
+(* *)
(* This file was originally from the Prelude compiler *)
-(* *)
+(* *)
(********************************************************************)
(** Base types and predefined operator types. *)
-
-module Make (T: Types.S) =
-struct
+module Make (T : Types.S) = struct
(* module T = Types.Make (BT) *)
module BT = T.BasicT
- include T
-
+ include T
+
let type_int = new_ty type_int
+
let type_real = new_ty type_real
+
let type_bool = new_ty type_bool
+
let type_string = new_ty type_string
+
let type_clock ty = new_ty (Tclock ty)
+
let type_const tname = new_ty (Tconst tname)
+
let type_enum taglist = new_ty (Tenum taglist)
+
let type_struct fieldlist = new_ty (Tstruct fieldlist)
+
let type_tuple tl = new_ty (Ttuple tl)
+
let type_arrow ty1 ty2 = new_ty (Tarrow (ty1, ty2))
+
let type_array d ty = new_ty (Tarray (d, ty))
+
let type_static d ty = new_ty (Tstatic (d, ty))
-
- let type_unary_bool_op =
- new_ty (Tarrow (type_bool, type_bool))
+
+ let type_unary_bool_op = new_ty (Tarrow (type_bool, type_bool))
let type_unary_poly_op =
let univ = new_univar () in
type_arrow univ univ
- let type_bin_int_op =
- type_arrow (type_tuple [type_int;type_int]) type_int
+ let type_bin_int_op = type_arrow (type_tuple [ type_int; type_int ]) type_int
let type_bin_bool_op =
- type_arrow (type_tuple [type_bool;type_bool]) type_bool
+ type_arrow (type_tuple [ type_bool; type_bool ]) type_bool
let type_ite_op =
let univ = new_univar () in
- type_arrow (type_tuple [type_bool;univ;univ]) univ
+ type_arrow (type_tuple [ type_bool; univ; univ ]) univ
let type_bin_poly_op =
let univ = new_univar () in
- type_arrow (type_tuple [univ;univ]) univ
+ type_arrow (type_tuple [ univ; univ ]) univ
let type_bin_comp_op =
let univ = new_univar () in
- new_ty (Tarrow (new_ty (Ttuple [univ;univ]), type_bool))
+ new_ty (Tarrow (new_ty (Ttuple [ univ; univ ]), type_bool))
let type_univ_bool_univ =
let univ = new_univar () in
- type_arrow (type_tuple [univ;type_bool]) univ
+ type_arrow (type_tuple [ univ; type_bool ]) univ
let type_bool_univ3 =
let univ = new_univar () in
- type_arrow (type_tuple [type_bool;univ;univ]) univ
+ type_arrow (type_tuple [ type_bool; univ; univ ]) univ
let type_access =
let d = Dimension.mkdim Location.dummy_loc Dimension.Dunivar in
let d' = Dimension.mkdim Location.dummy_loc Dimension.Dunivar in
let univ = new_univar () in
- type_arrow (type_tuple [type_array d univ; type_static d' type_int]) univ
+ type_arrow (type_tuple [ type_array d univ; type_static d' type_int ]) univ
let type_power =
let d = Dimension.mkdim Location.dummy_loc Dimension.Dunivar in
let univ = new_univar () in
- type_arrow (type_tuple [univ; type_static d type_int]) (type_array d univ)
+ type_arrow (type_tuple [ univ; type_static d type_int ]) (type_array d univ)
end
-
(* module BaseBuilder = *)
(* struct *)
(* let type_int_builder = Tbasic Basic.Tint *)
@@ -86,7 +92,7 @@ end
(* let type_bool_builder = Tbasic Basic.Tbool *)
(* let type_string_builder = Tbasic Basic.Tstring *)
(* end *)
-
+
module Main = Make (Types.Main)
include Main
diff --git a/src/types.ml b/src/types.ml
index 8313081c58dd6b9beceda2cf2954b38208422471..f95826292cedfd0b1d29426fb140dce20e19a47f 100644
--- a/src/types.ml
+++ b/src/types.ml
@@ -6,116 +6,122 @@
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)
(* under the terms of the GNU Lesser General Public License *)
(* version 2.1. *)
-(* *)
+(* *)
(* This file was originally from the Prelude compiler *)
-(* *)
+(* *)
(********************************************************************)
-(** Types definitions and a few utility functions on types. *)
open Utils
+(** Types definitions and a few utility functions on types. *)
+
open Dimension
-module type BASIC_TYPES =
-sig
+module type BASIC_TYPES = sig
type t
- val pp: Format.formatter -> t -> unit
- val pp_c: Format.formatter -> t -> unit
- val is_scalar_type: t -> bool
- val is_numeric_type: t -> bool
- val is_int_type: t -> bool
- val is_real_type: t -> bool
- val is_bool_type: t -> bool
- val is_dimension_type: t -> bool
- val type_int_builder: t
- val type_real_builder: t
- val type_bool_builder: t
- val type_string_builder: t
- val unify: t -> t -> unit
- val is_unifiable: t -> t -> bool
+
+ val pp : Format.formatter -> t -> unit
+
+ val pp_c : Format.formatter -> t -> unit
+
+ val is_scalar_type : t -> bool
+
+ val is_numeric_type : t -> bool
+
+ val is_int_type : t -> bool
+
+ val is_real_type : t -> bool
+
+ val is_bool_type : t -> bool
+
+ val is_dimension_type : t -> bool
+
+ val type_int_builder : t
+
+ val type_real_builder : t
+
+ val type_bool_builder : t
+
+ val type_string_builder : t
+
+ val unify : t -> t -> unit
+
+ val is_unifiable : t -> t -> bool
end
-module Basic =
-struct
- type t =
- | Tstring
- | Tint
- | Treal
- | Tbool
- | Trat (* Actually unused for now. Only place where it can appear is
- in a clock declaration *)
+module Basic = struct
+ type t = Tstring | Tint | Treal | Tbool | Trat
+ (* Actually unused for now. Only place where it can appear is in a clock
+ declaration *)
let type_string_builder = Tstring
+
let type_int_builder = Tint
+
let type_real_builder = Treal
+
let type_bool_builder = Tbool
open Format
+
let pp fmt t =
match t with
| Tint ->
- fprintf fmt "int"
+ fprintf fmt "int"
| Treal ->
- fprintf fmt "real"
+ fprintf fmt "real"
| Tstring ->
- fprintf fmt "string"
+ fprintf fmt "string"
| Tbool ->
- fprintf fmt "bool"
+ fprintf fmt "bool"
| Trat ->
- fprintf fmt "rat"
+ fprintf fmt "rat"
let pp_c = pp
-
- let is_scalar_type t =
- match t with
- | Tbool
- | Tint
- | Treal -> true
- | _ -> false
+ let is_scalar_type t =
+ match t with Tbool | Tint | Treal -> true | _ -> false
- let is_numeric_type t =
- match t with
- | Tint
- | Treal -> true
- | _ -> false
+ let is_numeric_type t = match t with Tint | Treal -> true | _ -> false
let is_int_type t = t = Tint
+
let is_real_type t = t = Treal
+
let is_bool_type t = t = Tbool
- let is_dimension_type t =
- match t with
- | Tint
- | Tbool -> true
- | _ -> false
+ let is_dimension_type t = match t with Tint | Tbool -> true | _ -> false
let is_unifiable b1 b2 = b1 == b2
+
let unify _ _ = ()
end
-
-
-module Make(BasicT : BASIC_TYPES) =
-struct
-
+module Make (BasicT : BASIC_TYPES) = struct
module BasicT = BasicT
+
type basic_type = BasicT.t
- type type_expr =
- {mutable tdesc: type_desc;
- tid: int}
+
+ type type_expr = { mutable tdesc : type_desc; tid : int }
+
and type_desc =
- | Tconst of ident (* type constant *)
+ | Tconst of ident
+ (* type constant *)
| Tbasic of basic_type
- | Tclock of type_expr (* A type expression explicitely tagged as carrying a clock *)
+ | Tclock of type_expr
+ (* A type expression explicitely tagged as carrying a clock *)
| Tarrow of type_expr * type_expr
| Ttuple of type_expr list
| Tenum of ident list
| Tstruct of (ident * type_expr) list
| Tarray of dim_expr * type_expr
- | Tstatic of dim_expr * type_expr (* a type carried by a dimension expression *)
- | Tlink of type_expr (* During unification, make links instead of substitutions *)
- | Tvar (* Monomorphic type variable *)
- | Tunivar (* Polymorphic type variable *)
+ | Tstatic of dim_expr * type_expr
+ (* a type carried by a dimension expression *)
+ | Tlink of type_expr
+ (* During unification, make links instead of substitutions *)
+ | Tvar
+ (* Monomorphic type variable *)
+ | Tunivar
+ (* Polymorphic type variable *)
(* {mutable tdesc: type_desc; *)
(* tid: int} *)
@@ -123,19 +129,22 @@ struct
(* and type_desc = *)
(* | Tconst of ident (\* type constant *\) *)
(* | Tbasic of BasicT.t *)
- (* | Tclock of type_expr (\* A type expression explicitely tagged as carrying a clock *\) *)
+ (* | Tclock of type_expr (\* A type expression explicitely tagged as carrying
+ a clock *\) *)
(* | Tarrow of type_expr * type_expr *)
(* | Ttuple of type_expr list *)
(* | Tenum of ident list *)
(* | Tstruct of (ident * type_expr) list *)
(* | Tarray of dim_expr * type_expr *)
- (* | Tstatic of dim_expr * type_expr (\* a type carried by a dimension expression *\) *)
- (* | Tlink of type_expr (\* During unification, make links instead of substitutions *\) *)
+ (* | Tstatic of dim_expr * type_expr (\* a type carried by a dimension
+ expression *\) *)
+ (* | Tlink of type_expr (\* During unification, make links instead of
+ substitutions *\) *)
(* | Tvar (\* Monomorphic type variable *\) *)
(* | Tunivar (\* Polymorphic type variable *\) *)
type error =
- Unbound_value of ident
+ | Unbound_value of ident
| Already_bound of ident
| Already_defined of ident
| Undefined_var of ISet.t
@@ -150,350 +159,394 @@ struct
| Type_clash of type_expr * type_expr
| Poly_imported_node of ident
-exception Unify of type_expr * type_expr
-exception Error of Location.t * error
-
-let mk_basic t = Tbasic t
-
-
-(* Pretty-print*)
-open Format
-
-let rec print_struct_ty_field pp_basic fmt (label, ty) =
- fprintf fmt "%a : %a" pp_print_string label (print_ty_param pp_basic) ty
-and print_ty_param pp_basic fmt ty =
- let print_ty = print_ty_param pp_basic in
- match ty.tdesc with
- | Tvar ->
- fprintf fmt "_%s" (name_of_type ty.tid)
- | Tbasic t -> pp_basic fmt t
- | Tclock t ->
- fprintf fmt "%a%s" print_ty t (if !Options.kind2_print then "" else " clock")
- | Tstatic (_, t) -> print_ty fmt t
- (* fprintf fmt "(%a:%a)" Dimension.pp_dimension d print_ty t *)
- | Tconst t ->
- fprintf fmt "%s" t
- | Tarrow (ty1,ty2) ->
- fprintf fmt "%a -> %a" print_ty ty1 print_ty ty2
- | Ttuple tylist ->
- fprintf fmt "(%a)"
- (Utils.fprintf_list ~sep:" * " print_ty) tylist
- | Tenum taglist ->
- fprintf fmt "enum {%a }"
- (Utils.fprintf_list ~sep:", " pp_print_string) taglist
- | Tstruct fieldlist ->
- fprintf fmt "struct {%a }"
- (Utils.fprintf_list ~sep:"; " (print_struct_ty_field pp_basic)) fieldlist
- | Tarray (e, ty) ->
- fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e
- | Tlink ty ->
- print_ty fmt ty
- | Tunivar ->
- fprintf fmt "'%s" (name_of_type ty.tid)
-
-let print_ty = print_ty_param BasicT.pp
-
-
-let rec print_node_struct_ty_field fmt (label, ty) =
- fprintf fmt "%a : %a" pp_print_string label print_node_ty ty
-and print_node_ty fmt ty =
- match ty.tdesc with
- | Tvar -> begin
- (*Format.eprintf "DEBUG:Types.print_node@.";*)
- fprintf fmt "_%s" (name_of_type ty.tid)
- end
- | Tbasic t -> BasicT.pp fmt t
- | Tclock t ->
- fprintf fmt "%a%s" print_node_ty t (if !Options.kind2_print then "" else " clock")
- | Tstatic (_, t) ->
- fprintf fmt "%a" print_node_ty t
- | Tconst t ->
- fprintf fmt "%s" t
- | Tarrow (ty1,ty2) ->
- fprintf fmt "%a -> %a" print_node_ty ty1 print_node_ty ty2
- | Ttuple tylist ->
- fprintf fmt "(%a)"
- (Utils.fprintf_list ~sep:"*" print_node_ty) tylist
- | Tenum taglist ->
- fprintf fmt "enum {%a }"
- (Utils.fprintf_list ~sep:", " pp_print_string) taglist
- | Tstruct fieldlist ->
- fprintf fmt "struct {%a }"
- (Utils.fprintf_list ~sep:"; " print_node_struct_ty_field) fieldlist
- | Tarray (e, ty) ->
- fprintf fmt "%a^%a" print_node_ty ty Dimension.pp_dimension e
- | Tlink ty ->
+ exception Unify of type_expr * type_expr
+
+ exception Error of Location.t * error
+
+ let mk_basic t = Tbasic t
+
+ (* Pretty-print*)
+ open Format
+
+ let rec print_struct_ty_field pp_basic fmt (label, ty) =
+ fprintf fmt "%a : %a" pp_print_string label (print_ty_param pp_basic) ty
+
+ and print_ty_param pp_basic fmt ty =
+ let print_ty = print_ty_param pp_basic in
+ match ty.tdesc with
+ | Tvar ->
+ fprintf fmt "_%s" (name_of_type ty.tid)
+ | Tbasic t ->
+ pp_basic fmt t
+ | Tclock t ->
+ fprintf fmt "%a%s" print_ty t
+ (if !Options.kind2_print then "" else " clock")
+ | Tstatic (_, t) ->
+ print_ty fmt t
+ (* fprintf fmt "(%a:%a)" Dimension.pp_dimension d print_ty t *)
+ | Tconst t ->
+ fprintf fmt "%s" t
+ | Tarrow (ty1, ty2) ->
+ fprintf fmt "%a -> %a" print_ty ty1 print_ty ty2
+ | Ttuple tylist ->
+ fprintf fmt "(%a)" (Utils.fprintf_list ~sep:" * " print_ty) tylist
+ | Tenum taglist ->
+ fprintf fmt "enum {%a }"
+ (Utils.fprintf_list ~sep:", " pp_print_string)
+ taglist
+ | Tstruct fieldlist ->
+ fprintf fmt "struct {%a }"
+ (Utils.fprintf_list ~sep:"; " (print_struct_ty_field pp_basic))
+ fieldlist
+ | Tarray (e, ty) ->
+ fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e
+ | Tlink ty ->
+ print_ty fmt ty
+ | Tunivar ->
+ fprintf fmt "'%s" (name_of_type ty.tid)
+
+ let print_ty = print_ty_param BasicT.pp
+
+ let rec print_node_struct_ty_field fmt (label, ty) =
+ fprintf fmt "%a : %a" pp_print_string label print_node_ty ty
+
+ and print_node_ty fmt ty =
+ match ty.tdesc with
+ | Tvar ->
+ (*Format.eprintf "DEBUG:Types.print_node@.";*)
+ fprintf fmt "_%s" (name_of_type ty.tid)
+ | Tbasic t ->
+ BasicT.pp fmt t
+ | Tclock t ->
+ fprintf fmt "%a%s" print_node_ty t
+ (if !Options.kind2_print then "" else " clock")
+ | Tstatic (_, t) ->
+ fprintf fmt "%a" print_node_ty t
+ | Tconst t ->
+ fprintf fmt "%s" t
+ | Tarrow (ty1, ty2) ->
+ fprintf fmt "%a -> %a" print_node_ty ty1 print_node_ty ty2
+ | Ttuple tylist ->
+ fprintf fmt "(%a)" (Utils.fprintf_list ~sep:"*" print_node_ty) tylist
+ | Tenum taglist ->
+ fprintf fmt "enum {%a }"
+ (Utils.fprintf_list ~sep:", " pp_print_string)
+ taglist
+ | Tstruct fieldlist ->
+ fprintf fmt "struct {%a }"
+ (Utils.fprintf_list ~sep:"; " print_node_struct_ty_field)
+ fieldlist
+ | Tarray (e, ty) ->
+ fprintf fmt "%a^%a" print_node_ty ty Dimension.pp_dimension e
+ | Tlink ty ->
print_node_ty fmt ty
- | Tunivar ->
- fprintf fmt "'%s" (name_of_type ty.tid)
-
-let pp_error fmt = function
- | Unbound_value id ->
- fprintf fmt "Unknown value %s@." id
- | Unbound_type id ->
- fprintf fmt "Unknown type %s@." id
- | Already_bound id ->
- fprintf fmt "%s is already declared@." id
- | Already_defined id ->
- fprintf fmt "Multiple definitions of variable %s@." id
- | Not_a_constant ->
- fprintf fmt "This expression is not a constant@."
- | Assigned_constant id ->
- fprintf fmt "The constant %s cannot be assigned@." id
- | Not_a_dimension ->
- fprintf fmt "This expression is not a valid dimension@."
- | WrongArity (ar1, ar2) ->
- fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2
- | WrongMorphism (ar1, ar2) ->
- fprintf fmt "Expecting %d argument(s) for homomorphic extension, found %d@." ar1 ar2
- | Type_mismatch id ->
- fprintf fmt "Definition and declaration of type %s don't agree@." id
- | Undefined_var vset ->
- fprintf fmt "No definition provided for variable(s): %a@."
- (Utils.fprintf_list ~sep:"," pp_print_string)
- (ISet.elements vset)
- | Declared_but_undefined id ->
- fprintf fmt "%s is declared but not defined@." id
- | Type_clash (ty1,ty2) ->
+ | Tunivar ->
+ fprintf fmt "'%s" (name_of_type ty.tid)
+
+ let pp_error fmt = function
+ | Unbound_value id ->
+ fprintf fmt "Unknown value %s@." id
+ | Unbound_type id ->
+ fprintf fmt "Unknown type %s@." id
+ | Already_bound id ->
+ fprintf fmt "%s is already declared@." id
+ | Already_defined id ->
+ fprintf fmt "Multiple definitions of variable %s@." id
+ | Not_a_constant ->
+ fprintf fmt "This expression is not a constant@."
+ | Assigned_constant id ->
+ fprintf fmt "The constant %s cannot be assigned@." id
+ | Not_a_dimension ->
+ fprintf fmt "This expression is not a valid dimension@."
+ | WrongArity (ar1, ar2) ->
+ fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2
+ | WrongMorphism (ar1, ar2) ->
+ fprintf fmt
+ "Expecting %d argument(s) for homomorphic extension, found %d@." ar1 ar2
+ | Type_mismatch id ->
+ fprintf fmt "Definition and declaration of type %s don't agree@." id
+ | Undefined_var vset ->
+ fprintf fmt "No definition provided for variable(s): %a@."
+ (Utils.fprintf_list ~sep:"," pp_print_string)
+ (ISet.elements vset)
+ | Declared_but_undefined id ->
+ fprintf fmt "%s is declared but not defined@." id
+ | Type_clash (ty1, ty2) ->
Utils.reset_names ();
- fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2
- | Poly_imported_node _ ->
- fprintf fmt "Imported nodes cannot have a polymorphic type@."
-
-
-let new_id = ref (-1)
-
-let rec bottom =
- { tdesc = Tlink bottom; tid = -666 }
-
-let new_ty desc =
- incr new_id; {tdesc = desc; tid = !new_id }
-
-let new_var () =
- new_ty Tvar
-
-let new_univar () =
- new_ty Tunivar
-
-let rec repr =
- function
- {tdesc = Tlink t'; _} ->
- repr t'
- | t -> t
-
-let get_static_value ty =
- match (repr ty).tdesc with
- | Tstatic (d, _) -> Some d
- | _ -> None
-
-let get_field_type ty label =
- match (repr ty).tdesc with
- | Tstruct fl -> (try Some (List.assoc label fl) with Not_found -> None)
- | _ -> None
-
-let is_static_type ty =
- match (repr ty).tdesc with
- | Tstatic _ -> true
- | _ -> false
-
-let rec is_scalar_type ty =
- match (repr ty).tdesc with
- | Tstatic (_, ty) -> is_scalar_type ty
- | Tbasic t -> BasicT.is_scalar_type t
- | _ -> false
-
-let rec is_numeric_type ty =
- match (repr ty).tdesc with
- | Tstatic (_, ty) -> is_numeric_type ty
- | Tbasic t -> BasicT.is_numeric_type t
- | _ -> false
-
-let rec is_real_type ty =
- match (repr ty).tdesc with
- | Tstatic (_, ty) -> is_real_type ty
- | Tbasic t -> BasicT.is_real_type t
- | _ -> false
-
-let rec is_int_type ty =
- match (repr ty).tdesc with
- | Tstatic (_, ty) -> is_int_type ty
- | Tbasic t -> BasicT.is_int_type t
- | _ -> false
-
-let rec is_bool_type ty =
- match (repr ty).tdesc with
- | Tstatic (_, ty) -> is_bool_type ty
- | Tbasic t -> BasicT.is_bool_type t
- | _ -> false
-
-let rec is_const_type ty c =
- match (repr ty).tdesc with
- | Tstatic (_, ty) -> is_const_type ty c
- | Tconst c' -> c = c'
- | _ -> false
-
-let get_clock_base_type ty =
- match (repr ty).tdesc with
- | Tclock ty -> Some ty
- | _ -> None
-
-let unclock_type ty =
- let ty = repr ty in
- match ty.tdesc with
- | Tclock ty' -> ty'
- | _ -> ty
-
-let rec is_dimension_type ty =
- match (repr ty).tdesc with
- | Tbasic t -> BasicT.is_dimension_type t
- | Tclock ty'
- | Tstatic (_, ty') -> is_dimension_type ty'
- | _ -> false
-
-let dynamic_type ty =
- let ty = repr ty in
- match ty.tdesc with
- | Tstatic (_, ty') -> ty'
- | _ -> ty
-
-let is_tuple_type ty =
- match (repr ty).tdesc with
- | Ttuple _ -> true
- | _ -> false
-
-let map_tuple_type f ty =
- let ty = dynamic_type ty in
- match ty.tdesc with
- | (Ttuple ty_list) -> { ty with tdesc = Ttuple (List.map f ty_list) }
- | _ -> f ty
-
-let rec is_struct_type ty =
- match (repr ty).tdesc with
- | Tstruct _ -> true
- | Tstatic (_, ty') -> is_struct_type ty'
- | _ -> false
-
-let struct_field_type ty field =
- match (dynamic_type ty).tdesc with
- | Tstruct fields ->
- (try
- List.assoc field fields
- with Not_found -> assert false)
- | _ -> assert false
-
-let rec is_array_type ty =
- match (repr ty).tdesc with
- | Tarray _ -> true
- | Tstatic (_, ty') -> is_array_type ty' (* looks strange !? *)
- | _ -> false
-
-let array_type_dimension ty =
- match (dynamic_type ty).tdesc with
- | Tarray (d, _) -> d
- | _ -> (Format.eprintf "internal error: Types.array_type_dimension %a@." print_ty ty; assert false)
-
-let rec array_type_multi_dimension ty =
- match (dynamic_type ty).tdesc with
- | Tarray (d, ty') -> d :: array_type_multi_dimension ty'
- | _ -> []
-
-let array_element_type ty =
- match (dynamic_type ty).tdesc with
- | Tarray (_, ty') -> ty'
- | _ -> (Format.eprintf "internal error: Types.array_element_type %a@." print_ty ty; assert false)
-
-let rec array_base_type ty =
- let ty = repr ty in
- match ty.tdesc with
- | Tarray (_, ty')
- | Tstatic (_, ty') -> array_base_type ty'
- | _ -> ty
-
-let is_address_type ty =
- is_array_type ty || is_struct_type ty || (is_real_type ty && !Options.mpfr)
-
-let rec is_generic_type ty =
- match (dynamic_type ty).tdesc with
- | Tarray (d, ty') ->
- (not (Dimension.is_dimension_const d)) || (is_generic_type ty')
- | _ -> false
-
-(** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type
- (ensured by language syntax) *)
-let rec split_arrow ty =
- match (repr ty).tdesc with
- | Tarrow (tin,tout) -> tin,tout
- | Tstatic (_, ty') -> split_arrow ty'
- (* Functions are not first order, I don't think the var case
- needs to be considered here *)
- | _ -> Format.eprintf "type %a is not a map@.Unable to split@.@?" print_ty ty; assert false
-
-(** Returns the type corresponding to a type list. *)
-let type_of_type_list tyl =
- if (List.length tyl) > 1 then
- new_ty (Ttuple tyl)
- else
- List.hd tyl
-
-let rec type_list_of_type ty =
- match (repr ty).tdesc with
- | Tstatic (_, ty) -> type_list_of_type ty
- | Ttuple tl -> tl
- | _ -> [ty]
-
-(** [is_polymorphic ty] returns true if [ty] is polymorphic. *)
-let rec is_polymorphic ty =
- match ty.tdesc with
- | Tenum _ | Tvar | Tbasic _ | Tconst _ -> false
- | Tclock ty -> is_polymorphic ty
- | Tarrow (ty1,ty2) -> (is_polymorphic ty1) || (is_polymorphic ty2)
- | Ttuple tl -> List.exists (fun t -> is_polymorphic t) tl
- | Tstruct fl -> List.exists (fun (_, t) -> is_polymorphic t) fl
- | Tlink t' -> is_polymorphic t'
- | Tarray (d, ty)
- | Tstatic (d, ty) -> Dimension.is_polymorphic d || is_polymorphic ty
- | Tunivar -> true
-
-
-let mktyptuple nb typ =
- let array = Array.make nb typ in
- Ttuple (Array.to_list array)
-
-let type_desc t = t.tdesc
-
-
-
-let type_int = mk_basic BasicT.type_int_builder
-let type_real = mk_basic BasicT.type_real_builder
-let type_bool = mk_basic BasicT.type_bool_builder
-let type_string = mk_basic BasicT.type_string_builder
-
+ fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2
+ | Poly_imported_node _ ->
+ fprintf fmt "Imported nodes cannot have a polymorphic type@."
+
+ let new_id = ref (-1)
+
+ let rec bottom = { tdesc = Tlink bottom; tid = -666 }
+
+ let new_ty desc =
+ incr new_id;
+ { tdesc = desc; tid = !new_id }
+
+ let new_var () = new_ty Tvar
+
+ let new_univar () = new_ty Tunivar
+
+ let rec repr = function { tdesc = Tlink t'; _ } -> repr t' | t -> t
+
+ let get_static_value ty =
+ match (repr ty).tdesc with Tstatic (d, _) -> Some d | _ -> None
+
+ let get_field_type ty label =
+ match (repr ty).tdesc with
+ | Tstruct fl -> (
+ try Some (List.assoc label fl) with Not_found -> None)
+ | _ ->
+ None
+
+ let is_static_type ty =
+ match (repr ty).tdesc with Tstatic _ -> true | _ -> false
+
+ let rec is_scalar_type ty =
+ match (repr ty).tdesc with
+ | Tstatic (_, ty) ->
+ is_scalar_type ty
+ | Tbasic t ->
+ BasicT.is_scalar_type t
+ | _ ->
+ false
+
+ let rec is_numeric_type ty =
+ match (repr ty).tdesc with
+ | Tstatic (_, ty) ->
+ is_numeric_type ty
+ | Tbasic t ->
+ BasicT.is_numeric_type t
+ | _ ->
+ false
+
+ let rec is_real_type ty =
+ match (repr ty).tdesc with
+ | Tstatic (_, ty) ->
+ is_real_type ty
+ | Tbasic t ->
+ BasicT.is_real_type t
+ | _ ->
+ false
+
+ let rec is_int_type ty =
+ match (repr ty).tdesc with
+ | Tstatic (_, ty) ->
+ is_int_type ty
+ | Tbasic t ->
+ BasicT.is_int_type t
+ | _ ->
+ false
+
+ let rec is_bool_type ty =
+ match (repr ty).tdesc with
+ | Tstatic (_, ty) ->
+ is_bool_type ty
+ | Tbasic t ->
+ BasicT.is_bool_type t
+ | _ ->
+ false
+
+ let rec is_const_type ty c =
+ match (repr ty).tdesc with
+ | Tstatic (_, ty) ->
+ is_const_type ty c
+ | Tconst c' ->
+ c = c'
+ | _ ->
+ false
+
+ let get_clock_base_type ty =
+ match (repr ty).tdesc with Tclock ty -> Some ty | _ -> None
+
+ let unclock_type ty =
+ let ty = repr ty in
+ match ty.tdesc with Tclock ty' -> ty' | _ -> ty
+
+ let rec is_dimension_type ty =
+ match (repr ty).tdesc with
+ | Tbasic t ->
+ BasicT.is_dimension_type t
+ | Tclock ty' | Tstatic (_, ty') ->
+ is_dimension_type ty'
+ | _ ->
+ false
+
+ let dynamic_type ty =
+ let ty = repr ty in
+ match ty.tdesc with Tstatic (_, ty') -> ty' | _ -> ty
+
+ let is_tuple_type ty =
+ match (repr ty).tdesc with Ttuple _ -> true | _ -> false
+
+ let map_tuple_type f ty =
+ let ty = dynamic_type ty in
+ match ty.tdesc with
+ | Ttuple ty_list ->
+ { ty with tdesc = Ttuple (List.map f ty_list) }
+ | _ ->
+ f ty
+
+ let rec is_struct_type ty =
+ match (repr ty).tdesc with
+ | Tstruct _ ->
+ true
+ | Tstatic (_, ty') ->
+ is_struct_type ty'
+ | _ ->
+ false
+
+ let struct_field_type ty field =
+ match (dynamic_type ty).tdesc with
+ | Tstruct fields -> (
+ try List.assoc field fields with Not_found -> assert false)
+ | _ ->
+ assert false
+
+ let rec is_array_type ty =
+ match (repr ty).tdesc with
+ | Tarray _ ->
+ true
+ | Tstatic (_, ty') ->
+ is_array_type ty' (* looks strange !? *)
+ | _ ->
+ false
+
+ let array_type_dimension ty =
+ match (dynamic_type ty).tdesc with
+ | Tarray (d, _) ->
+ d
+ | _ ->
+ Format.eprintf "internal error: Types.array_type_dimension %a@." print_ty
+ ty;
+ assert false
+
+ let rec array_type_multi_dimension ty =
+ match (dynamic_type ty).tdesc with
+ | Tarray (d, ty') ->
+ d :: array_type_multi_dimension ty'
+ | _ ->
+ []
+
+ let array_element_type ty =
+ match (dynamic_type ty).tdesc with
+ | Tarray (_, ty') ->
+ ty'
+ | _ ->
+ Format.eprintf "internal error: Types.array_element_type %a@." print_ty ty;
+ assert false
+
+ let rec array_base_type ty =
+ let ty = repr ty in
+ match ty.tdesc with
+ | Tarray (_, ty') | Tstatic (_, ty') ->
+ array_base_type ty'
+ | _ ->
+ ty
+
+ let is_address_type ty =
+ is_array_type ty || is_struct_type ty || (is_real_type ty && !Options.mpfr)
+
+ let rec is_generic_type ty =
+ match (dynamic_type ty).tdesc with
+ | Tarray (d, ty') ->
+ (not (Dimension.is_dimension_const d)) || is_generic_type ty'
+ | _ ->
+ false
+
+ (** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type
+ (ensured by language syntax) *)
+ let rec split_arrow ty =
+ match (repr ty).tdesc with
+ | Tarrow (tin, tout) ->
+ tin, tout
+ | Tstatic (_, ty') ->
+ split_arrow ty'
+ (* Functions are not first order, I don't think the var case needs to be
+ considered here *)
+ | _ ->
+ Format.eprintf "type %a is not a map@.Unable to split@.@?" print_ty ty;
+ assert false
+
+ (** Returns the type corresponding to a type list. *)
+ let type_of_type_list tyl =
+ if List.length tyl > 1 then new_ty (Ttuple tyl) else List.hd tyl
+
+ let rec type_list_of_type ty =
+ match (repr ty).tdesc with
+ | Tstatic (_, ty) ->
+ type_list_of_type ty
+ | Ttuple tl ->
+ tl
+ | _ ->
+ [ ty ]
+
+ (** [is_polymorphic ty] returns true if [ty] is polymorphic. *)
+ let rec is_polymorphic ty =
+ match ty.tdesc with
+ | Tenum _ | Tvar | Tbasic _ | Tconst _ ->
+ false
+ | Tclock ty ->
+ is_polymorphic ty
+ | Tarrow (ty1, ty2) ->
+ is_polymorphic ty1 || is_polymorphic ty2
+ | Ttuple tl ->
+ List.exists (fun t -> is_polymorphic t) tl
+ | Tstruct fl ->
+ List.exists (fun (_, t) -> is_polymorphic t) fl
+ | Tlink t' ->
+ is_polymorphic t'
+ | Tarray (d, ty) | Tstatic (d, ty) ->
+ Dimension.is_polymorphic d || is_polymorphic ty
+ | Tunivar ->
+ true
+
+ let mktyptuple nb typ =
+ let array = Array.make nb typ in
+ Ttuple (Array.to_list array)
+
+ let type_desc t = t.tdesc
+
+ let type_int = mk_basic BasicT.type_int_builder
+
+ let type_real = mk_basic BasicT.type_real_builder
+
+ let type_bool = mk_basic BasicT.type_bool_builder
+
+ let type_string = mk_basic BasicT.type_string_builder
end
+module type S = sig
+ module BasicT : BASIC_TYPES
-module type S =
-sig
- module BasicT: BASIC_TYPES
type basic_type = BasicT.t
- type type_expr =
- {mutable tdesc: type_desc;
- tid: int}
+
+ type type_expr = { mutable tdesc : type_desc; tid : int }
+
and type_desc =
- | Tconst of ident (* type constant *)
+ | Tconst of ident
+ (* type constant *)
| Tbasic of basic_type
- | Tclock of type_expr (* A type expression explicitely tagged as carrying a clock *)
+ | Tclock of type_expr
+ (* A type expression explicitely tagged as carrying a clock *)
| Tarrow of type_expr * type_expr
| Ttuple of type_expr list
| Tenum of ident list
| Tstruct of (ident * type_expr) list
| Tarray of dim_expr * type_expr
- | Tstatic of dim_expr * type_expr (* a type carried by a dimension expression *)
- | Tlink of type_expr (* During unification, make links instead of substitutions *)
- | Tvar (* Monomorphic type variable *)
- | Tunivar (* Polymorphic type variable *)
+ | Tstatic of dim_expr * type_expr
+ (* a type carried by a dimension expression *)
+ | Tlink of type_expr
+ (* During unification, make links instead of substitutions *)
+ | Tvar
+ (* Monomorphic type variable *)
+ | Tunivar
+ (* Polymorphic type variable *)
type error =
- Unbound_value of ident
+ | Unbound_value of ident
| Already_bound of ident
| Already_defined of ident
| Undefined_var of ISet.t
@@ -508,52 +561,89 @@ sig
| Type_clash of type_expr * type_expr
| Poly_imported_node of ident
- exception Unify of type_expr * type_expr
- exception Error of Location.t * error
-
- val is_real_type: type_expr -> bool
- val is_int_type: type_expr -> bool
- val is_bool_type: type_expr -> bool
- val is_const_type: type_expr -> ident -> bool
- val is_static_type: type_expr -> bool
- val is_array_type: type_expr -> bool
- val is_dimension_type: type_expr -> bool
- val is_address_type: type_expr -> bool
- val is_generic_type: type_expr -> bool
- val print_ty: Format.formatter -> type_expr -> unit
- val repr: type_expr -> type_expr
- val dynamic_type: type_expr -> type_expr
- val type_desc: type_expr -> type_desc
- val new_var: unit -> type_expr
- val new_univar: unit -> type_expr
- val new_ty: type_desc -> type_expr
- val type_int: type_desc
- val type_real: type_desc
- val type_bool: type_desc
- val type_string: type_desc
- val array_element_type: type_expr -> type_expr
- val type_list_of_type: type_expr -> type_expr list
- val print_node_ty: Format.formatter -> type_expr -> unit
- val get_clock_base_type: type_expr -> type_expr option
- val get_static_value: type_expr -> Dimension.dim_expr option
- val is_tuple_type: type_expr -> bool
- val type_of_type_list: type_expr list -> type_expr
- val split_arrow: type_expr -> type_expr * type_expr
- val unclock_type: type_expr -> type_expr
- val bottom: type_expr
- val map_tuple_type: (type_expr -> type_expr) -> type_expr -> type_expr
- val array_base_type: type_expr -> type_expr
- val array_type_dimension: type_expr -> Dimension.dim_expr
- val pp_error: Format.formatter -> error -> unit
- val struct_field_type: type_expr -> ident -> type_expr
- val array_type_multi_dimension: type_expr -> Dimension.dim_expr list
-end (* with type type_expr = BasicT.t type_expr_gen *)
-
-module type Sbasic = S with type BasicT.t = Basic.t
-
+ exception Unify of type_expr * type_expr
+
+ exception Error of Location.t * error
+
+ val is_real_type : type_expr -> bool
+
+ val is_int_type : type_expr -> bool
+
+ val is_bool_type : type_expr -> bool
+
+ val is_const_type : type_expr -> ident -> bool
+
+ val is_static_type : type_expr -> bool
+
+ val is_array_type : type_expr -> bool
+
+ val is_dimension_type : type_expr -> bool
+
+ val is_address_type : type_expr -> bool
+
+ val is_generic_type : type_expr -> bool
+
+ val print_ty : Format.formatter -> type_expr -> unit
+
+ val repr : type_expr -> type_expr
+
+ val dynamic_type : type_expr -> type_expr
+
+ val type_desc : type_expr -> type_desc
+
+ val new_var : unit -> type_expr
+
+ val new_univar : unit -> type_expr
+
+ val new_ty : type_desc -> type_expr
+
+ val type_int : type_desc
+
+ val type_real : type_desc
+
+ val type_bool : type_desc
+
+ val type_string : type_desc
+
+ val array_element_type : type_expr -> type_expr
+
+ val type_list_of_type : type_expr -> type_expr list
+
+ val print_node_ty : Format.formatter -> type_expr -> unit
+
+ val get_clock_base_type : type_expr -> type_expr option
+
+ val get_static_value : type_expr -> Dimension.dim_expr option
+
+ val is_tuple_type : type_expr -> bool
+
+ val type_of_type_list : type_expr list -> type_expr
+
+ val split_arrow : type_expr -> type_expr * type_expr
+
+ val unclock_type : type_expr -> type_expr
+
+ val bottom : type_expr
+
+ val map_tuple_type : (type_expr -> type_expr) -> type_expr -> type_expr
+
+ val array_base_type : type_expr -> type_expr
+
+ val array_type_dimension : type_expr -> Dimension.dim_expr
+
+ val pp_error : Format.formatter -> error -> unit
+
+ val struct_field_type : type_expr -> ident -> type_expr
+
+ val array_type_multi_dimension : type_expr -> Dimension.dim_expr list
+end
+(* with type type_expr = BasicT.t type_expr_gen *)
+
+module type Sbasic = S with type BasicT.t = Basic.t
+
module Main : Sbasic = Make (Basic)
-include Main
+include Main
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/typing.ml b/src/typing.ml
index 1e5ea9a1bd18e2b18e1e3eacc38eed4162c64a33..b69b2b8f90a42ecc8d9c56aba4cb3b121ffa6e5d 100644
--- a/src/typing.ml
+++ b/src/typing.ml
@@ -6,930 +6,1117 @@
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)
(* under the terms of the GNU Lesser General Public License *)
(* version 2.1. *)
-(* *)
+(* *)
(* This file was originally from the Prelude compiler *)
-(* *)
+(* *)
(********************************************************************)
(** Main typing module. Classic inference algorithm with destructive
unification. *)
-let debug _fmt _args = () (* Format.eprintf "%a" *)
-(* Though it shares similarities with the clock calculus module, no code
- is shared. Simple environments, very limited identifier scoping, no
- identifier redefinition allowed. *)
+let debug _fmt _args = ()
+
+(* Format.eprintf "%a" *)
+(* Though it shares similarities with the clock calculus module, no code is
+ shared. Simple environments, very limited identifier scoping, no identifier
+ redefinition allowed. *)
open Utils
-(* Yes, opening both modules is dirty as some type names will be
- overwritten, yet this makes notations far lighter.*)
+
+(* Yes, opening both modules is dirty as some type names will be overwritten,
+ yet this makes notations far lighter.*)
open Lustre_types
open Corelang
+(* TODO general remark: except in the add_vdecl, it seems to me that all the
+ pairs (env, vd_env) should be replace with just env, since vd_env is never
+ used and the env element is always extract with a fst *)
+
+module type EXPR_TYPE_HUB = sig
+ type type_expr
-(* TODO general remark: except in the add_vdecl, it seems to me that
- all the pairs (env, vd_env) should be replace with just env, since
- vd_env is never used and the env element is always extract with a
- fst *)
+ val import : Types.Main.type_expr -> type_expr
-
-module type EXPR_TYPE_HUB =
-sig
- type type_expr
- val import: Types.Main.type_expr -> type_expr
- val export: type_expr -> Types.Main.type_expr
+ val export : type_expr -> Types.Main.type_expr
end
-module Make (T: Types.S) (Expr_type_hub: EXPR_TYPE_HUB with type type_expr = T.type_expr) =
- struct
-
- module TP = Type_predef.Make (T)
- include TP
-
- let pp_typing_env fmt env =
- Env.pp_env print_ty fmt env
-
- (****************************************************************)
- (* Generic functions: occurs, instantiate and generalize *)
- (****************************************************************)
-
- (** [occurs tvar ty] returns true if the type variable [tvar]
- occurs in type [ty]. False otherwise. *)
- let rec occurs tvar ty =
- let ty = repr ty in
- match type_desc ty with
- | Tvar -> ty=tvar
- | Tarrow (t1, t2) ->
- (occurs tvar t1) || (occurs tvar t2)
- | Ttuple tl ->
- List.exists (occurs tvar) tl
- | Tstruct fl ->
- List.exists (fun (_, t) -> occurs tvar t) fl
- | Tarray (_, t)
- | Tstatic (_, t)
- | Tclock t
- | Tlink t -> occurs tvar t
- | Tenum _ | Tconst _ | Tunivar | Tbasic _ -> false
-
- (** Promote monomorphic type variables to polymorphic type
- variables. *)
- (* Generalize by side-effects *)
- let rec generalize ty =
- match type_desc ty with
- | Tvar ->
- (* No scopes, always generalize *)
- ty.tdesc <- Tunivar
- | Tarrow (t1,t2) ->
- generalize t1; generalize t2
- | Ttuple tl ->
- List.iter generalize tl
- | Tstruct fl ->
- List.iter (fun (_, t) -> generalize t) fl
- | Tstatic (d, t)
- | Tarray (d, t) -> Dimension.generalize d; generalize t
- | Tclock t
- | Tlink t ->
- generalize t
- | Tenum _ | Tconst _ | Tunivar | Tbasic _ -> ()
-
- (** Downgrade polymorphic type variables to monomorphic type
- variables *)
- let rec instantiate inst_vars inst_dim_vars ty =
- let ty = repr ty in
- match ty.tdesc with
- | Tenum _ | Tconst _ | Tvar | Tbasic _ -> ty
- | Tarrow (t1,t2) ->
- {ty with tdesc =
- Tarrow ((instantiate inst_vars inst_dim_vars t1), (instantiate inst_vars inst_dim_vars t2))}
- | Ttuple tlist ->
- {ty with tdesc = Ttuple (List.map (instantiate inst_vars inst_dim_vars) tlist)}
- | Tstruct flist ->
- {ty with tdesc = Tstruct (List.map (fun (f, t) -> (f, instantiate inst_vars inst_dim_vars t)) flist)}
- | Tclock t ->
- {ty with tdesc = Tclock (instantiate inst_vars inst_dim_vars t)}
- | Tstatic (d, t) ->
- {ty with tdesc = Tstatic (Dimension.instantiate inst_dim_vars d, instantiate inst_vars inst_dim_vars t)}
- | Tarray (d, t) ->
- {ty with tdesc = Tarray (Dimension.instantiate inst_dim_vars d, instantiate inst_vars inst_dim_vars t)}
- | Tlink t ->
- (* should not happen *)
- {ty with tdesc = Tlink (instantiate inst_vars inst_dim_vars t)}
- | Tunivar ->
- try
- List.assoc ty.tid !inst_vars
- with Not_found ->
- let var = new_var () in
- inst_vars := (ty.tid, var)::!inst_vars;
- var
-
-
-
- let basic_coretype_type t =
- if is_real_type t then Tydec_real else
- if is_int_type t then Tydec_int else
- if is_bool_type t then Tydec_bool else
- assert false
-
- (* [type_coretype cty] types the type declaration [cty] *)
- let rec type_coretype type_dim cty =
- match (*get_repr_type*) cty with
- | Tydec_any -> new_var ()
- | Tydec_int -> type_int
- | Tydec_real -> (* Type_predef. *)type_real
- (* | Tydec_float -> Type_predef.type_real *)
- | Tydec_bool -> (* Type_predef. *)type_bool
- | Tydec_clock ty -> (* Type_predef. *)type_clock (type_coretype type_dim ty)
- | Tydec_const c -> (* Type_predef. *)type_const c
- | Tydec_enum tl -> (* Type_predef. *)type_enum tl
- | Tydec_struct fl -> (* Type_predef. *)type_struct (List.map (fun (f, ty) -> (f, type_coretype type_dim ty)) fl)
- | Tydec_array (d, ty) ->
- begin
- let d = Dimension.copy (ref []) d in
- type_dim d;
- (* Type_predef. *)type_array d (type_coretype type_dim ty)
- end
-
- (* [coretype_type] is the reciprocal of [type_typecore] *)
- let rec coretype_type ty =
- match (repr ty).tdesc with
- | Tvar -> Tydec_any
- | Tbasic _ -> basic_coretype_type ty
- | Tconst c -> Tydec_const c
- | Tclock t -> Tydec_clock (coretype_type t)
- | Tenum tl -> Tydec_enum tl
- | Tstruct fl -> Tydec_struct (List.map (fun (f, t) -> (f, coretype_type t)) fl)
- | Tarray (d, t) -> Tydec_array (d, coretype_type t)
- | Tstatic (_, t) -> coretype_type t
- | _ -> assert false
-
- let get_coretype_definition tname =
- try
- let top = Hashtbl.find type_table (Tydec_const tname) in
- match top.top_decl_desc with
- | TypeDef tdef -> tdef.tydef_desc
- | _ -> assert false
- with Not_found -> raise (Error (Location.dummy_loc, Unbound_type tname))
-
- let get_type_definition tname =
- type_coretype (fun _ -> ()) (get_coretype_definition tname)
-
- (* Equality on ground types only *)
- (* Should be used between local variables which must have a ground type *)
- let rec eq_ground t1 t2 =
+module Make
+ (T : Types.S)
+ (Expr_type_hub : EXPR_TYPE_HUB with type type_expr = T.type_expr) =
+struct
+ module TP = Type_predef.Make (T)
+ include TP
+
+ let pp_typing_env fmt env = Env.pp_env print_ty fmt env
+
+ (****************************************************************)
+ (* Generic functions: occurs, instantiate and generalize *)
+ (****************************************************************)
+
+ (** [occurs tvar ty] returns true if the type variable [tvar] occurs in type
+ [ty]. False otherwise. *)
+ let rec occurs tvar ty =
+ let ty = repr ty in
+ match type_desc ty with
+ | Tvar ->
+ ty = tvar
+ | Tarrow (t1, t2) ->
+ occurs tvar t1 || occurs tvar t2
+ | Ttuple tl ->
+ List.exists (occurs tvar) tl
+ | Tstruct fl ->
+ List.exists (fun (_, t) -> occurs tvar t) fl
+ | Tarray (_, t) | Tstatic (_, t) | Tclock t | Tlink t ->
+ occurs tvar t
+ | Tenum _ | Tconst _ | Tunivar | Tbasic _ ->
+ false
+
+ (* Generalize by side-effects *)
+
+ (** Promote monomorphic type variables to polymorphic type variables. *)
+ let rec generalize ty =
+ match type_desc ty with
+ | Tvar ->
+ (* No scopes, always generalize *)
+ ty.tdesc <- Tunivar
+ | Tarrow (t1, t2) ->
+ generalize t1;
+ generalize t2
+ | Ttuple tl ->
+ List.iter generalize tl
+ | Tstruct fl ->
+ List.iter (fun (_, t) -> generalize t) fl
+ | Tstatic (d, t) | Tarray (d, t) ->
+ Dimension.generalize d;
+ generalize t
+ | Tclock t | Tlink t ->
+ generalize t
+ | Tenum _ | Tconst _ | Tunivar | Tbasic _ ->
+ ()
+
+ (** Downgrade polymorphic type variables to monomorphic type variables *)
+ let rec instantiate inst_vars inst_dim_vars ty =
+ let ty = repr ty in
+ match ty.tdesc with
+ | Tenum _ | Tconst _ | Tvar | Tbasic _ ->
+ ty
+ | Tarrow (t1, t2) ->
+ {
+ ty with
+ tdesc =
+ Tarrow
+ ( instantiate inst_vars inst_dim_vars t1,
+ instantiate inst_vars inst_dim_vars t2 );
+ }
+ | Ttuple tlist ->
+ {
+ ty with
+ tdesc = Ttuple (List.map (instantiate inst_vars inst_dim_vars) tlist);
+ }
+ | Tstruct flist ->
+ {
+ ty with
+ tdesc =
+ Tstruct
+ (List.map
+ (fun (f, t) -> f, instantiate inst_vars inst_dim_vars t)
+ flist);
+ }
+ | Tclock t ->
+ { ty with tdesc = Tclock (instantiate inst_vars inst_dim_vars t) }
+ | Tstatic (d, t) ->
+ {
+ ty with
+ tdesc =
+ Tstatic
+ ( Dimension.instantiate inst_dim_vars d,
+ instantiate inst_vars inst_dim_vars t );
+ }
+ | Tarray (d, t) ->
+ {
+ ty with
+ tdesc =
+ Tarray
+ ( Dimension.instantiate inst_dim_vars d,
+ instantiate inst_vars inst_dim_vars t );
+ }
+ | Tlink t ->
+ (* should not happen *)
+ { ty with tdesc = Tlink (instantiate inst_vars inst_dim_vars t) }
+ | Tunivar -> (
+ try List.assoc ty.tid !inst_vars
+ with Not_found ->
+ let var = new_var () in
+ inst_vars := (ty.tid, var) :: !inst_vars;
+ var)
+
+ let basic_coretype_type t =
+ if is_real_type t then Tydec_real
+ else if is_int_type t then Tydec_int
+ else if is_bool_type t then Tydec_bool
+ else assert false
+
+ (* [type_coretype cty] types the type declaration [cty] *)
+ let rec type_coretype type_dim cty =
+ match (*get_repr_type*)
+ cty with
+ | Tydec_any ->
+ new_var ()
+ | Tydec_int ->
+ type_int
+ | Tydec_real ->
+ (* Type_predef. *)
+ type_real
+ (* | Tydec_float -> Type_predef.type_real *)
+ | Tydec_bool ->
+ (* Type_predef. *)
+ type_bool
+ | Tydec_clock ty ->
+ (* Type_predef. *)
+ type_clock (type_coretype type_dim ty)
+ | Tydec_const c ->
+ (* Type_predef. *)
+ type_const c
+ | Tydec_enum tl ->
+ (* Type_predef. *)
+ type_enum tl
+ | Tydec_struct fl ->
+ (* Type_predef. *)
+ type_struct (List.map (fun (f, ty) -> f, type_coretype type_dim ty) fl)
+ | Tydec_array (d, ty) ->
+ let d = Dimension.copy (ref []) d in
+ type_dim d;
+ (* Type_predef. *)
+ type_array d (type_coretype type_dim ty)
+
+ (* [coretype_type] is the reciprocal of [type_typecore] *)
+ let rec coretype_type ty =
+ match (repr ty).tdesc with
+ | Tvar ->
+ Tydec_any
+ | Tbasic _ ->
+ basic_coretype_type ty
+ | Tconst c ->
+ Tydec_const c
+ | Tclock t ->
+ Tydec_clock (coretype_type t)
+ | Tenum tl ->
+ Tydec_enum tl
+ | Tstruct fl ->
+ Tydec_struct (List.map (fun (f, t) -> f, coretype_type t) fl)
+ | Tarray (d, t) ->
+ Tydec_array (d, coretype_type t)
+ | Tstatic (_, t) ->
+ coretype_type t
+ | _ ->
+ assert false
+
+ let get_coretype_definition tname =
+ try
+ let top = Hashtbl.find type_table (Tydec_const tname) in
+ match top.top_decl_desc with
+ | TypeDef tdef ->
+ tdef.tydef_desc
+ | _ ->
+ assert false
+ with Not_found -> raise (Error (Location.dummy_loc, Unbound_type tname))
+
+ let get_type_definition tname =
+ type_coretype (fun _ -> ()) (get_coretype_definition tname)
+
+ (* Equality on ground types only *)
+ (* Should be used between local variables which must have a ground type *)
+ let rec eq_ground t1 t2 =
+ let t1 = repr t1 in
+ let t2 = repr t2 in
+ t1 == t2
+ ||
+ match t1.tdesc, t2.tdesc with
+ | Tbasic t1, Tbasic t2 when t1 == t2 ->
+ true
+ | Tenum tl, Tenum tl' when tl == tl' ->
+ true
+ | Ttuple tl, Ttuple tl' when List.length tl = List.length tl' ->
+ List.for_all2 eq_ground tl tl'
+ | Tstruct fl, Tstruct fl' when List.map fst fl = List.map fst fl' ->
+ List.for_all2 (fun (_, t) (_, t') -> eq_ground t t') fl fl'
+ | Tconst t, _ ->
+ let def_t = get_type_definition t in
+ eq_ground def_t t2
+ | _, Tconst t ->
+ let def_t = get_type_definition t in
+ eq_ground t1 def_t
+ | Tarrow (t1, t2), Tarrow (t1', t2') ->
+ eq_ground t1 t1' && eq_ground t2 t2'
+ | Tclock t1', Tclock t2' ->
+ eq_ground t1' t2'
+ | Tstatic (e1, t1'), Tstatic (e2, t2') | Tarray (e1, t1'), Tarray (e2, t2')
+ ->
+ Dimension.is_eq_dimension e1 e2 && eq_ground t1' t2'
+ | _ ->
+ false
+
+ (** [unify t1 t2] unifies types [t1] and [t2] using standard destructive
+ unification. Raises [Unify (t1,t2)] if the types are not unifiable. [t1]
+ is a expected/formal/spec type, [t2] is a computed/real/implem type, so in
+ case of unification error: expected type [t1], got type [t2]. If
+ [sub]-typing is allowed, [t2] may be a subtype of [t1]. If [semi]
+ unification is required, [t1] should furthermore be an instance of [t2]
+ and constants are handled differently.*)
+ let unify ?(sub = false) ?(semi = false) t1 t2 =
+ let rec unif t1 t2 =
let t1 = repr t1 in
let t2 = repr t2 in
- t1==t2 ||
+ if t1 == t2 then ()
+ else
match t1.tdesc, t2.tdesc with
- | Tbasic t1, Tbasic t2 when t1 == t2 -> true
- | Tenum tl, Tenum tl' when tl == tl' -> true
- | Ttuple tl, Ttuple tl' when List.length tl = List.length tl' -> List.for_all2 eq_ground tl tl'
- | Tstruct fl, Tstruct fl' when List.map fst fl = List.map fst fl' -> List.for_all2 (fun (_, t) (_, t') -> eq_ground t t') fl fl'
- | (Tconst t, _) ->
- let def_t = get_type_definition t in
- eq_ground def_t t2
- | (_, Tconst t) ->
- let def_t = get_type_definition t in
- eq_ground t1 def_t
- | Tarrow (t1,t2), Tarrow (t1',t2') -> eq_ground t1 t1' && eq_ground t2 t2'
- | Tclock t1', Tclock t2' -> eq_ground t1' t2'
- | Tstatic (e1, t1'), Tstatic (e2, t2')
- | Tarray (e1, t1'), Tarray (e2, t2') -> Dimension.is_eq_dimension e1 e2 && eq_ground t1' t2'
- | _ -> false
-
- (** [unify t1 t2] unifies types [t1] and [t2]
- using standard destructive unification.
- Raises [Unify (t1,t2)] if the types are not unifiable.
- [t1] is a expected/formal/spec type, [t2] is a computed/real/implem type,
- so in case of unification error: expected type [t1], got type [t2].
- If [sub]-typing is allowed, [t2] may be a subtype of [t1].
- If [semi] unification is required,
- [t1] should furthermore be an instance of [t2]
- and constants are handled differently.*)
- let unify ?(sub=false) ?(semi=false) t1 t2 =
- let rec unif t1 t2 =
- let t1 = repr t1 in
- let t2 = repr t2 in
- if t1 == t2 then
+ (* strictly subtyping cases first *)
+ | _, Tclock t2 when sub && get_clock_base_type t1 = None ->
+ unif t1 t2
+ | _, Tstatic (_, t2) when sub && get_static_value t1 = None ->
+ unif t1 t2
+ (* This case is not mandatory but will keep "older" types *)
+ | Tvar, Tvar ->
+ if t1.tid < t2.tid then t2.tdesc <- Tlink t1 else t1.tdesc <- Tlink t2
+ | Tvar, _ when (not semi) && not (occurs t1 t2) ->
+ t1.tdesc <- Tlink t2
+ | _, Tvar when not (occurs t2 t1) ->
+ t2.tdesc <- Tlink t1
+ | Tarrow (t1, t2), Tarrow (t1', t2') ->
+ unif t2 t2';
+ unif t1' t1
+ | Ttuple tl, Ttuple tl' when List.length tl = List.length tl' ->
+ List.iter2 unif tl tl'
+ | Ttuple [ t1 ], _ ->
+ unif t1 t2
+ | _, Ttuple [ t2 ] ->
+ unif t1 t2
+ | Tstruct fl, Tstruct fl' when List.map fst fl = List.map fst fl' ->
+ List.iter2 (fun (_, t) (_, t') -> unif t t') fl fl'
+ | Tclock _, Tstatic _ | Tstatic _, Tclock _ ->
+ raise (Unify (t1, t2))
+ | Tclock t1', Tclock t2' ->
+ unif t1' t2'
+ (* | Tbasic t1, Tbasic t2 when t1 == t2 -> () *)
+ | Tunivar, _ | _, Tunivar ->
()
- else
- match t1.tdesc,t2.tdesc with
- (* strictly subtyping cases first *)
- | _ , Tclock t2 when sub && (get_clock_base_type t1 = None) ->
- unif t1 t2
- | _ , Tstatic (_, t2) when sub && (get_static_value t1 = None) ->
- unif t1 t2
- (* This case is not mandatory but will keep "older" types *)
- | Tvar, Tvar ->
- if t1.tid < t2.tid then
- t2.tdesc <- Tlink t1
+ | Tconst t, _ ->
+ let def_t = get_type_definition t in
+ unif def_t t2
+ | _, Tconst t ->
+ let def_t = get_type_definition t in
+ unif t1 def_t
+ | Tenum tl, Tenum tl' when tl == tl' ->
+ ()
+ | Tstatic (e1, t1'), Tstatic (e2, t2')
+ | Tarray (e1, t1'), Tarray (e2, t2') ->
+ let eval_const =
+ if semi then fun c ->
+ Some (Dimension.mkdim_ident Location.dummy_loc c)
+ else fun _ -> None
+ in
+ unif t1' t2';
+ Dimension.eval Basic_library.eval_dim_env eval_const e1;
+ Dimension.eval Basic_library.eval_dim_env eval_const e2;
+ Dimension.unify ~semi e1 e2
+ (* Special cases for machine_types. Rules to unify static types infered
+ for numerical constants with non static ones for variables with
+ possible machine types *)
+ | Tbasic bt1, Tbasic bt2 when BasicT.is_unifiable bt1 bt2 ->
+ BasicT.unify bt1 bt2
+ | _, _ ->
+ raise (Unify (t1, t2))
+ in
+ unif t1 t2
+
+ (* Expected type ty1, got type ty2 *)
+ let try_unify ?(sub = false) ?(semi = false) ty1 ty2 loc =
+ try unify ~sub ~semi ty1 ty2 with
+ | Unify (t1', t2') ->
+ raise (Error (loc, Type_clash (ty1, ty2)))
+ | Dimension.Unify _ ->
+ raise (Error (loc, Type_clash (ty1, ty2)))
+
+ (************************************************)
+ (* Typing function for each basic AST construct *)
+ (************************************************)
+
+ let rec type_struct_const_field ?(is_annot = false) loc (label, c) =
+ if Hashtbl.mem field_table label then (
+ let tydef = Hashtbl.find field_table label in
+ let tydec = (typedef_of_top tydef).tydef_desc in
+ let tydec_struct = get_struct_type_fields tydec in
+ let ty_label =
+ type_coretype (fun _ -> ()) (List.assoc label tydec_struct)
+ in
+ try_unify ty_label (type_const ~is_annot loc c) loc;
+ type_coretype (fun _ -> ()) tydec)
+ else raise (Error (loc, Unbound_value ("struct field " ^ label)))
+
+ and type_const ?(is_annot = false) loc c =
+ match c with
+ | Const_int _ ->
+ (* Type_predef. *)
+ type_int
+ | Const_real _ ->
+ (* Type_predef. *)
+ type_real
+ | Const_array ca ->
+ let d = Dimension.mkdim_int loc (List.length ca) in
+ let ty = new_var () in
+ List.iter (fun e -> try_unify ty (type_const ~is_annot loc e) loc) ca;
+ (* Type_predef. *)
+ type_array d ty
+ | Const_tag t ->
+ if Hashtbl.mem tag_table t then
+ let tydef = typedef_of_top (Hashtbl.find tag_table t) in
+ let tydec =
+ if is_user_type tydef.tydef_desc then Tydec_const tydef.tydef_id
+ else tydef.tydef_desc
+ in
+ type_coretype (fun _ -> ()) tydec
+ else raise (Error (loc, Unbound_value ("enum tag " ^ t)))
+ | Const_struct fl -> (
+ let ty_struct = new_var () in
+ let used =
+ List.fold_left
+ (fun acc (l, c) ->
+ if List.mem l acc then
+ raise (Error (loc, Already_bound ("struct field " ^ l)))
else
- t1.tdesc <- Tlink t2
- | Tvar, _ when (not semi) && (not (occurs t1 t2)) ->
- t1.tdesc <- Tlink t2
- | _, Tvar when (not (occurs t2 t1)) ->
- t2.tdesc <- Tlink t1
- | Tarrow (t1,t2), Tarrow (t1',t2') ->
- begin
- unif t2 t2';
- unif t1' t1
- end
- | Ttuple tl, Ttuple tl' when List.length tl = List.length tl' ->
- List.iter2 unif tl tl'
- | Ttuple [t1] , _ -> unif t1 t2
- | _ , Ttuple [t2] -> unif t1 t2
- | Tstruct fl, Tstruct fl' when List.map fst fl = List.map fst fl' ->
- List.iter2 (fun (_, t) (_, t') -> unif t t') fl fl'
- | Tclock _, Tstatic _
- | Tstatic _, Tclock _ -> raise (Unify (t1, t2))
- | Tclock t1', Tclock t2' -> unif t1' t2'
- (* | Tbasic t1, Tbasic t2 when t1 == t2 -> () *)
- | Tunivar, _ | _, Tunivar -> ()
- | (Tconst t, _) ->
- let def_t = get_type_definition t in
- unif def_t t2
- | (_, Tconst t) ->
- let def_t = get_type_definition t in
- unif t1 def_t
- | Tenum tl, Tenum tl' when tl == tl' -> ()
- | Tstatic (e1, t1'), Tstatic (e2, t2')
- | Tarray (e1, t1'), Tarray (e2, t2') ->
- let eval_const =
- if semi
- then (fun c -> Some (Dimension.mkdim_ident Location.dummy_loc c))
- else (fun _ -> None) in
- begin
- unif t1' t2';
- Dimension.eval Basic_library.eval_dim_env eval_const e1;
- Dimension.eval Basic_library.eval_dim_env eval_const e2;
- Dimension.unify ~semi:semi e1 e2;
- end
- (* Special cases for machine_types. Rules to unify static types infered
- for numerical constants with non static ones for variables with
- possible machine types *)
- | Tbasic bt1, Tbasic bt2 when BasicT.is_unifiable bt1 bt2 -> BasicT.unify bt1 bt2
- | _,_ -> raise (Unify (t1, t2))
- in unif t1 t2
-
- (* Expected type ty1, got type ty2 *)
- let try_unify ?(sub=false) ?(semi=false) ty1 ty2 loc =
+ try_unify ty_struct
+ (type_struct_const_field ~is_annot loc (l, c))
+ loc;
+ l :: acc)
+ [] fl
+ in
try
- unify ~sub:sub ~semi:semi ty1 ty2
- with
- | Unify (t1', t2') ->
- raise (Error (loc, Type_clash (ty1,ty2)))
- | Dimension.Unify _ ->
- raise (Error (loc, Type_clash (ty1,ty2)))
-
-
- (************************************************)
- (* Typing function for each basic AST construct *)
- (************************************************)
-
- let rec type_struct_const_field ?(is_annot=false) loc (label, c) =
- if Hashtbl.mem field_table label
- then let tydef = Hashtbl.find field_table label in
- let tydec = (typedef_of_top tydef).tydef_desc in
- let tydec_struct = get_struct_type_fields tydec in
- let ty_label = type_coretype (fun _ -> ()) (List.assoc label tydec_struct) in
- begin
- try_unify ty_label (type_const ~is_annot loc c) loc;
- type_coretype (fun _ -> ()) tydec
- end
- else raise (Error (loc, Unbound_value ("struct field " ^ label)))
-
- and type_const ?(is_annot=false) loc c =
- match c with
- | Const_int _ -> (* Type_predef. *)type_int
- | Const_real _ -> (* Type_predef. *)type_real
- | Const_array ca -> let d = Dimension.mkdim_int loc (List.length ca) in
- let ty = new_var () in
- List.iter (fun e -> try_unify ty (type_const ~is_annot loc e) loc) ca;
- (* Type_predef. *)type_array d ty
- | Const_tag t ->
- if Hashtbl.mem tag_table t
- then
- let tydef = typedef_of_top (Hashtbl.find tag_table t) in
- let tydec =
- if is_user_type tydef.tydef_desc
- then Tydec_const tydef.tydef_id
- else tydef.tydef_desc in
- type_coretype (fun _ -> ()) tydec
- else raise (Error (loc, Unbound_value ("enum tag " ^ t)))
- | Const_struct fl ->
- let ty_struct = new_var () in
- begin
- let used =
- List.fold_left
- (fun acc (l, c) ->
- if List.mem l acc
- then raise (Error (loc, Already_bound ("struct field " ^ l)))
- else try_unify ty_struct (type_struct_const_field ~is_annot loc (l, c)) loc; l::acc)
- [] fl in
- try
- let total = List.map fst (get_struct_type_fields (coretype_type ty_struct)) in
- (* List.iter (fun l -> Format.eprintf "total: %s@." l) total;
- List.iter (fun l -> Format.eprintf "used: %s@." l) used; *)
- let undef = List.find (fun l -> not (List.mem l used)) total
- in raise (Error (loc, Unbound_value ("struct field " ^ undef)))
- with Not_found ->
- ty_struct
- end
- | Const_string s | Const_modeid s ->
- if is_annot then (* Type_predef. *)type_string else (Format.eprintf "Typing string %s outisde of annot scope@.@?" s; assert false (* string datatype should only appear in annotations *))
-
- (* The following typing functions take as parameter an environment [env]
- and whether the element being typed is expected to be constant [const].
- [env] is a pair composed of:
- - a map from ident to type, associating to each ident, i.e.
- variables, constants and (imported) nodes, its type including whether
- it is constant or not. This latter information helps in checking constant
- propagation policy in Lustre.
- - a vdecl list, in order to modify types of declared variables that are
- later discovered to be clocks during the typing process.
- *)
- let check_constant loc const_expected const_real =
- if const_expected && not const_real
- then raise (Error (loc, Not_a_constant))
-
- let rec type_add_const env const arg targ =
- (*Format.eprintf "Typing.type_add_const %a %a@." Printers.pp_expr arg Types.print_ty targ;*)
- if const
- then let d =
- if is_dimension_type targ
- then dimension_of_expr arg
- else Dimension.mkdim_var () in
- let eval_const id = (* Types. *)get_static_value (Env.lookup_value (fst env) id) in
- Dimension.eval Basic_library.eval_dim_env eval_const d;
- let real_static_type = (* Type_predef. *)type_static d ((* Types. *)dynamic_type targ) in
- (match (* Types. *)get_static_value targ with
- | None -> ()
- | Some _ -> try_unify targ real_static_type arg.expr_loc);
- real_static_type
- else targ
-
- (* emulates a subtyping relation between types t and (d : t),
- used during node applications and assignments *)
- and type_subtyping_arg env in_main ?(sub=true) const real_arg formal_type =
- let loc = real_arg.expr_loc in
- let const = const || ((* Types. *)get_static_value formal_type <> None) in
- let real_type = type_add_const env const real_arg (type_expr env in_main const real_arg) in
- (*Format.eprintf "subtyping const %B real %a:%a vs formal %a@." const Printers.pp_expr real_arg Types.print_ty real_type Types.print_ty formal_type;*)
- try_unify ~sub:sub formal_type real_type loc
-
- (* typing an application implies:
- - checking that const formal parameters match real const (maybe symbolic) arguments
- - checking type adequation between formal and real arguments
- An application may embed an homomorphic/internal function, in which case we need to split
- it in many calls
- *)
- and type_appl env in_main loc const f args =
- let targs = List.map (type_expr env in_main const) args in
- if Basic_library.is_homomorphic_fun f && List.exists is_tuple_type targs
- then
- try
- let targs = Utils.transpose_list (List.map type_list_of_type targs) in
- (* Types. *)type_of_type_list (List.map (type_simple_call env in_main loc const f) targs)
- with
- Utils.TransposeError (l, l') -> raise (Error (loc, WrongMorphism (l, l')))
-
+ let total =
+ List.map fst (get_struct_type_fields (coretype_type ty_struct))
+ in
+ (* List.iter (fun l -> Format.eprintf "total: %s@." l) total; List.iter
+ (fun l -> Format.eprintf "used: %s@." l) used; *)
+ let undef = List.find (fun l -> not (List.mem l used)) total in
+ raise (Error (loc, Unbound_value ("struct field " ^ undef)))
+ with Not_found -> ty_struct)
+ | Const_string s | Const_modeid s ->
+ if is_annot then (* Type_predef. *)
+ type_string
else (
- type_dependent_call env in_main loc const f (List.combine args targs)
- )
-
- (* type a call with possible dependent types. [targs] is here a list of (argument, type) pairs. *)
- and type_dependent_call env in_main loc const f targs =
- (* Format.eprintf "Typing.type_dependent_call %s@." f; *)
- let tins, touts = new_var (), new_var () in
- (* Format.eprintf "tin=%a, tout=%a@." print_ty tins print_ty touts; *)
- let tfun = (* Type_predef. *)type_arrow tins touts in
- (* Format.eprintf "fun=%a@." print_ty tfun; *)
- type_subtyping_arg env in_main const (expr_of_ident f loc) tfun;
- (* Format.eprintf "type subtyping@."; *)
- let tins = type_list_of_type tins in
- if List.length targs <> List.length tins then
- raise (Error (loc, WrongArity (List.length tins, List.length targs)))
- else
- begin
- List.iter2 (
- fun (a,t) ti ->
- let t' = type_add_const env (const || (* Types. *)get_static_value ti <> None) a t in
- (* Format.eprintf "uniying ti=%a t'=%a touts=%a@." print_ty ti print_ty t' print_ty touts; *)
- try_unify ~sub:true ti t' a.expr_loc;
- (* Format.eprintf "unified ti=%a t'=%a touts=%a@." print_ty ti print_ty t' print_ty touts; *)
-
- )
- targs
- tins;
- touts
- end
-
- (* type a simple call without dependent types
- but possible homomorphic extension.
- [targs] is here a list of arguments' types. *)
- and type_simple_call env in_main loc const f targs =
- let tins, touts = new_var (), new_var () in
- let tfun = (* Type_predef. *)type_arrow tins touts in
- type_subtyping_arg env in_main const (expr_of_ident f loc) tfun;
- (*Format.eprintf "try unify %a %a@." Types.print_ty tins Types.print_ty (type_of_type_list targs);*)
- try_unify ~sub:true tins (type_of_type_list targs) loc;
- touts
-
- (** [type_expr env in_main expr] types expression [expr] in environment
- [env], expecting it to be [const] or not. *)
- and type_expr ?(is_annot=false) env in_main const expr =
- let resulting_ty =
- match expr.expr_desc with
- | Expr_const c ->
- let ty = type_const ~is_annot expr.expr_loc c in
- let ty = (* Type_predef. *)type_static (Dimension.mkdim_var ()) ty in
- expr.expr_type <- Expr_type_hub.export ty;
- ty
- | Expr_ident v ->
- let tyv =
- try
- Env.lookup_value (fst env) v
- with Not_found ->
- Format.eprintf "Failure in typing expr %a. Not in typing environement@." Printers.pp_expr expr;
- raise (Error (expr.expr_loc, Unbound_value ("identifier " ^ v)))
- in
- let ty = instantiate (ref []) (ref []) tyv in
- let ty' =
- if const
- then (* Type_predef. *)type_static (Dimension.mkdim_var ()) (new_var ())
- else new_var () in
- try_unify ty ty' expr.expr_loc;
- expr.expr_type <- Expr_type_hub.export ty;
- ty
- | Expr_array elist ->
- let ty_elt = new_var () in
- List.iter (fun e -> try_unify ty_elt (type_appl env in_main expr.expr_loc const "uminus" [e]) e.expr_loc) elist;
- let d = Dimension.mkdim_int expr.expr_loc (List.length elist) in
- let ty = (* Type_predef. *)type_array d ty_elt in
- expr.expr_type <- Expr_type_hub.export ty;
- ty
- | Expr_access (e1, d) ->
- type_subtyping_arg env in_main false (* not necessary a constant *) (expr_of_dimension d) (* Type_predef. *)type_int;
- let ty_elt = new_var () in
- let d = Dimension.mkdim_var () in
- type_subtyping_arg env in_main const e1 ((* Type_predef. *)type_array d ty_elt);
- expr.expr_type <- Expr_type_hub.export ty_elt;
- ty_elt
- | Expr_power (e1, d) ->
- let eval_const id = (* Types. *)get_static_value (Env.lookup_value (fst env) id) in
- type_subtyping_arg env in_main true (expr_of_dimension d) (* Type_predef. *)type_int;
- Dimension.eval Basic_library.eval_dim_env eval_const d;
- let ty_elt = type_appl env in_main expr.expr_loc const "uminus" [e1] in
- let ty = (* Type_predef. *)type_array d ty_elt in
- expr.expr_type <- Expr_type_hub.export ty;
- ty
- | Expr_tuple elist ->
- let ty = new_ty (Ttuple (List.map (type_expr ~is_annot env in_main const) elist)) in
- expr.expr_type <- Expr_type_hub.export ty;
- ty
- | Expr_ite (c, t, e) ->
- type_subtyping_arg env in_main const c (* Type_predef. *)type_bool;
- let ty = type_appl env in_main expr.expr_loc const "+" [t; e] in
- expr.expr_type <- Expr_type_hub.export ty;
- ty
- | Expr_appl (id, args, r) ->
- (* application of non internal function is not legal in a constant
- expression *)
- (match r with
- | None -> ()
- | Some c ->
- check_constant expr.expr_loc const false;
- type_subtyping_arg env in_main const c (* Type_predef. *)type_bool);
- let args_list = expr_list_of_expr args in
- let touts = type_appl env in_main expr.expr_loc const id args_list in
- let targs = new_ty (Ttuple (List.map (fun a -> Expr_type_hub.import a.expr_type) args_list)) in
- args.expr_type <- Expr_type_hub.export targs;
- expr.expr_type <- Expr_type_hub.export touts;
- touts
- | Expr_fby (e1,e2)
- | Expr_arrow (e1,e2) ->
- (* fby/arrow is not legal in a constant expression *)
- check_constant expr.expr_loc const false;
- let ty = type_appl env in_main expr.expr_loc const "+" [e1; e2] in
- expr.expr_type <- Expr_type_hub.export ty;
- ty
- | Expr_pre e ->
- (* pre is not legal in a constant expression *)
- check_constant expr.expr_loc const false;
- let ty = type_appl env in_main expr.expr_loc const "uminus" [e] in
- expr.expr_type <- Expr_type_hub.export ty;
- ty
- | Expr_when (e1,c,l) ->
- (* when is not legal in a constant expression *)
- check_constant expr.expr_loc const false;
- let typ_l = (* Type_predef. *)type_clock (type_const ~is_annot expr.expr_loc (Const_tag l)) in
- let expr_c = expr_of_ident c expr.expr_loc in
- type_subtyping_arg env in_main ~sub:false const expr_c typ_l;
- let ty = type_appl env in_main expr.expr_loc const "uminus" [e1] in
- expr.expr_type <- Expr_type_hub.export ty;
- ty
- | Expr_merge (c,hl) ->
- (* merge is not legal in a constant expression *)
- check_constant expr.expr_loc const false;
- let typ_in, typ_out = type_branches env in_main expr.expr_loc const hl in
- let expr_c = expr_of_ident c expr.expr_loc in
- let typ_l = (* Type_predef. *)type_clock typ_in in
- type_subtyping_arg env in_main ~sub:false const expr_c typ_l;
- expr.expr_type <- Expr_type_hub.export typ_out;
- typ_out
- in
- Log.report ~level:3 (fun fmt ->
- Format.fprintf fmt "Type of expr %a: %a@ "
- Printers.pp_expr expr (* Types. *)print_ty resulting_ty);
- resulting_ty
-
- and type_branches ?(is_annot=false) env in_main loc const hl =
- let typ_in = new_var () in
- let typ_out = new_var () in
- try
- let used_labels =
- List.fold_left (fun accu (t, h) ->
- unify typ_in (type_const ~is_annot loc (Const_tag t));
- type_subtyping_arg env in_main const h typ_out;
- if List.mem t accu
- then raise (Error (loc, Already_bound t))
- else t :: accu) [] hl in
- let type_labels = get_enum_type_tags (coretype_type typ_in) in
- if List.sort compare used_labels <> List.sort compare type_labels
- then let unbound_tag = List.find (fun t -> not (List.mem t used_labels)) type_labels in
- raise (Error (loc, Unbound_value ("branching tag " ^ unbound_tag)))
- else (typ_in, typ_out)
- with Unify (t1, t2) ->
- raise (Error (loc, Type_clash (t1,t2)))
-
- (* Eexpr are always in annotations. TODO: add the quantifiers variables to the env *)
- let type_eexpr env eexpr =
- (type_expr
- ~is_annot:true
- env
- false (* not in main *)
- false (* not a const *)
- eexpr.eexpr_qfexpr)
-
-
- (** [type_eq env eq] types equation [eq] in environment [env] *)
- let type_eq env in_main undefined_vars eq =
- (*Format.eprintf "Typing.type_eq %a@." Printers.pp_node_eq eq;*)
- (* Check undefined variables, type lhs *)
- let expr_lhs = expr_of_expr_list eq.eq_loc (List.map (fun v -> expr_of_ident v eq.eq_loc) eq.eq_lhs) in
- let ty_lhs = type_expr env in_main false expr_lhs in
- (* Check multiple variable definitions *)
- let define_var id uvars =
- if ISet.mem id uvars
- then ISet.remove id uvars
- else raise (Error (eq.eq_loc, Already_defined id))
+ Format.eprintf "Typing string %s outisde of annot scope@.@?" s;
+ assert false (* string datatype should only appear in annotations *))
+
+ (* The following typing functions take as parameter an environment [env] and
+ whether the element being typed is expected to be constant [const]. [env]
+ is a pair composed of: - a map from ident to type, associating to each
+ ident, i.e. variables, constants and (imported) nodes, its type including
+ whether it is constant or not. This latter information helps in checking
+ constant propagation policy in Lustre. - a vdecl list, in order to modify
+ types of declared variables that are later discovered to be clocks during
+ the typing process. *)
+ let check_constant loc const_expected const_real =
+ if const_expected && not const_real then raise (Error (loc, Not_a_constant))
+
+ let rec type_add_const env const arg targ =
+ (*Format.eprintf "Typing.type_add_const %a %a@." Printers.pp_expr arg
+ Types.print_ty targ;*)
+ if const then (
+ let d =
+ if is_dimension_type targ then dimension_of_expr arg
+ else Dimension.mkdim_var ()
+ in
+ let eval_const id =
+ (* Types. *)
+ get_static_value (Env.lookup_value (fst env) id)
+ in
+ Dimension.eval Basic_library.eval_dim_env eval_const d;
+ let real_static_type =
+ (* Type_predef. *)
+ type_static d ((* Types. *)
+ dynamic_type targ)
in
- (* check assignment of declared constant, assignment of clock *)
- let ty_lhs =
+ (match (* Types. *)
+ get_static_value targ with
+ | None ->
+ ()
+ | Some _ ->
+ try_unify targ real_static_type arg.expr_loc);
+ real_static_type)
+ else targ
+
+ (* emulates a subtyping relation between types t and (d : t), used during node
+ applications and assignments *)
+ and type_subtyping_arg env in_main ?(sub = true) const real_arg formal_type =
+ let loc = real_arg.expr_loc in
+ let const =
+ const
+ || (* Types. *)
+ get_static_value formal_type <> None
+ in
+ let real_type =
+ type_add_const env const real_arg (type_expr env in_main const real_arg)
+ in
+ (*Format.eprintf "subtyping const %B real %a:%a vs formal %a@." const
+ Printers.pp_expr real_arg Types.print_ty real_type Types.print_ty
+ formal_type;*)
+ try_unify ~sub formal_type real_type loc
+
+ (* typing an application implies: - checking that const formal parameters
+ match real const (maybe symbolic) arguments - checking type adequation
+ between formal and real arguments An application may embed an
+ homomorphic/internal function, in which case we need to split it in many
+ calls *)
+ and type_appl env in_main loc const f args =
+ let targs = List.map (type_expr env in_main const) args in
+ if Basic_library.is_homomorphic_fun f && List.exists is_tuple_type targs
+ then
+ try
+ let targs = Utils.transpose_list (List.map type_list_of_type targs) in
+ (* Types. *)
type_of_type_list
- (List.map2 (fun ty id ->
- if get_static_value ty <> None
- then raise (Error (eq.eq_loc, Assigned_constant id)) else
- match get_clock_base_type ty with
- | None -> ty
- | Some ty -> ty)
- (type_list_of_type ty_lhs) eq.eq_lhs) in
- let undefined_vars =
- List.fold_left (fun uvars v -> define_var v uvars) undefined_vars eq.eq_lhs in
- (* Type rhs wrt to lhs type with subtyping, i.e. a constant rhs value may be assigned
- to a (always non-constant) lhs variable *)
- type_subtyping_arg env in_main false eq.eq_rhs ty_lhs;
- undefined_vars
-
-
- (* [type_coreclock env ck id loc] types the type clock declaration [ck]
- in environment [env] *)
- let type_coreclock env ck id loc =
- match ck.ck_dec_desc with
- | Ckdec_any -> ()
- | Ckdec_bool cl ->
- let dummy_id_expr = expr_of_ident id loc in
- let when_expr =
- List.fold_left
- (fun expr (x, l) ->
- {expr_tag = new_tag ();
- expr_desc= Expr_when (expr,x,l);
- expr_type = Types.Main.new_var ();
- expr_clock = Clocks.new_var true;
- expr_delay = Delay.new_var ();
- expr_loc=loc;
- expr_annot = None})
- dummy_id_expr cl
- in
- ignore (type_expr env false false when_expr)
-
- let rec check_type_declaration loc cty =
- match cty with
- | Tydec_clock ty
- | Tydec_array (_, ty) -> check_type_declaration loc ty
- | Tydec_const tname ->
- (* Format.eprintf "TABLE: %a@." print_type_table (); *)
- if not (Hashtbl.mem type_table cty)
- then raise (Error (loc, Unbound_type tname));
- | _ -> ()
-
- let type_var_decl vd_env env vdecl =
- (*Format.eprintf "Typing.type_var_decl START %a:%a@." Printers.pp_var vdecl Printers.print_dec_ty vdecl.var_dec_type.ty_dec_desc;*)
- check_type_declaration vdecl.var_loc vdecl.var_dec_type.ty_dec_desc;
- let eval_const id = (* Types. *)get_static_value (Env.lookup_value env id) in
- let type_dim d =
- begin
- type_subtyping_arg (env, vd_env) false true (expr_of_dimension d) (* Type_predef. *)type_int;
- Dimension.eval Basic_library.eval_dim_env eval_const d;
- end in
- let ty = type_coretype type_dim vdecl.var_dec_type.ty_dec_desc in
-
- let ty_static =
- if vdecl.var_dec_const
- then (* Type_predef. *)type_static (Dimension.mkdim_var ()) ty
- else ty in
- (match vdecl.var_dec_value with
- | None -> ()
- | Some v -> type_subtyping_arg (env, vd_env) false ~sub:false true v ty_static);
- try_unify ty_static (Expr_type_hub.import vdecl.var_type) vdecl.var_loc;
- let new_env = Env.add_value env vdecl.var_id ty_static in
- type_coreclock (new_env,vd_env) vdecl.var_dec_clock vdecl.var_id vdecl.var_loc;
- (*Format.eprintf "END %a@." Types.print_ty ty_static;*)
- new_env
-
- let type_var_decl_list vd_env env l =
- List.fold_left (type_var_decl vd_env) env l
-
- let type_of_vlist vars =
- let tyl = List.map (fun v -> Expr_type_hub.import v.var_type) vars in
- type_of_type_list tyl
-
- let add_vdecl vd_env vdecl =
- if List.exists (fun v -> v.var_id = vdecl.var_id) vd_env
- then raise (Error (vdecl.var_loc, Already_bound vdecl.var_id))
- else vdecl::vd_env
-
- let check_vd_env vd_env =
- ignore (List.fold_left add_vdecl [] vd_env)
-
- let type_contract env c =
- let vd_env = c.consts @ c.locals in
- check_vd_env vd_env;
- let env = type_var_decl_list ((* this argument seems useless to me, cf TODO at top of the file*) vd_env) env vd_env in
- (* typing stmts *)
- let eqs = List.map (fun s -> match s with Eq eq -> eq | _ -> assert false) c.stmts in
- let undefined_vars_init =
+ (List.map (type_simple_call env in_main loc const f) targs)
+ with Utils.TransposeError (l, l') ->
+ raise (Error (loc, WrongMorphism (l, l')))
+ else type_dependent_call env in_main loc const f (List.combine args targs)
+
+ (* type a call with possible dependent types. [targs] is here a list of
+ (argument, type) pairs. *)
+ and type_dependent_call env in_main loc const f targs =
+ (* Format.eprintf "Typing.type_dependent_call %s@." f; *)
+ let tins, touts = new_var (), new_var () in
+ (* Format.eprintf "tin=%a, tout=%a@." print_ty tins print_ty touts; *)
+ let tfun =
+ (* Type_predef. *)
+ type_arrow tins touts
+ in
+ (* Format.eprintf "fun=%a@." print_ty tfun; *)
+ type_subtyping_arg env in_main const (expr_of_ident f loc) tfun;
+ (* Format.eprintf "type subtyping@."; *)
+ let tins = type_list_of_type tins in
+ if List.length targs <> List.length tins then
+ raise (Error (loc, WrongArity (List.length tins, List.length targs)))
+ else (
+ List.iter2
+ (fun (a, t) ti ->
+ let t' =
+ type_add_const env
+ (const
+ || (* Types. *)
+ get_static_value ti <> None)
+ a t
+ in
+ (* Format.eprintf "uniying ti=%a t'=%a touts=%a@." print_ty ti
+ print_ty t' print_ty touts; *)
+ try_unify ~sub:true ti t' a.expr_loc
+ (* Format.eprintf "unified ti=%a t'=%a touts=%a@." print_ty ti
+ print_ty t' print_ty touts; *))
+ targs tins;
+ touts)
+
+ (* type a simple call without dependent types but possible homomorphic
+ extension. [targs] is here a list of arguments' types. *)
+ and type_simple_call env in_main loc const f targs =
+ let tins, touts = new_var (), new_var () in
+ let tfun =
+ (* Type_predef. *)
+ type_arrow tins touts
+ in
+ type_subtyping_arg env in_main const (expr_of_ident f loc) tfun;
+ (*Format.eprintf "try unify %a %a@." Types.print_ty tins Types.print_ty
+ (type_of_type_list targs);*)
+ try_unify ~sub:true tins (type_of_type_list targs) loc;
+ touts
+
+ (** [type_expr env in_main expr] types expression [expr] in environment [env],
+ expecting it to be [const] or not. *)
+ and type_expr ?(is_annot = false) env in_main const expr =
+ let resulting_ty =
+ match expr.expr_desc with
+ | Expr_const c ->
+ let ty = type_const ~is_annot expr.expr_loc c in
+ let ty =
+ (* Type_predef. *)
+ type_static (Dimension.mkdim_var ()) ty
+ in
+ expr.expr_type <- Expr_type_hub.export ty;
+ ty
+ | Expr_ident v ->
+ let tyv =
+ try Env.lookup_value (fst env) v
+ with Not_found ->
+ Format.eprintf
+ "Failure in typing expr %a. Not in typing environement@."
+ Printers.pp_expr expr;
+ raise (Error (expr.expr_loc, Unbound_value ("identifier " ^ v)))
+ in
+ let ty = instantiate (ref []) (ref []) tyv in
+ let ty' =
+ if const then
+ (* Type_predef. *)
+ type_static (Dimension.mkdim_var ()) (new_var ())
+ else new_var ()
+ in
+ try_unify ty ty' expr.expr_loc;
+ expr.expr_type <- Expr_type_hub.export ty;
+ ty
+ | Expr_array elist ->
+ let ty_elt = new_var () in
+ List.iter
+ (fun e ->
+ try_unify ty_elt
+ (type_appl env in_main expr.expr_loc const "uminus" [ e ])
+ e.expr_loc)
+ elist;
+ let d = Dimension.mkdim_int expr.expr_loc (List.length elist) in
+ let ty =
+ (* Type_predef. *)
+ type_array d ty_elt
+ in
+ expr.expr_type <- Expr_type_hub.export ty;
+ ty
+ | Expr_access (e1, d) ->
+ type_subtyping_arg env in_main false
+ (* not necessary a constant *)
+ (expr_of_dimension d)
+ (* Type_predef. *)
+ type_int;
+ let ty_elt = new_var () in
+ let d = Dimension.mkdim_var () in
+ type_subtyping_arg env in_main const e1
+ ((* Type_predef. *)
+ type_array d ty_elt);
+ expr.expr_type <- Expr_type_hub.export ty_elt;
+ ty_elt
+ | Expr_power (e1, d) ->
+ let eval_const id =
+ (* Types. *)
+ get_static_value (Env.lookup_value (fst env) id)
+ in
+ type_subtyping_arg env in_main true (expr_of_dimension d)
+ (* Type_predef. *)
+ type_int;
+ Dimension.eval Basic_library.eval_dim_env eval_const d;
+ let ty_elt =
+ type_appl env in_main expr.expr_loc const "uminus" [ e1 ]
+ in
+ let ty =
+ (* Type_predef. *)
+ type_array d ty_elt
+ in
+ expr.expr_type <- Expr_type_hub.export ty;
+ ty
+ | Expr_tuple elist ->
+ let ty =
+ new_ty
+ (Ttuple (List.map (type_expr ~is_annot env in_main const) elist))
+ in
+ expr.expr_type <- Expr_type_hub.export ty;
+ ty
+ | Expr_ite (c, t, e) ->
+ type_subtyping_arg env in_main const c (* Type_predef. *) type_bool;
+ let ty = type_appl env in_main expr.expr_loc const "+" [ t; e ] in
+ expr.expr_type <- Expr_type_hub.export ty;
+ ty
+ | Expr_appl (id, args, r) ->
+ (* application of non internal function is not legal in a constant
+ expression *)
+ (match r with
+ | None ->
+ ()
+ | Some c ->
+ check_constant expr.expr_loc const false;
+ type_subtyping_arg env in_main const c (* Type_predef. *) type_bool);
+ let args_list = expr_list_of_expr args in
+ let touts = type_appl env in_main expr.expr_loc const id args_list in
+ let targs =
+ new_ty
+ (Ttuple
+ (List.map (fun a -> Expr_type_hub.import a.expr_type) args_list))
+ in
+ args.expr_type <- Expr_type_hub.export targs;
+ expr.expr_type <- Expr_type_hub.export touts;
+ touts
+ | Expr_fby (e1, e2) | Expr_arrow (e1, e2) ->
+ (* fby/arrow is not legal in a constant expression *)
+ check_constant expr.expr_loc const false;
+ let ty = type_appl env in_main expr.expr_loc const "+" [ e1; e2 ] in
+ expr.expr_type <- Expr_type_hub.export ty;
+ ty
+ | Expr_pre e ->
+ (* pre is not legal in a constant expression *)
+ check_constant expr.expr_loc const false;
+ let ty = type_appl env in_main expr.expr_loc const "uminus" [ e ] in
+ expr.expr_type <- Expr_type_hub.export ty;
+ ty
+ | Expr_when (e1, c, l) ->
+ (* when is not legal in a constant expression *)
+ check_constant expr.expr_loc const false;
+ let typ_l =
+ (* Type_predef. *)
+ type_clock (type_const ~is_annot expr.expr_loc (Const_tag l))
+ in
+ let expr_c = expr_of_ident c expr.expr_loc in
+ type_subtyping_arg env in_main ~sub:false const expr_c typ_l;
+ let ty = type_appl env in_main expr.expr_loc const "uminus" [ e1 ] in
+ expr.expr_type <- Expr_type_hub.export ty;
+ ty
+ | Expr_merge (c, hl) ->
+ (* merge is not legal in a constant expression *)
+ check_constant expr.expr_loc const false;
+ let typ_in, typ_out =
+ type_branches env in_main expr.expr_loc const hl
+ in
+ let expr_c = expr_of_ident c expr.expr_loc in
+ let typ_l =
+ (* Type_predef. *)
+ type_clock typ_in
+ in
+ type_subtyping_arg env in_main ~sub:false const expr_c typ_l;
+ expr.expr_type <- Expr_type_hub.export typ_out;
+ typ_out
+ in
+ Log.report ~level:3 (fun fmt ->
+ Format.fprintf fmt "Type of expr %a: %a@ " Printers.pp_expr expr
+ (* Types. *)
+ print_ty resulting_ty);
+ resulting_ty
+
+ and type_branches ?(is_annot = false) env in_main loc const hl =
+ let typ_in = new_var () in
+ let typ_out = new_var () in
+ try
+ let used_labels =
List.fold_left
- (fun uvs v -> ISet.add v.var_id uvs)
- ISet.empty c.locals
+ (fun accu (t, h) ->
+ unify typ_in (type_const ~is_annot loc (Const_tag t));
+ type_subtyping_arg env in_main const h typ_out;
+ if List.mem t accu then raise (Error (loc, Already_bound t))
+ else t :: accu)
+ [] hl
in
- let _ =
+ let type_labels = get_enum_type_tags (coretype_type typ_in) in
+ if List.sort compare used_labels <> List.sort compare type_labels then
+ let unbound_tag =
+ List.find (fun t -> not (List.mem t used_labels)) type_labels
+ in
+ raise (Error (loc, Unbound_value ("branching tag " ^ unbound_tag)))
+ else typ_in, typ_out
+ with Unify (t1, t2) -> raise (Error (loc, Type_clash (t1, t2)))
+
+ (* Eexpr are always in annotations. TODO: add the quantifiers variables to the
+ env *)
+ let type_eexpr env eexpr =
+ type_expr ~is_annot:true env false (* not in main *) false (* not a const *)
+ eexpr.eexpr_qfexpr
+
+ (** [type_eq env eq] types equation [eq] in environment [env] *)
+ let type_eq env in_main undefined_vars eq =
+ (*Format.eprintf "Typing.type_eq %a@." Printers.pp_node_eq eq;*)
+ (* Check undefined variables, type lhs *)
+ let expr_lhs =
+ expr_of_expr_list eq.eq_loc
+ (List.map (fun v -> expr_of_ident v eq.eq_loc) eq.eq_lhs)
+ in
+ let ty_lhs = type_expr env in_main false expr_lhs in
+ (* Check multiple variable definitions *)
+ let define_var id uvars =
+ if ISet.mem id uvars then ISet.remove id uvars
+ else raise (Error (eq.eq_loc, Already_defined id))
+ in
+ (* check assignment of declared constant, assignment of clock *)
+ let ty_lhs =
+ type_of_type_list
+ (List.map2
+ (fun ty id ->
+ if get_static_value ty <> None then
+ raise (Error (eq.eq_loc, Assigned_constant id))
+ else match get_clock_base_type ty with None -> ty | Some ty -> ty)
+ (type_list_of_type ty_lhs) eq.eq_lhs)
+ in
+ let undefined_vars =
+ List.fold_left
+ (fun uvars v -> define_var v uvars)
+ undefined_vars eq.eq_lhs
+ in
+ (* Type rhs wrt to lhs type with subtyping, i.e. a constant rhs value may be
+ assigned to a (always non-constant) lhs variable *)
+ type_subtyping_arg env in_main false eq.eq_rhs ty_lhs;
+ undefined_vars
+
+ (* [type_coreclock env ck id loc] types the type clock declaration [ck] in
+ environment [env] *)
+ let type_coreclock env ck id loc =
+ match ck.ck_dec_desc with
+ | Ckdec_any ->
+ ()
+ | Ckdec_bool cl ->
+ let dummy_id_expr = expr_of_ident id loc in
+ let when_expr =
List.fold_left
- (type_eq (env, vd_env) (false (*is_main*)))
- undefined_vars_init
- eqs
- in
- (* Typing each predicate expr *)
- let type_pred_ee ee : unit=
- type_subtyping_arg (env, vd_env) (false (* not in main *)) (false (* not a const *)) ee.eexpr_qfexpr type_bool
+ (fun expr (x, l) ->
+ {
+ expr_tag = new_tag ();
+ expr_desc = Expr_when (expr, x, l);
+ expr_type = Types.Main.new_var ();
+ expr_clock = Clocks.new_var true;
+ expr_delay = Delay.new_var ();
+ expr_loc = loc;
+ expr_annot = None;
+ })
+ dummy_id_expr cl
in
- List.iter type_pred_ee
- (
- c.assume
- @ c.guarantees
- @ List.flatten (List.map (fun m -> m.ensure @ m.require) c.modes)
- );
- (*TODO
- enrich env locally with locals and consts
- type each pre/post as a boolean expr
- I don't know if we want to update the global env with locally typed variables.
- For the moment, returning the provided env
- *)
+ ignore (type_expr env false false when_expr)
+
+ let rec check_type_declaration loc cty =
+ match cty with
+ | Tydec_clock ty | Tydec_array (_, ty) ->
+ check_type_declaration loc ty
+ | Tydec_const tname ->
+ (* Format.eprintf "TABLE: %a@." print_type_table (); *)
+ if not (Hashtbl.mem type_table cty) then
+ raise (Error (loc, Unbound_type tname))
+ | _ ->
+ ()
+
+ let type_var_decl vd_env env vdecl =
+ (*Format.eprintf "Typing.type_var_decl START %a:%a@." Printers.pp_var vdecl
+ Printers.print_dec_ty vdecl.var_dec_type.ty_dec_desc;*)
+ check_type_declaration vdecl.var_loc vdecl.var_dec_type.ty_dec_desc;
+ let eval_const id =
+ (* Types. *)
+ get_static_value (Env.lookup_value env id)
+ in
+ let type_dim d =
+ type_subtyping_arg (env, vd_env) false true (expr_of_dimension d)
+ (* Type_predef. *)
+ type_int;
+ Dimension.eval Basic_library.eval_dim_env eval_const d
+ in
+ let ty = type_coretype type_dim vdecl.var_dec_type.ty_dec_desc in
+
+ let ty_static =
+ if vdecl.var_dec_const then
+ (* Type_predef. *)
+ type_static (Dimension.mkdim_var ()) ty
+ else ty
+ in
+ (match vdecl.var_dec_value with
+ | None ->
+ ()
+ | Some v ->
+ type_subtyping_arg (env, vd_env) false ~sub:false true v ty_static);
+ try_unify ty_static (Expr_type_hub.import vdecl.var_type) vdecl.var_loc;
+ let new_env = Env.add_value env vdecl.var_id ty_static in
+ type_coreclock (new_env, vd_env) vdecl.var_dec_clock vdecl.var_id
+ vdecl.var_loc;
+ (*Format.eprintf "END %a@." Types.print_ty ty_static;*)
+ new_env
+
+ let type_var_decl_list vd_env env l =
+ List.fold_left (type_var_decl vd_env) env l
+
+ let type_of_vlist vars =
+ let tyl = List.map (fun v -> Expr_type_hub.import v.var_type) vars in
+ type_of_type_list tyl
+
+ let add_vdecl vd_env vdecl =
+ if List.exists (fun v -> v.var_id = vdecl.var_id) vd_env then
+ raise (Error (vdecl.var_loc, Already_bound vdecl.var_id))
+ else vdecl :: vd_env
+
+ let check_vd_env vd_env = ignore (List.fold_left add_vdecl [] vd_env)
+
+ let type_contract env c =
+ let vd_env = c.consts @ c.locals in
+ check_vd_env vd_env;
+ let env =
+ type_var_decl_list
+ (* this argument seems useless to me, cf TODO at top of the file*)
+ vd_env env vd_env
+ in
+ (* typing stmts *)
+ let eqs =
+ List.map (fun s -> match s with Eq eq -> eq | _ -> assert false) c.stmts
+ in
+ let undefined_vars_init =
+ List.fold_left (fun uvs v -> ISet.add v.var_id uvs) ISet.empty c.locals
+ in
+ let _ =
+ List.fold_left
+ (type_eq (env, vd_env) false (*is_main*))
+ undefined_vars_init eqs
+ in
+ (* Typing each predicate expr *)
+ let type_pred_ee ee : unit =
+ type_subtyping_arg (env, vd_env) false (* not in main *) false
+ (* not a const *)
+ ee.eexpr_qfexpr type_bool
+ in
+ List.iter type_pred_ee
+ (c.assume @ c.guarantees
+ @ List.flatten (List.map (fun m -> m.ensure @ m.require) c.modes));
+ (*TODO enrich env locally with locals and consts type each pre/post as a
+ boolean expr I don't know if we want to update the global env with locally
+ typed variables. For the moment, returning the provided env *)
+ env
+
+ let rec type_spec env spec =
+ match spec with Contract c -> type_contract env c | NodeSpec _ -> env
+
+ (** [type_node env nd loc] types node [nd] in environment env. The location is
+ used for error reports. *)
+ and type_node env nd loc =
+ (* Format.eprintf "Typing node %s@." nd.node_id; *)
+ let is_main = nd.node_id = !Options.main_node in
+ (* In contracts, outputs are considered as input values *)
+ let vd_env_ol =
+ if nd.node_iscontract then nd.node_locals
+ else nd.node_outputs @ nd.node_locals
+ in
+ let vd_env = nd.node_inputs @ nd.node_outputs @ nd.node_locals in
+ check_vd_env vd_env;
+ let init_env = env in
+ let delta_env = type_var_decl_list vd_env init_env nd.node_inputs in
+ let delta_env = type_var_decl_list vd_env delta_env nd.node_outputs in
+ let delta_env = type_var_decl_list vd_env delta_env nd.node_locals in
+ let new_env = Env.overwrite env delta_env in
+ let undefined_vars_init =
+ List.fold_left (fun uvs v -> ISet.add v.var_id uvs) ISet.empty vd_env_ol
+ in
+ let undefined_vars =
+ let eqs, _ = get_node_eqs nd in
+ (* TODO XXX: il faut typer les handlers de l'automate *)
+ List.fold_left (type_eq (new_env, vd_env) is_main) undefined_vars_init eqs
+ in
+ (* Typing asserts *)
+ List.iter
+ (fun assert_ ->
+ let assert_expr = assert_.assert_expr in
+ type_subtyping_arg (new_env, vd_env) is_main false assert_expr
+ (* Type_predef. *)
+ type_bool)
+ nd.node_asserts;
+ (* Typing spec/contracts *)
+ (match nd.node_spec with
+ | None ->
+ ()
+ | Some spec ->
+ ignore (type_spec new_env spec));
+ (* Typing annots *)
+ List.iter
+ (fun annot ->
+ List.iter
+ (fun (_, eexpr) -> ignore (type_eexpr (new_env, vd_env) eexpr))
+ annot.annots)
+ nd.node_annot;
+
+ (* check that table is empty *)
+ let local_consts =
+ List.fold_left
+ (fun res vdecl ->
+ if vdecl.var_dec_const then ISet.add vdecl.var_id res else res)
+ ISet.empty nd.node_locals
+ in
+ let undefined_vars = ISet.diff undefined_vars local_consts in
+
+ if not (ISet.is_empty undefined_vars) then
+ raise (Error (loc, Undefined_var undefined_vars));
+ let ty_ins = type_of_vlist nd.node_inputs in
+ let ty_outs = type_of_vlist nd.node_outputs in
+ let ty_node = new_ty (Tarrow (ty_ins, ty_outs)) in
+ generalize ty_node;
+ (* TODO ? Check that no node in the hierarchy remains polymorphic ? *)
+ nd.node_type <- Expr_type_hub.export ty_node;
+ Env.add_value env nd.node_id ty_node
+
+ let type_imported_node env nd _loc =
+ let vd_env = nd.nodei_inputs @ nd.nodei_outputs in
+ check_vd_env vd_env;
+ let delta_env = type_var_decl_list vd_env env nd.nodei_inputs in
+ let delta_env = type_var_decl_list vd_env delta_env nd.nodei_outputs in
+ let new_env = Env.overwrite env delta_env in
+ (* Typing spec *)
+ (match nd.nodei_spec with
+ | None ->
+ ()
+ | Some spec ->
+ ignore (type_spec new_env spec));
+ let ty_ins = type_of_vlist nd.nodei_inputs in
+ let ty_outs = type_of_vlist nd.nodei_outputs in
+ let ty_node = new_ty (Tarrow (ty_ins, ty_outs)) in
+ generalize ty_node;
+ (* if (is_polymorphic ty_node) then raise (Error (loc, Poly_imported_node
+ nd.nodei_id)); *)
+ let new_env = Env.add_value env nd.nodei_id ty_node in
+ nd.nodei_type <- Expr_type_hub.export ty_node;
+ new_env
+
+ let type_top_const env cdecl =
+ let ty = type_const cdecl.const_loc cdecl.const_value in
+ let d =
+ if is_dimension_type ty then
+ dimension_of_const cdecl.const_loc cdecl.const_value
+ else Dimension.mkdim_var ()
+ in
+ let ty =
+ (* Type_predef. *)
+ type_static d ty
+ in
+ let new_env = Env.add_value env cdecl.const_id ty in
+ cdecl.const_type <- Expr_type_hub.export ty;
+ new_env
+
+ let type_top_consts env clist = List.fold_left type_top_const env clist
+
+ let rec type_top_decl env decl =
+ match decl.top_decl_desc with
+ | Node nd -> (
+ try type_node env nd decl.top_decl_loc
+ with Error _ as exc ->
+ if !Options.global_inline then
+ Format.eprintf "Type error: failing node@.%a@.@?" Printers.pp_node nd;
+ raise exc)
+ | ImportedNode nd ->
+ type_imported_node env nd decl.top_decl_loc
+ | Const c ->
+ type_top_const env c
+ | TypeDef _ ->
+ List.fold_left type_top_decl env (consts_of_enum_type decl)
+ | Include _ | Open _ ->
env
- let rec type_spec env spec =
- match spec with
- | Contract c -> type_contract env c
- | NodeSpec _ -> env
-
- (** [type_node env nd loc] types node [nd] in environment env. The
- location is used for error reports. *)
- and type_node env nd loc =
- (* Format.eprintf "Typing node %s@." nd.node_id; *)
- let is_main = nd.node_id = !Options.main_node in
- (* In contracts, outputs are considered as input values *)
- let vd_env_ol = if nd.node_iscontract then nd.node_locals else nd.node_outputs@nd.node_locals in
- let vd_env = nd.node_inputs@nd.node_outputs@nd.node_locals in
- check_vd_env vd_env;
- let init_env = env in
- let delta_env = type_var_decl_list vd_env init_env nd.node_inputs in
- let delta_env = type_var_decl_list vd_env delta_env nd.node_outputs in
- let delta_env = type_var_decl_list vd_env delta_env nd.node_locals in
- let new_env = Env.overwrite env delta_env in
- let undefined_vars_init =
- List.fold_left
- (fun uvs v -> ISet.add v.var_id uvs)
- ISet.empty vd_env_ol in
- let undefined_vars =
- let eqs, _ = get_node_eqs nd in
- (* TODO XXX: il faut typer les handlers de l'automate *)
- List.fold_left (type_eq (new_env, vd_env) is_main) undefined_vars_init eqs
- in
- (* Typing asserts *)
- List.iter (fun assert_ ->
- let assert_expr = assert_.assert_expr in
- type_subtyping_arg (new_env, vd_env) is_main false assert_expr (* Type_predef. *)type_bool
- ) nd.node_asserts;
- (* Typing spec/contracts *)
- (match nd.node_spec with
- | None -> ()
- | Some spec -> ignore (type_spec new_env spec));
- (* Typing annots *)
- List.iter (fun annot ->
- List.iter (fun (_, eexpr) -> ignore (type_eexpr (new_env, vd_env) eexpr)) annot.annots
- ) nd.node_annot;
-
- (* check that table is empty *)
- let local_consts = List.fold_left (fun res vdecl -> if vdecl.var_dec_const then ISet.add vdecl.var_id res else res) ISet.empty nd.node_locals in
- let undefined_vars = ISet.diff undefined_vars local_consts in
-
- if (not (ISet.is_empty undefined_vars)) then
- raise (Error (loc, Undefined_var undefined_vars));
- let ty_ins = type_of_vlist nd.node_inputs in
- let ty_outs = type_of_vlist nd.node_outputs in
- let ty_node = new_ty (Tarrow (ty_ins,ty_outs)) in
- generalize ty_node;
- (* TODO ? Check that no node in the hierarchy remains polymorphic ? *)
- nd.node_type <- Expr_type_hub.export ty_node;
- Env.add_value env nd.node_id ty_node
-
- let type_imported_node env nd _loc =
- let vd_env = nd.nodei_inputs@nd.nodei_outputs in
- check_vd_env vd_env;
- let delta_env = type_var_decl_list vd_env env nd.nodei_inputs in
- let delta_env = type_var_decl_list vd_env delta_env nd.nodei_outputs in
- let new_env = Env.overwrite env delta_env in
- (* Typing spec *)
- (match nd.nodei_spec with
- | None -> ()
- | Some spec -> ignore (type_spec new_env spec));
- let ty_ins = type_of_vlist nd.nodei_inputs in
- let ty_outs = type_of_vlist nd.nodei_outputs in
- let ty_node = new_ty (Tarrow (ty_ins,ty_outs)) in
- generalize ty_node;
- (*
- if (is_polymorphic ty_node) then
- raise (Error (loc, Poly_imported_node nd.nodei_id));
- *)
- let new_env = Env.add_value env nd.nodei_id ty_node in
- nd.nodei_type <- Expr_type_hub.export ty_node;
- new_env
-
- let type_top_const env cdecl =
- let ty = type_const cdecl.const_loc cdecl.const_value in
- let d =
- if is_dimension_type ty
- then dimension_of_const cdecl.const_loc cdecl.const_value
- else Dimension.mkdim_var () in
- let ty = (* Type_predef. *)type_static d ty in
- let new_env = Env.add_value env cdecl.const_id ty in
- cdecl.const_type <- Expr_type_hub.export ty;
- new_env
-
- let type_top_consts env clist =
- List.fold_left type_top_const env clist
-
- let rec type_top_decl env decl =
+ let get_type_of_call decl =
+ match decl.top_decl_desc with
+ | Node nd ->
+ let in_typ, out_typ = split_arrow (Expr_type_hub.import nd.node_type) in
+ type_list_of_type in_typ, type_list_of_type out_typ
+ | ImportedNode nd ->
+ let in_typ, out_typ = split_arrow (Expr_type_hub.import nd.nodei_type) in
+ type_list_of_type in_typ, type_list_of_type out_typ
+ | _ ->
+ assert false
+
+ let type_prog env decls =
+ try List.fold_left type_top_decl env decls
+ with Failure _ as exc -> raise exc
+
+ (* Once the Lustre program is fully typed, we must get back to the original
+ description of dimensions, with constant parameters, instead of unifiable
+ internal variables. *)
+
+ (* The following functions aims at 'unevaluating' dimension expressions
+ occuring in array types, i.e. replacing unifiable second_order variables
+ with the original static parameters. Once restored in this formulation,
+ dimensions may be meaningfully printed. *)
+ let uneval_vdecl_generics vdecl =
+ if vdecl.var_dec_const then
+ match get_static_value (Expr_type_hub.import vdecl.var_type) with
+ | None ->
+ Format.eprintf "internal error: %a@." (* Types. *) print_ty
+ (Expr_type_hub.import vdecl.var_type);
+ assert false
+ | Some d ->
+ Dimension.uneval vdecl.var_id d
+
+ let uneval_node_generics vdecls = List.iter uneval_vdecl_generics vdecls
+
+ let uneval_spec_generics spec =
+ List.iter uneval_vdecl_generics (spec.consts @ spec.locals)
+
+ let uneval_top_generics decl =
+ match decl.top_decl_desc with
+ | Node nd ->
+ uneval_node_generics (nd.node_inputs @ nd.node_outputs)
+ | ImportedNode nd ->
+ uneval_node_generics (nd.nodei_inputs @ nd.nodei_outputs)
+ | Const _ | TypeDef _ | Open _ | Include _ ->
+ ()
+
+ let uneval_prog_generics prog = List.iter uneval_top_generics prog
+
+ let rec get_imported_symbol decls id =
+ match decls with
+ | [] ->
+ assert false
+ | decl :: q -> (
match decl.top_decl_desc with
- | Node nd -> (
+ | ImportedNode nd when id = nd.nodei_id && decl.top_decl_itf ->
+ decl
+ | Const c when id = c.const_id && decl.top_decl_itf ->
+ decl
+ | TypeDef _ ->
+ get_imported_symbol (consts_of_enum_type decl @ q) id
+ | _ ->
+ get_imported_symbol q id)
+
+ let check_env_compat header declared computed =
+ uneval_prog_generics header;
+ Env.iter declared (fun k decl_type_k ->
+ let top = get_imported_symbol header k in
+ let loc = top.top_decl_loc in
try
- type_node env nd decl.top_decl_loc
- with Error _ as exc -> (
- if !Options.global_inline then
- Format.eprintf "Type error: failing node@.%a@.@?"
- Printers.pp_node nd
- ;
- raise exc)
- )
- | ImportedNode nd ->
- type_imported_node env nd decl.top_decl_loc
- | Const c ->
- type_top_const env c
- | TypeDef _ -> List.fold_left type_top_decl env (consts_of_enum_type decl)
- | Include _ | Open _ -> env
-
- let get_type_of_call decl =
- match decl.top_decl_desc with
- | Node nd ->
- let (in_typ, out_typ) = split_arrow (Expr_type_hub.import nd.node_type) in
- type_list_of_type in_typ, type_list_of_type out_typ
- | ImportedNode nd ->
- let (in_typ, out_typ) = split_arrow (Expr_type_hub.import nd.nodei_type) in
- type_list_of_type in_typ, type_list_of_type out_typ
- | _ -> assert false
-
- let type_prog env decls =
- try
- List.fold_left type_top_decl env decls
- with Failure _ as exc -> raise exc
-
- (* Once the Lustre program is fully typed, we must get back to the
- original description of dimensions, with constant parameters,
- instead of unifiable internal variables. *)
-
- (* The following functions aims at 'unevaluating' dimension
- expressions occuring in array types, i.e. replacing unifiable
- second_order variables with the original static parameters.
- Once restored in this formulation, dimensions may be
- meaningfully printed. *)
- let uneval_vdecl_generics vdecl =
- if vdecl.var_dec_const
- then
- match get_static_value (Expr_type_hub.import vdecl.var_type) with
- | None -> (Format.eprintf "internal error: %a@." (* Types. *)print_ty (Expr_type_hub.import vdecl.var_type); assert false)
- | Some d -> Dimension.uneval vdecl.var_id d
-
- let uneval_node_generics vdecls =
- List.iter uneval_vdecl_generics vdecls
-
- let uneval_spec_generics spec =
- List.iter uneval_vdecl_generics (spec.consts@spec.locals)
-
- let uneval_top_generics decl =
- match decl.top_decl_desc with
- | Node nd ->
- uneval_node_generics (nd.node_inputs @ nd.node_outputs)
- | ImportedNode nd ->
- uneval_node_generics (nd.nodei_inputs @ nd.nodei_outputs)
- | Const _ | TypeDef _ | Open _ | Include _
- -> ()
-
- let uneval_prog_generics prog =
- List.iter uneval_top_generics prog
-
- let rec get_imported_symbol decls id =
- match decls with
- | [] -> assert false
- | decl::q ->
- (match decl.top_decl_desc with
- | ImportedNode nd when id = nd.nodei_id && decl.top_decl_itf -> decl
- | Const c when id = c.const_id && decl.top_decl_itf -> decl
- | TypeDef _ -> get_imported_symbol (consts_of_enum_type decl @ q) id
- | _ -> get_imported_symbol q id)
-
- let check_env_compat header declared computed =
- uneval_prog_generics header;
- Env.iter declared (fun k decl_type_k ->
- let top = get_imported_symbol header k in
- let loc = top.top_decl_loc in
- try
- let computed_t = Env.lookup_value computed k in
- let computed_t = instantiate (ref []) (ref []) computed_t in
- (*Types.print_ty Format.std_formatter decl_type_k;
- Types.print_ty Format.std_formatter computed_t;*)
- try_unify ~sub:true ~semi:true decl_type_k computed_t loc
- with Not_found ->
- begin
- (* If top is a contract we do not require the lustre
- file to provide the same definition. *)
- match top.top_decl_desc with
- | Node nd -> (
- match nd.node_spec with
- | Some (Contract _) -> ()
- | _ -> raise (Error (loc, Declared_but_undefined k))
- )
- | _ ->
- raise (Error (loc, Declared_but_undefined k))
- end
- )
-
- let check_typedef_top decl =
- (*Format.eprintf "check_typedef %a@." Printers.pp_short_decl decl;*)
- (*Format.eprintf "%a" Printers.pp_typedef (typedef_of_top decl);*)
- (*Format.eprintf "%a" Corelang.print_type_table ();*)
- match decl.top_decl_desc with
- | TypeDef ty ->
- let owner = decl.top_decl_owner in
- let itf = decl.top_decl_itf in
- let decl' =
- try Hashtbl.find type_table (Tydec_const (typedef_of_top decl).tydef_id)
- with Not_found -> raise (Error (decl.top_decl_loc, Declared_but_undefined ("type "^ ty.tydef_id))) in
- let owner' = decl'.top_decl_owner in
- (*Format.eprintf "def owner = %s@.decl owner = %s@." owner' owner;*)
- let itf' = decl'.top_decl_itf in
- (match decl'.top_decl_desc with
- | Const _ | Node _ | ImportedNode _ -> assert false
- | TypeDef ty' when coretype_equal ty'.tydef_desc ty.tydef_desc && owner' = owner && itf && (not itf') -> ()
- | _ -> raise (Error (decl.top_decl_loc, Type_mismatch ty.tydef_id)))
- | _ -> ()
-
- let check_typedef_compat header =
- List.iter check_typedef_top header
- end
-
-include Make(Types.Main) (struct
- type type_expr = Types.Main.type_expr
- let import x = x
- let export x = x
- end)
- (* Local Variables: *)
- (* compile-command:"make -C .." *)
+ let computed_t = Env.lookup_value computed k in
+ let computed_t = instantiate (ref []) (ref []) computed_t in
+ (* Types.print_ty Format.std_formatter decl_type_k; Types.print_ty
+ Format.std_formatter computed_t;*)
+ try_unify ~sub:true ~semi:true decl_type_k computed_t loc
+ with Not_found -> (
+ (* If top is a contract we do not require the lustre file to provide
+ the same definition. *)
+ match top.top_decl_desc with
+ | Node nd -> (
+ match nd.node_spec with
+ | Some (Contract _) ->
+ ()
+ | _ ->
+ raise (Error (loc, Declared_but_undefined k)))
+ | _ ->
+ raise (Error (loc, Declared_but_undefined k))))
+
+ let check_typedef_top decl =
+ (*Format.eprintf "check_typedef %a@." Printers.pp_short_decl decl;*)
+ (*Format.eprintf "%a" Printers.pp_typedef (typedef_of_top decl);*)
+ (*Format.eprintf "%a" Corelang.print_type_table ();*)
+ match decl.top_decl_desc with
+ | TypeDef ty -> (
+ let owner = decl.top_decl_owner in
+ let itf = decl.top_decl_itf in
+ let decl' =
+ try Hashtbl.find type_table (Tydec_const (typedef_of_top decl).tydef_id)
+ with Not_found ->
+ raise
+ (Error
+ ( decl.top_decl_loc,
+ Declared_but_undefined ("type " ^ ty.tydef_id) ))
+ in
+ let owner' = decl'.top_decl_owner in
+ (*Format.eprintf "def owner = %s@.decl owner = %s@." owner' owner;*)
+ let itf' = decl'.top_decl_itf in
+ match decl'.top_decl_desc with
+ | Const _ | Node _ | ImportedNode _ ->
+ assert false
+ | TypeDef ty'
+ when coretype_equal ty'.tydef_desc ty.tydef_desc
+ && owner' = owner && itf && not itf' ->
+ ()
+ | _ ->
+ raise (Error (decl.top_decl_loc, Type_mismatch ty.tydef_id)))
+ | _ ->
+ ()
+
+ let check_typedef_compat header = List.iter check_typedef_top header
+end
+
+include
+ Make
+ (Types.Main)
+ (struct
+ type type_expr = Types.Main.type_expr
+
+ let import x = x
+
+ let export x = x
+ end)
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/utils/dimension.ml b/src/utils/dimension.ml
index d97d27d82f372b3197dbd505decb15c0f608cd8a..635cebf3e878a49953ed3448fb7b87d911b7cede 100644
--- a/src/utils/dimension.ml
+++ b/src/utils/dimension.ml
@@ -11,357 +11,379 @@
open Format
-type dim_expr =
- {mutable dim_desc: dim_desc;
- dim_loc: Location.t;
- dim_id: int}
+type dim_expr = {
+ mutable dim_desc : dim_desc;
+ dim_loc : Location.t;
+ dim_id : int;
+}
and dim_desc =
-| Dbool of bool
-| Dint of int
-| Dident of Utils.ident
-| Dappl of Utils.ident * dim_expr list
-| Dite of dim_expr * dim_expr * dim_expr
-| Dlink of dim_expr
-| Dvar
-| Dunivar
+ | Dbool of bool
+ | Dint of int
+ | Dident of Utils.ident
+ | Dappl of Utils.ident * dim_expr list
+ | Dite of dim_expr * dim_expr * dim_expr
+ | Dlink of dim_expr
+ | Dvar
+ | Dunivar
exception Unify of dim_expr * dim_expr
+
exception InvalidDimension
let new_id = ref (-1)
let mkdim loc dim =
incr new_id;
- { dim_loc = loc;
- dim_id = !new_id;
- dim_desc = dim;}
+ { dim_loc = loc; dim_id = !new_id; dim_desc = dim }
let mkdim_var () =
incr new_id;
- { dim_loc = Location.dummy_loc;
- dim_id = !new_id;
- dim_desc = Dvar;}
+ { dim_loc = Location.dummy_loc; dim_id = !new_id; dim_desc = Dvar }
let mkdim_ident loc id =
incr new_id;
- { dim_loc = loc;
- dim_id = !new_id;
- dim_desc = Dident id;}
+ { dim_loc = loc; dim_id = !new_id; dim_desc = Dident id }
let mkdim_bool loc b =
incr new_id;
- { dim_loc = loc;
- dim_id = !new_id;
- dim_desc = Dbool b;}
+ { dim_loc = loc; dim_id = !new_id; dim_desc = Dbool b }
let mkdim_int loc i =
incr new_id;
- { dim_loc = loc;
- dim_id = !new_id;
- dim_desc = Dint i;}
+ { dim_loc = loc; dim_id = !new_id; dim_desc = Dint i }
let mkdim_appl loc f args =
incr new_id;
- { dim_loc = loc;
- dim_id = !new_id;
- dim_desc = Dappl (f, args);}
+ { dim_loc = loc; dim_id = !new_id; dim_desc = Dappl (f, args) }
let mkdim_ite loc i t e =
incr new_id;
- { dim_loc = loc;
- dim_id = !new_id;
- dim_desc = Dite (i, t, e);}
+ { dim_loc = loc; dim_id = !new_id; dim_desc = Dite (i, t, e) }
let rec pp_dimension fmt dim =
-(*fprintf fmt "<%d>" (Obj.magic dim: int);*)
- match dim.dim_desc with
- | Dident id ->
- fprintf fmt "%s" id
- | Dint i ->
- fprintf fmt "%d" i
- | Dbool b ->
- fprintf fmt "%B" b
- | Dite (i, t, e) ->
- fprintf fmt "if %a then %a else %a"
- pp_dimension i pp_dimension t pp_dimension e
- | Dappl (f, [arg]) ->
- fprintf fmt "(%s%a)" f pp_dimension arg
- | Dappl (f, [arg1; arg2]) ->
- fprintf fmt "(%a%s%a)" pp_dimension arg1 f pp_dimension arg2
- | Dappl (_, _) -> assert false
- | Dlink dim' -> fprintf fmt "%a" pp_dimension dim'
- | Dvar -> fprintf fmt "_%s" (Utils.name_of_dimension dim.dim_id)
- | Dunivar -> fprintf fmt "'%s" (Utils.name_of_dimension dim.dim_id)
+ (*fprintf fmt "<%d>" (Obj.magic dim: int);*)
+ match dim.dim_desc with
+ | Dident id ->
+ fprintf fmt "%s" id
+ | Dint i ->
+ fprintf fmt "%d" i
+ | Dbool b ->
+ fprintf fmt "%B" b
+ | Dite (i, t, e) ->
+ fprintf fmt "if %a then %a else %a" pp_dimension i pp_dimension t
+ pp_dimension e
+ | Dappl (f, [ arg ]) ->
+ fprintf fmt "(%s%a)" f pp_dimension arg
+ | Dappl (f, [ arg1; arg2 ]) ->
+ fprintf fmt "(%a%s%a)" pp_dimension arg1 f pp_dimension arg2
+ | Dappl (_, _) ->
+ assert false
+ | Dlink dim' ->
+ fprintf fmt "%a" pp_dimension dim'
+ | Dvar ->
+ fprintf fmt "_%s" (Utils.name_of_dimension dim.dim_id)
+ | Dunivar ->
+ fprintf fmt "'%s" (Utils.name_of_dimension dim.dim_id)
let rec multi_dimension_product loc dim_list =
- match dim_list with
- | [] -> mkdim_int loc 1
- | [d] -> d
- | d::q -> mkdim_appl loc "*" [d; multi_dimension_product loc q]
+ match dim_list with
+ | [] ->
+ mkdim_int loc 1
+ | [ d ] ->
+ d
+ | d :: q ->
+ mkdim_appl loc "*" [ d; multi_dimension_product loc q ]
(* Builds a dimension expr representing 0<=d *)
-let check_bound loc d =
- mkdim_appl loc "<=" [mkdim_int loc 0; d]
+let check_bound loc d = mkdim_appl loc "<=" [ mkdim_int loc 0; d ]
(* Builds a dimension expr representing 0<=i<d *)
let check_access loc d i =
- mkdim_appl loc "&&"
- [mkdim_appl loc "<=" [mkdim_int loc 0; i];
- mkdim_appl loc "<" [i; d]]
+ mkdim_appl loc "&&"
+ [ mkdim_appl loc "<=" [ mkdim_int loc 0; i ]; mkdim_appl loc "<" [ i; d ] ]
-let rec repr dim =
- match dim.dim_desc with
- | Dlink dim' -> repr dim'
- | _ -> dim
+let rec repr dim = match dim.dim_desc with Dlink dim' -> repr dim' | _ -> dim
let rec is_eq_dimension d1 d2 =
let d1 = repr d1 in
let d2 = repr d2 in
- d1.dim_id = d2.dim_id ||
+ d1.dim_id = d2.dim_id
+ ||
match d1.dim_desc, d2.dim_desc with
| Dappl (f1, args1), Dappl (f2, args2) ->
- f1 = f2 && List.length args1 = List.length args2 && List.for_all2 is_eq_dimension args1 args2
+ f1 = f2
+ && List.length args1 = List.length args2
+ && List.for_all2 is_eq_dimension args1 args2
| Dite (c1, t1, e1), Dite (c2, t2, e2) ->
is_eq_dimension c1 c2 && is_eq_dimension t1 t2 && is_eq_dimension e1 e2
- | Dint i1 , Dint i2 -> i1 = i2
- | Dbool b1 , Dbool b2 -> b1 = b2
- | Dident id1, Dident id2 -> id1 = id2
- | _ -> false
+ | Dint i1, Dint i2 ->
+ i1 = i2
+ | Dbool b1, Dbool b2 ->
+ b1 = b2
+ | Dident id1, Dident id2 ->
+ id1 = id2
+ | _ ->
+ false
let is_dimension_const dim =
- match (repr dim).dim_desc with
- | Dint _
- | Dbool _ -> true
- | _ -> false
+ match (repr dim).dim_desc with Dint _ | Dbool _ -> true | _ -> false
let size_const_dimension dim =
match (repr dim).dim_desc with
- | Dint i -> i
- | Dbool b -> if b then 1 else 0
- | _ -> (Format.eprintf "internal error: size_const_dimension %a@." pp_dimension dim; assert false)
+ | Dint i ->
+ i
+ | Dbool b ->
+ if b then 1 else 0
+ | _ ->
+ Format.eprintf "internal error: size_const_dimension %a@." pp_dimension dim;
+ assert false
let rec is_polymorphic dim =
match dim.dim_desc with
- | Dident _
- | Dint _
- | Dbool _
- | Dvar -> false
- | Dite (i, t, e) ->
- is_polymorphic i || is_polymorphic t || is_polymorphic e
- | Dappl (_, args) -> List.exists is_polymorphic args
- | Dlink dim' -> is_polymorphic dim'
- | Dunivar -> true
+ | Dident _ | Dint _ | Dbool _ | Dvar ->
+ false
+ | Dite (i, t, e) ->
+ is_polymorphic i || is_polymorphic t || is_polymorphic e
+ | Dappl (_, args) ->
+ List.exists is_polymorphic args
+ | Dlink dim' ->
+ is_polymorphic dim'
+ | Dunivar ->
+ true
(* Normalizes a dimension expression, i.e. canonicalize all polynomial
- sub-expressions, where unsupported operations (eg. '/') are treated
- as variables.
-*)
+ sub-expressions, where unsupported operations (eg. '/') are treated as
+ variables. *)
let rec factors dim =
match dim.dim_desc with
- | Dappl (f, args) when f = "*" -> List.flatten (List.map factors args)
- | _ -> [dim]
+ | Dappl (f, args) when f = "*" ->
+ List.flatten (List.map factors args)
+ | _ ->
+ [ dim ]
let rec factors_constant fs =
match fs with
- | [] -> 1
- | f::q ->
+ | [] ->
+ 1
+ | f :: q -> (
match f.dim_desc with
- | Dint i -> i * (factors_constant q)
- | _ -> factors_constant q
+ | Dint i ->
+ i * factors_constant q
+ | _ ->
+ factors_constant q)
let norm_factors fs =
let k = factors_constant fs in
let nk = List.filter (fun d -> not (is_dimension_const d)) fs in
- (k, List.sort compare nk)
+ k, List.sort compare nk
let rec terms dim =
- match dim.dim_desc with
- | Dappl (f, args) when f = "+" -> List.flatten (List.map terms args)
- | _ -> [dim]
-
-let normalize dim =
- dim
-(*
-let rec unnormalize loc l =
- let l = List.sort (fun (k, l) (k', l') -> compare l l') (List.map (fun (k, l) -> (k, List.sort compare l)) l) in
- match l with
- | [] -> mkdim_int loc 0
- | t::q ->
- List.fold_left (fun res (k, l) -> mkdim_appl loc "+" res (mkdim_appl loc "*" (mkdim_int loc k) l)) t q
-*)
-let copy copy_dim_vars dim =
- let rec cp dim =
match dim.dim_desc with
- | Dbool _
- | Dint _ -> dim
- | Dident id -> mkdim_ident dim.dim_loc id
- | Dite (c, t, e) -> mkdim_ite dim.dim_loc (cp c) (cp t) (cp e)
- | Dappl (id, args) -> mkdim_appl dim.dim_loc id (List.map cp args)
- | Dlink dim' -> cp dim'
- | Dunivar -> assert false
- | Dvar ->
- try
- List.assoc dim.dim_id !copy_dim_vars
- with Not_found ->
- let var = mkdim dim.dim_loc Dvar in
- copy_dim_vars := (dim.dim_id, var)::!copy_dim_vars;
- var
- in cp dim
+ | Dappl (f, args) when f = "+" ->
+ List.flatten (List.map terms args)
+ | _ ->
+ [ dim ]
+
+let normalize dim = dim
-(* Partially evaluates a 'simple' dimension expr [dim], i.e. an expr containing only int and bool
- constructs, with conditionals. [eval_const] is a typing environment for static values. [eval_op] is an evaluation env for basic operators. The argument [dim] is modified in-place.
-*)
+(* let rec unnormalize loc l = let l = List.sort (fun (k, l) (k', l') -> compare
+ l l') (List.map (fun (k, l) -> (k, List.sort compare l)) l) in match l with |
+ [] -> mkdim_int loc 0 | t::q -> List.fold_left (fun res (k, l) -> mkdim_appl
+ loc "+" res (mkdim_appl loc "*" (mkdim_int loc k) l)) t q *)
+let copy copy_dim_vars dim =
+ let rec cp dim =
+ match dim.dim_desc with
+ | Dbool _ | Dint _ ->
+ dim
+ | Dident id ->
+ mkdim_ident dim.dim_loc id
+ | Dite (c, t, e) ->
+ mkdim_ite dim.dim_loc (cp c) (cp t) (cp e)
+ | Dappl (id, args) ->
+ mkdim_appl dim.dim_loc id (List.map cp args)
+ | Dlink dim' ->
+ cp dim'
+ | Dunivar ->
+ assert false
+ | Dvar -> (
+ try List.assoc dim.dim_id !copy_dim_vars
+ with Not_found ->
+ let var = mkdim dim.dim_loc Dvar in
+ copy_dim_vars := (dim.dim_id, var) :: !copy_dim_vars;
+ var)
+ in
+ cp dim
+
+(* Partially evaluates a 'simple' dimension expr [dim], i.e. an expr containing
+ only int and bool constructs, with conditionals. [eval_const] is a typing
+ environment for static values. [eval_op] is an evaluation env for basic
+ operators. The argument [dim] is modified in-place. *)
let rec eval eval_op eval_const dim =
match dim.dim_desc with
- | Dbool _
- | Dint _ -> ()
- | Dident id ->
- (match eval_const id with
- | Some val_dim -> dim.dim_desc <- Dlink val_dim
- | None -> (Format.eprintf "invalid %a@." pp_dimension dim; raise InvalidDimension))
- | Dite (c, t, e) ->
- begin
- eval eval_op eval_const c;
- eval eval_op eval_const t;
- eval eval_op eval_const e;
- match (repr c).dim_desc with
- | Dbool b -> dim.dim_desc <- Dlink (if b then t else e)
- | _ -> ()
- end
+ | Dbool _ | Dint _ ->
+ ()
+ | Dident id -> (
+ match eval_const id with
+ | Some val_dim ->
+ dim.dim_desc <- Dlink val_dim
+ | None ->
+ Format.eprintf "invalid %a@." pp_dimension dim;
+ raise InvalidDimension)
+ | Dite (c, t, e) -> (
+ eval eval_op eval_const c;
+ eval eval_op eval_const t;
+ eval eval_op eval_const e;
+ match (repr c).dim_desc with
+ | Dbool b ->
+ dim.dim_desc <- Dlink (if b then t else e)
+ | _ ->
+ ())
| Dappl (id, args) ->
- begin
- List.iter (eval eval_op eval_const) args;
- if List.for_all is_dimension_const args
- then dim.dim_desc <- Env.lookup_value eval_op id (List.map (fun d -> (repr d).dim_desc) args)
- end
+ List.iter (eval eval_op eval_const) args;
+ if List.for_all is_dimension_const args then
+ dim.dim_desc <-
+ Env.lookup_value eval_op id (List.map (fun d -> (repr d).dim_desc) args)
| Dlink dim' ->
- begin
- eval eval_op eval_const dim';
- dim.dim_desc <- Dlink (repr dim')
- end
- | Dvar -> ()
- | Dunivar -> assert false
+ eval eval_op eval_const dim';
+ dim.dim_desc <- Dlink (repr dim')
+ | Dvar ->
+ ()
+ | Dunivar ->
+ assert false
let uneval const univar =
let univar = repr univar in
match univar.dim_desc with
- | Dunivar -> univar.dim_desc <- Dident const
- | _ -> assert false
+ | Dunivar ->
+ univar.dim_desc <- Dident const
+ | _ ->
+ assert false
(** [occurs dvar dim] returns true if the dimension variable [dvar] occurs in
dimension expression [dim]. False otherwise. *)
let rec occurs dvar dim =
let dim = repr dim in
match dim.dim_desc with
- | Dvar -> dim.dim_id = dvar.dim_id
- | Dident _
- | Dint _
- | Dbool _
- | Dunivar -> false
- | Dite (i, t, e) ->
- occurs dvar i || occurs dvar t || occurs dvar e
- | Dappl (_, args) -> List.exists (occurs dvar) args
- | Dlink _ -> assert false
-
-(* Promote monomorphic dimension variables to polymorphic variables.
- Generalize by side-effects *)
+ | Dvar ->
+ dim.dim_id = dvar.dim_id
+ | Dident _ | Dint _ | Dbool _ | Dunivar ->
+ false
+ | Dite (i, t, e) ->
+ occurs dvar i || occurs dvar t || occurs dvar e
+ | Dappl (_, args) ->
+ List.exists (occurs dvar) args
+ | Dlink _ ->
+ assert false
+
+(* Promote monomorphic dimension variables to polymorphic variables. Generalize
+ by side-effects *)
let rec generalize dim =
match dim.dim_desc with
- | Dvar -> dim.dim_desc <- Dunivar
- | Dident _
- | Dint _
- | Dbool _
- | Dunivar -> ()
- | Dite (i, t, e) ->
- generalize i; generalize t; generalize e
- | Dappl (_, args) -> List.iter generalize args
- | Dlink dim' -> generalize dim'
-
-(* Instantiate polymorphic dimension variables to monomorphic variables.
- Also duplicates the whole term structure (but the constant sub-terms).
-*)
+ | Dvar ->
+ dim.dim_desc <- Dunivar
+ | Dident _ | Dint _ | Dbool _ | Dunivar ->
+ ()
+ | Dite (i, t, e) ->
+ generalize i;
+ generalize t;
+ generalize e
+ | Dappl (_, args) ->
+ List.iter generalize args
+ | Dlink dim' ->
+ generalize dim'
+
+(* Instantiate polymorphic dimension variables to monomorphic variables. Also
+ duplicates the whole term structure (but the constant sub-terms). *)
let rec instantiate inst_dim_vars dim =
let dim = repr dim in
match dim.dim_desc with
- | Dvar
- | Dident _
- | Dint _
- | Dbool _ -> dim
- | Dite (i, t, e) ->
- mkdim_ite dim.dim_loc
- (instantiate inst_dim_vars i)
- (instantiate inst_dim_vars t)
- (instantiate inst_dim_vars e)
- | Dappl (f, args) -> mkdim_appl dim.dim_loc f (List.map (instantiate inst_dim_vars) args)
- | Dlink _ -> assert false (*mkdim dim.dim_loc (Dlink (instantiate inst_dim_vars dim'))*)
- | Dunivar ->
- try
- List.assoc dim.dim_id !inst_dim_vars
- with Not_found ->
- let var = mkdim dim.dim_loc Dvar in
- inst_dim_vars := (dim.dim_id, var)::!inst_dim_vars;
- var
-
-(** destructive unification of [dim1] and [dim2].
- Raises [Unify (t1,t2)] if the types are not unifiable.
- if [semi] unification is required,
- [dim1] should furthermore be an instance of [dim2] *)
-let unify ?(semi=false) dim1 dim2 =
+ | Dvar | Dident _ | Dint _ | Dbool _ ->
+ dim
+ | Dite (i, t, e) ->
+ mkdim_ite dim.dim_loc
+ (instantiate inst_dim_vars i)
+ (instantiate inst_dim_vars t)
+ (instantiate inst_dim_vars e)
+ | Dappl (f, args) ->
+ mkdim_appl dim.dim_loc f (List.map (instantiate inst_dim_vars) args)
+ | Dlink _ ->
+ assert false (*mkdim dim.dim_loc (Dlink (instantiate inst_dim_vars dim'))*)
+ | Dunivar -> (
+ try List.assoc dim.dim_id !inst_dim_vars
+ with Not_found ->
+ let var = mkdim dim.dim_loc Dvar in
+ inst_dim_vars := (dim.dim_id, var) :: !inst_dim_vars;
+ var)
+
+(** destructive unification of [dim1] and [dim2]. Raises [Unify (t1,t2)] if the
+ types are not unifiable. if [semi] unification is required, [dim1] should
+ furthermore be an instance of [dim2] *)
+let unify ?(semi = false) dim1 dim2 =
let rec unif dim1 dim2 =
let dim1 = repr dim1 in
let dim2 = repr dim2 in
- if dim1.dim_id = dim2.dim_id then () else
+ if dim1.dim_id = dim2.dim_id then ()
+ else
match dim1.dim_desc, dim2.dim_desc with
- | Dunivar, _
- | _ , Dunivar -> assert false
- | Dvar , Dvar ->
- if dim1.dim_id < dim2.dim_id
- then dim2.dim_desc <- Dlink dim1
- else dim1.dim_desc <- Dlink dim2
- | Dvar , _ when (not semi) && not (occurs dim1 dim2) ->
- dim1.dim_desc <- Dlink dim2
- | _ , Dvar when not (occurs dim2 dim1) ->
- dim2.dim_desc <- Dlink dim1
- | Dite(i1, t1, e1), Dite(i2, t2, e2) ->
- begin
- unif i1 i2;
- unif t1 t2;
- unif e1 e2
- end
- | Dappl(f1, args1), Dappl(f2, args2) when f1 = f2 && List.length args1 = List.length args2 ->
- List.iter2 unif args1 args2
- | Dbool b1, Dbool b2 when b1 = b2 -> ()
- | Dint i1 , Dint i2 when i1 = i2 -> ()
- | Dident id1, Dident id2 when id1 = id2 -> ()
- | _ -> raise (Unify (dim1, dim2))
- in unif dim1 dim2
-
-let rec rename fnode fvar e =
- { e with dim_desc = expr_replace_var_desc fnode fvar e.dim_desc }
+ | Dunivar, _ | _, Dunivar ->
+ assert false
+ | Dvar, Dvar ->
+ if dim1.dim_id < dim2.dim_id then dim2.dim_desc <- Dlink dim1
+ else dim1.dim_desc <- Dlink dim2
+ | Dvar, _ when (not semi) && not (occurs dim1 dim2) ->
+ dim1.dim_desc <- Dlink dim2
+ | _, Dvar when not (occurs dim2 dim1) ->
+ dim2.dim_desc <- Dlink dim1
+ | Dite (i1, t1, e1), Dite (i2, t2, e2) ->
+ unif i1 i2;
+ unif t1 t2;
+ unif e1 e2
+ | Dappl (f1, args1), Dappl (f2, args2)
+ when f1 = f2 && List.length args1 = List.length args2 ->
+ List.iter2 unif args1 args2
+ | Dbool b1, Dbool b2 when b1 = b2 ->
+ ()
+ | Dint i1, Dint i2 when i1 = i2 ->
+ ()
+ | Dident id1, Dident id2 when id1 = id2 ->
+ ()
+ | _ ->
+ raise (Unify (dim1, dim2))
+ in
+ unif dim1 dim2
+
+let rec rename fnode fvar e =
+ { e with dim_desc = expr_replace_var_desc fnode fvar e.dim_desc }
+
and expr_replace_var_desc fnode fvar e =
let re = rename fnode fvar in
match e with
- | Dvar
- | Dunivar
- | Dbool _
- | Dint _ -> e
- | Dident v -> Dident (fvar v)
- | Dappl (id, el) -> Dappl (fnode id, List.map re el)
- | Dite (g,t,e) -> Dite (re g, re t, re e)
- | Dlink e -> Dlink (re e)
-
-let rec expr_replace_expr fvar e =
- { e with dim_desc = expr_replace_expr_desc fvar e.dim_desc }
+ | Dvar | Dunivar | Dbool _ | Dint _ ->
+ e
+ | Dident v ->
+ Dident (fvar v)
+ | Dappl (id, el) ->
+ Dappl (fnode id, List.map re el)
+ | Dite (g, t, e) ->
+ Dite (re g, re t, re e)
+ | Dlink e ->
+ Dlink (re e)
+
+let rec expr_replace_expr fvar e =
+ { e with dim_desc = expr_replace_expr_desc fvar e.dim_desc }
+
and expr_replace_expr_desc fvar e =
let re = expr_replace_expr fvar in
match e with
- | Dvar
- | Dunivar
- | Dbool _
- | Dint _ -> e
- | Dident v -> (fvar v).dim_desc
- | Dappl (id, el) -> Dappl (id, List.map re el)
- | Dite (g,t,e) -> Dite (re g, re t, re e)
- | Dlink e -> Dlink (re e)
+ | Dvar | Dunivar | Dbool _ | Dint _ ->
+ e
+ | Dident v ->
+ (fvar v).dim_desc
+ | Dappl (id, el) ->
+ Dappl (id, List.map re el)
+ | Dite (g, t, e) ->
+ Dite (re g, re t, re e)
+ | Dlink e ->
+ Dlink (re e)
diff --git a/src/utils/dune b/src/utils/dune
index 064da44eb7f1c433b838d5ddd5070f3920df0ce4..881046aa777f0b8d27a39afc1f8c7c03e0b831e3 100644
--- a/src/utils/dune
+++ b/src/utils/dune
@@ -3,13 +3,18 @@
(rule
(target ocaml_utils.ml)
(deps ocaml_utils.ml.lt403)
- (action (copy %{deps} %{target}))
- (enabled_if (< %{ocaml_version} 4.0.3)))
+ (action
+ (copy %{deps} %{target}))
+ (enabled_if
+ (< %{ocaml_version} 4.0.3)))
+
(rule
(target ocaml_utils.ml)
(deps ocaml_utils.ml.ge403)
- (action (copy %{deps} %{target}))
- (enabled_if (>= %{ocaml_version} 4.0.3)))
+ (action
+ (copy %{deps} %{target}))
+ (enabled_if
+ (>= %{ocaml_version} 4.0.3)))
; (library
; (name utils)
diff --git a/src/utils/env.ml b/src/utils/env.ml
index 687be6418251336c575fc677a86ec906582f6bc7..d4e03231350f39e3ecd65a780dc4e94d73a68bec 100644
--- a/src/utils/env.ml
+++ b/src/utils/env.ml
@@ -9,41 +9,35 @@
(* *)
(********************************************************************)
-(** Generic inference environments. Used both for typing and
- clock-calculus. *)
open Utils
+(** Generic inference environments. Used both for typing and clock-calculus. *)
+
+type 'a t = 'a IMap.t
-type 'a t = 'a IMap.t
(* Same namespace for nodes, variables and constants *)
let initial = IMap.empty
-let add_value env ident ty =
- IMap.add ident ty env
+let add_value env ident ty = IMap.add ident ty env
-let lookup_value env ident =
- IMap.find ident env
+let lookup_value env ident = IMap.find ident env
-let exists_value env ident =
- IMap.mem ident env
+let exists_value env ident = IMap.mem ident env
let iter env f = IMap.iter f env
+
let fold = IMap.fold
-(* Merges x and y. In case of conflicting definitions,
- overwrites definitions in x by definitions in y *)
+(* Merges x and y. In case of conflicting definitions, overwrites definitions in
+ x by definitions in y *)
let overwrite x y =
- IMap.merge (
- fun _ _old _new -> match _new with
- | Some _ -> _new
- | _ -> _old
- ) x y
+ IMap.merge
+ (fun _ _old _new -> match _new with Some _ -> _new | _ -> _old)
+ x y
let pp_env pp_fun fmt env =
- let (lid,lty) = list_of_imap env in
+ let lid, lty = list_of_imap env in
let l' = List.combine lid lty in
- let pp_fun fmt (id,value) =
- Format.fprintf fmt "%s |-> %a" id pp_fun value
- in
+ let pp_fun fmt (id, value) = Format.fprintf fmt "%s |-> %a" id pp_fun value in
Format.fprintf fmt "{ @[<v 2>%a@] }" (fprintf_list ~sep:"@," pp_fun) l'
(* Local Variables: *)
diff --git a/src/utils/location.ml b/src/utils/location.ml
index 1dc09791bb92862fe81ca53fba84d3eccc27fdce..58069a152d4af89be7f03db3ea1fe7a7b87a7330 100644
--- a/src/utils/location.ml
+++ b/src/utils/location.ml
@@ -10,7 +10,6 @@
(********************************************************************)
open Lexing
-
module Lex = MenhirLib.LexerUtil
type t = position * position
@@ -22,18 +21,17 @@ let dummy_loc = dummy_pos, dummy_pos
let set_input, get_input, get_module =
let input_name : filename ref = ref "__UNINITIALIZED__" in
let module_name : filename ref = ref "__UNINITIALIZED__" in
- (fun name -> input_name := name; module_name := Filename.chop_extension name),
- (fun () -> !input_name),
- (fun () -> !module_name)
+ ( (fun name ->
+ input_name := name;
+ module_name := Filename.chop_extension name),
+ (fun () -> !input_name),
+ fun () -> !module_name )
-let curr lexbuf =
- lexbuf.lex_start_p, lexbuf.lex_curr_p
+let curr lexbuf = lexbuf.lex_start_p, lexbuf.lex_curr_p
-let filename_of_loc (s, _) =
- s.pos_fname
+let filename_of_loc (s, _) = s.pos_fname
-let filename_of_lexbuf lexbuf =
- lexbuf.lex_start_p.pos_fname
+let filename_of_lexbuf lexbuf = lexbuf.lex_start_p.pos_fname
(* let init lexbuf fname =
* lexbuf.Lexing.lex_curr_p <- {
@@ -49,19 +47,16 @@ let shift_pos pos1 pos2 =
{
pos_fname = pos1.pos_fname;
pos_lnum = pos1.pos_lnum + pos2.pos_lnum - 1;
-
(* New try *)
(* pos_bol = pos2.pos_bol; *)
pos_bol = pos1.pos_bol + pos2.pos_bol;
- pos_cnum = pos1.pos_cnum + pos2.pos_cnum
- (* pos_cnum = pos2.pos_cnum; *)
- (*
- pos_bol = pos1.pos_bol + pos2.pos_bol;
- pos_cnum =if pos2.pos_lnum = 1 then pos1.pos_cnum + pos2.pos_cnum else pos2.pos_cnum
- *)
+ pos_cnum =
+ pos1.pos_cnum + pos2.pos_cnum
+ (* pos_cnum = pos2.pos_cnum; *)
+ (* pos_bol = pos1.pos_bol + pos2.pos_bol; pos_cnum =if pos2.pos_lnum = 1
+ then pos1.pos_cnum + pos2.pos_cnum else pos2.pos_cnum *);
}
-
(* let print loc =
* let filename = loc.loc_start.pos_fname in
* let line = loc.loc_start.pos_lnum in
@@ -84,21 +79,16 @@ let shift_pos pos1 pos2 =
* print_newline () *)
let loc_line (s, _e) = s.pos_lnum
-
+
let pp_loc fmt loc =
- if loc == dummy_loc then
- ()
- else
- Format.fprintf fmt "%s" (Lex.range loc)
+ if loc == dummy_loc then () else Format.fprintf fmt "%s" (Lex.range loc)
let pp_c_loc fmt (s, _e) =
let filename = s.pos_fname in
let line = s.pos_lnum in
Format.fprintf fmt "#line %i \"%s\"" line filename
-let shift (_s1, e1) (s2, e2) =
- shift_pos e1 s2,
- shift_pos e1 e2
+let shift (_s1, e1) (s2, e2) = shift_pos e1 s2, shift_pos e1 e2
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/utils/utils.ml b/src/utils/utils.ml
index df6e0bb894440cc864fb20a00c22be94d87f5de7..ef930561f58d3945ec615a61cc27ef2cdbfa51a9 100644
--- a/src/utils/utils.ml
+++ b/src/utils/utils.ml
@@ -11,12 +11,15 @@
open Graph
-type rat = int*int
+type rat = int * int
+
type ident = string
+
type tag = int
+
type longident = (string * tag) list
-exception TransposeError of int*int
+exception TransposeError of int * int
(** General utility functions. *)
let create_hashtable size init =
@@ -24,134 +27,138 @@ let create_hashtable size init =
List.iter (fun (key, data) -> Hashtbl.add tbl key data) init;
tbl
-module IdentModule =
-struct (* Node module *)
+module IdentModule = struct
+ (* Node module *)
type t = ident
+
let compare = compare
+
let hash n = Hashtbl.hash n
+
let equal n1 n2 = n1 = n2
end
module IMap = struct
- include Map.Make(IdentModule)
+ include Map.Make (IdentModule)
+
let union_l m1 m2 =
- merge (fun _ o1 o2 -> match o1, o2 with
- | None, None -> None
- | Some _, _ -> o1
- | _, Some _ -> o2) m1 m2
+ merge
+ (fun _ o1 o2 ->
+ match o1, o2 with
+ | None, None ->
+ None
+ | Some _, _ ->
+ o1
+ | _, Some _ ->
+ o2)
+ m1 m2
end
-module ISet = Set.Make(IdentModule)
+module ISet = Set.Make (IdentModule)
module IdentDepGraph = Imperative.Digraph.ConcreteBidirectional (IdentModule)
-module TopologicalDepGraph = Topological.Make(IdentDepGraph)
-module ComponentsDepGraph = Components.Make(IdentDepGraph)
-
+module TopologicalDepGraph = Topological.Make (IdentDepGraph)
+module ComponentsDepGraph = Components.Make (IdentDepGraph)
+
(*module DotGraph = Graphviz.Dot (IdentDepGraph)*)
module Bfs = Traverse.Bfs (IdentDepGraph)
-
exception DeSome
+
let desome x = match x with Some x -> x | None -> raise DeSome
-let option_map f o =
- match o with
- | None -> None
- | Some e -> Some (f e)
+let option_map f o = match o with None -> None | Some e -> Some (f e)
-let add_cons x l =
- if List.mem x l then l else x::l
+let add_cons x l = if List.mem x l then l else x :: l
let rec remove_duplicates l =
- match l with
- | [] -> []
- | t::q -> add_cons t (remove_duplicates q)
+ match l with [] -> [] | t :: q -> add_cons t (remove_duplicates q)
let position pred l =
let rec pos p l =
match l with
- | [] -> assert false
- | t::q -> if pred t then p else pos (p+1) q
- in pos 0 l
+ | [] ->
+ assert false
+ | t :: q ->
+ if pred t then p else pos (p + 1) q
+ in
+ pos 0 l
(* TODO: Lélio: why n+1? cf former def below *)
(* if n < 0 then [] else x :: duplicate x (n - 1) *)
-let duplicate x n = List.init (n+1) (fun _ -> x)
+let duplicate x n = List.init (n + 1) (fun _ -> x)
let enumerate n = List.init n (fun i -> i)
-let rec repeat n f x =
- if n <= 0 then x else repeat (n-1) f (f x)
+let rec repeat n f x = if n <= 0 then x else repeat (n - 1) f (f x)
let transpose_list ll =
let rec transpose ll =
match ll with
- | [] -> []
- | [l] -> List.map (fun el -> [el]) l
- | l::q -> List.map2 (fun el eq -> el::eq) l (transpose q)
- in match ll with
- | [] -> []
- | l::q -> let length_l = List.length l in
- List.iter (fun l' -> let length_l' = List.length l'
- in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q;
+ | [] ->
+ []
+ | [ l ] ->
+ List.map (fun el -> [ el ]) l
+ | l :: q ->
+ List.map2 (fun el eq -> el :: eq) l (transpose q)
+ in
+ match ll with
+ | [] ->
+ []
+ | l :: q ->
+ let length_l = List.length l in
+ List.iter
+ (fun l' ->
+ let length_l' = List.length l' in
+ if length_l <> length_l' then
+ raise (TransposeError (length_l, length_l')))
+ q;
transpose ll
let rec filter_upto p n l =
- if n = 0 then [] else
- match l with
- | [] -> []
- | t::q -> if p t then t :: filter_upto p (n-1) q else filter_upto p n q
+ if n = 0 then []
+ else
+ match l with
+ | [] ->
+ []
+ | t :: q ->
+ if p t then t :: filter_upto p (n - 1) q else filter_upto p n q
(* Warning: bad complexity *)
let list_of_imap imap =
- IMap.fold (fun i v (il,vl) -> (i::il,v::vl)) imap ([],[])
+ IMap.fold (fun i v (il, vl) -> i :: il, v :: vl) imap ([], [])
(** [gcd a b] returns the greatest common divisor of [a] and [b]. *)
-let rec gcd a b =
- if b = 0 then a
- else gcd b (a mod b)
+let rec gcd a b = if b = 0 then a else gcd b (a mod b)
(** [lcm a b] returns the least common multiple of [a] and [b]. *)
-let lcm a b =
- if a = 0 && b = 0 then
- 0
- else a*b/(gcd a b)
-
-(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and
- [(a',b')] *)
-let sum_rat (a,b) (a',b') =
- if a = 0 && b = 0 then
- (a',b')
- else if a'=0 && b'=0 then
- (a,b)
+let lcm a b = if a = 0 && b = 0 then 0 else a * b / gcd a b
+
+(** [sum_rat (a,b) (a',b')] returns the sum of rationals [(a,b)] and [(a',b')] *)
+let sum_rat (a, b) (a', b') =
+ if a = 0 && b = 0 then a', b'
+ else if a' = 0 && b' = 0 then a, b
else
let lcm_bb' = lcm b b' in
- (a*lcm_bb'/b+a'*lcm_bb'/b',lcm_bb')
+ (a * lcm_bb' / b) + (a' * lcm_bb' / b'), lcm_bb'
-let simplify_rat (a,b) =
+let simplify_rat (a, b) =
let gcd = gcd a b in
- if (gcd =0) then
- (a,b)
- else (a/gcd,b/gcd)
-
-let max_rat (a,b) (a',b') =
- let ratio_ab = (float_of_int a)/.(float_of_int b) in
- let ratio_ab' = (float_of_int a')/.(float_of_int b') in
- if ratio_ab > ratio_ab' then
- (a,b)
- else
- (a',b')
+ if gcd = 0 then a, b else a / gcd, b / gcd
-(** [list_union l1 l2] returns the union of list [l1] and [l2]. The
- result contains no duplicates. *)
+let max_rat (a, b) (a', b') =
+ let ratio_ab = float_of_int a /. float_of_int b in
+ let ratio_ab' = float_of_int a' /. float_of_int b' in
+ if ratio_ab > ratio_ab' then a, b else a', b'
+
+(** [list_union l1 l2] returns the union of list [l1] and [l2]. The result
+ contains no duplicates. *)
let list_union l1 l2 =
let rec aux l acc =
match l with
- | [] -> acc
- | x::tl ->
- if List.mem x acc then
- aux tl acc
- else
- aux tl (x::acc)
+ | [] ->
+ acc
+ | x :: tl ->
+ if List.mem x acc then aux tl acc else aux tl (x :: acc)
in
let l1' = aux l1 [] in
aux l2 l1'
@@ -163,27 +170,36 @@ let hashtbl_add h1 h2 =
let hashtbl_iterlast h f1 f2 =
let l = Hashtbl.length h in
- ignore(
- Hashtbl.fold
- (fun k v cpt ->
- if cpt = l then
- begin f2 k v; cpt+1 end
- else
- begin f1 k v; cpt+1 end)
- h 1)
-
-(** Match types variables to 'a, 'b, ..., for pretty-printing. Type
- variables are identified by integers. *)
-let tnames = ref ([]: (int * string) list)
+ ignore
+ (Hashtbl.fold
+ (fun k v cpt ->
+ if cpt = l then (
+ f2 k v;
+ cpt + 1)
+ else (
+ f1 k v;
+ cpt + 1))
+ h 1)
+
+(** Match types variables to 'a, 'b, ..., for pretty-printing. Type variables
+ are identified by integers. *)
+let tnames = ref ([] : (int * string) list)
+
let tname_counter = ref 0
+
(* Same for carriers *)
-let crnames = ref ([]: (int * string) list)
+let crnames = ref ([] : (int * string) list)
+
let crname_counter = ref 0
+
(* Same for dimension *)
-let dnames = ref ([]: (int * string) list)
+let dnames = ref ([] : (int * string) list)
+
let dname_counter = ref 0
+
(* Same for delays *)
-let inames = ref ([]: (int * string) list)
+let inames = ref ([] : (int * string) list)
+
let iname_counter = ref 0
let reset_names () =
@@ -199,72 +215,71 @@ let reset_names () =
(* From OCaml compiler *)
let new_tname () =
let tname =
- if !tname_counter < 26
- then String.make 1 (Char.chr(97 + !tname_counter))
- else String.make 1 (Char.chr(97 + !tname_counter mod 26)) ^
- string_of_int(!tname_counter / 26) in
+ if !tname_counter < 26 then String.make 1 (Char.chr (97 + !tname_counter))
+ else
+ String.make 1 (Char.chr (97 + (!tname_counter mod 26)))
+ ^ string_of_int (!tname_counter / 26)
+ in
incr tname_counter;
tname
let new_crname () =
incr crname_counter;
- Format.sprintf "c%i" (!crname_counter-1)
+ Format.sprintf "c%i" (!crname_counter - 1)
let name_of_type id =
- try List.assoc id !tnames with Not_found ->
+ try List.assoc id !tnames
+ with Not_found ->
let name = new_tname () in
tnames := (id, name) :: !tnames;
name
let name_of_carrier id =
let pp_id =
- try List.assoc id !crnames with Not_found ->
+ try List.assoc id !crnames
+ with Not_found ->
let name = new_crname () in
- crnames := (id,name) :: !crnames;
+ crnames := (id, name) :: !crnames;
name
in
pp_id
let new_dname () =
incr dname_counter;
- Format.sprintf "d%i" (!dname_counter-1)
+ Format.sprintf "d%i" (!dname_counter - 1)
let name_of_dimension id =
- try List.assoc id !dnames with Not_found ->
+ try List.assoc id !dnames
+ with Not_found ->
let name = new_dname () in
dnames := (id, name) :: !dnames;
name
let new_iname () =
incr iname_counter;
- Format.sprintf "t%i" (!iname_counter-1)
+ Format.sprintf "t%i" (!iname_counter - 1)
let name_of_delay id =
- try List.assoc id !inames with Not_found ->
+ try List.assoc id !inames
+ with Not_found ->
let name = new_iname () in
inames := (id, name) :: !inames;
name
open Format
-let print_rat fmt (a,b) =
- if b=1 then
- Format.fprintf fmt "%i" a
- else
- if b < 0 then
- Format.fprintf fmt "%i/%i" (-a) (-b)
- else
- Format.fprintf fmt "%i/%i" a b
-
+let print_rat fmt (a, b) =
+ if b = 1 then Format.fprintf fmt "%i" a
+ else if b < 0 then Format.fprintf fmt "%i/%i" (-a) (-b)
+ else Format.fprintf fmt "%i/%i" a b
(* Generic pretty printing *)
+let pp_final_char_if_non_empty c l fmt =
+ match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c
-let pp_final_char_if_non_empty c l =
- (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "%(%)" c)
-
-let pp_newline_if_non_empty l =
- (fun fmt -> match l with [] -> () | _ -> Format.fprintf fmt "@,")
+let pp_newline_if_non_empty l fmt =
+ match l with [] -> () | _ -> Format.fprintf fmt "@,"
module Format = struct
include Format
@@ -283,160 +298,137 @@ module Format = struct
let pp_print_endcut s fmt () = fprintf fmt "%s@," s
let pp_print_opar fmt () = pp_print_string fmt "("
+
let pp_print_cpar fmt () = pp_print_string fmt ")"
+
let pp_print_obracket fmt () = pp_print_string fmt "["
+
let pp_print_cbracket fmt () = pp_print_string fmt "]"
+
let pp_print_obrace fmt () = pp_print_string fmt "{"
+
let pp_print_cbrace fmt () = pp_print_string fmt "}"
+
let pp_print_opar' fmt () = pp_print_string fmt "( "
+
let pp_print_cpar' fmt () = pp_print_string fmt " )"
+
let pp_print_obrace' fmt () = pp_print_string fmt "{ "
+
let pp_print_cbrace' fmt () = pp_print_string fmt " }"
let pp_print_comma fmt () = fprintf fmt ",@ "
+
let pp_print_semicolon fmt () = fprintf fmt ";@ "
+
let pp_print_comma' fmt () = fprintf fmt ","
+
let pp_print_semicolon' fmt () = fprintf fmt ";"
let pp_open_vbox0 fmt () = pp_open_vbox fmt 0
- let pp_print_list
- ?(pp_prologue=pp_print_nothing) ?(pp_epilogue=pp_print_nothing)
- ?(pp_op=pp_print_nothing) ?(pp_cl=pp_print_nothing)
- ?(pp_open_box=fun fmt () -> pp_open_box fmt 0)
- ?(pp_eol=pp_print_nothing)
- ?(pp_nil=pp_print_nothing)
- ?pp_sep pp_v fmt l =
+ let pp_print_list ?(pp_prologue = pp_print_nothing)
+ ?(pp_epilogue = pp_print_nothing) ?(pp_op = pp_print_nothing)
+ ?(pp_cl = pp_print_nothing)
+ ?(pp_open_box = fun fmt () -> pp_open_box fmt 0)
+ ?(pp_eol = pp_print_nothing) ?(pp_nil = pp_print_nothing) ?pp_sep pp_v fmt
+ l =
fprintf fmt "%a%a%a%a%a@]%a%a"
- (fun fmt l -> if l <> [] then pp_prologue fmt ()) l
- pp_op ()
- pp_open_box ()
+ (fun fmt l -> if l <> [] then pp_prologue fmt ())
+ l pp_op () pp_open_box ()
(fun fmt () ->
- if l = [] then pp_nil fmt () else pp_print_list ?pp_sep pp_v fmt l) ()
- (fun fmt l -> if l <> [] then pp_eol fmt ()) l
- pp_cl ()
- (fun fmt l -> if l <> [] then pp_epilogue fmt ()) l
+ if l = [] then pp_nil fmt () else pp_print_list ?pp_sep pp_v fmt l)
+ ()
+ (fun fmt l -> if l <> [] then pp_eol fmt ())
+ l pp_cl ()
+ (fun fmt l -> if l <> [] then pp_epilogue fmt ())
+ l
let pp_comma_list = pp_print_list ~pp_sep:pp_print_comma
- let pp_print_list_i
- ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
- pp_v =
+ let pp_print_list_i ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
+ ?pp_eol ?pp_sep pp_v =
let i = ref 0 in
- pp_print_list
- ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
- (fun fmt x -> pp_v fmt !i x; incr i)
-
- let pp_print_list2
- ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
- pp_v fmt (l1, l2) =
- pp_print_list
- ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
- pp_v fmt (List.combine l1 l2)
-
- let pp_print_list_i2
- ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
- pp_v fmt (l1, l2) =
- pp_print_list_i
- ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol ?pp_sep
- (fun fmt i (x1, x2) -> pp_v fmt i x1 x2) fmt (List.combine l1 l2)
-
- let pp_print_parenthesized ?(pp_sep=pp_print_comma) =
- pp_print_list
- ~pp_op:pp_print_opar
- ~pp_cl:pp_print_cpar
- ~pp_sep
-
- let pp_print_bracketed ?(pp_sep=pp_print_comma) =
- pp_print_list
- ~pp_op:pp_print_obracket
- ~pp_cl:pp_print_cbracket
- ~pp_sep
-
- let pp_print_braced ?(pp_sep=pp_print_comma) =
- pp_print_list
- ~pp_op:pp_print_obrace
- ~pp_cl:pp_print_cbrace
- ~pp_sep
-
- let pp_print_braced' ?(pp_sep=pp_print_comma) =
- pp_print_list
- ~pp_op:pp_print_obrace'
- ~pp_cl:pp_print_cbrace'
- ~pp_sep
+ pp_print_list ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
+ ?pp_sep (fun fmt x ->
+ pp_v fmt !i x;
+ incr i)
+
+ let pp_print_list2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
+ ?pp_eol ?pp_sep pp_v fmt (l1, l2) =
+ pp_print_list ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
+ ?pp_sep pp_v fmt (List.combine l1 l2)
+
+ let pp_print_list_i2 ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box
+ ?pp_eol ?pp_sep pp_v fmt (l1, l2) =
+ pp_print_list_i ?pp_prologue ?pp_epilogue ?pp_op ?pp_cl ?pp_open_box ?pp_eol
+ ?pp_sep
+ (fun fmt i (x1, x2) -> pp_v fmt i x1 x2)
+ fmt (List.combine l1 l2)
+
+ let pp_print_parenthesized ?(pp_sep = pp_print_comma) =
+ pp_print_list ~pp_op:pp_print_opar ~pp_cl:pp_print_cpar ~pp_sep
+
+ let pp_print_bracketed ?(pp_sep = pp_print_comma) =
+ pp_print_list ~pp_op:pp_print_obracket ~pp_cl:pp_print_cbracket ~pp_sep
+
+ let pp_print_braced ?(pp_sep = pp_print_comma) =
+ pp_print_list ~pp_op:pp_print_obrace ~pp_cl:pp_print_cbrace ~pp_sep
+
+ let pp_print_braced' ?(pp_sep = pp_print_comma) =
+ pp_print_list ~pp_op:pp_print_obrace' ~pp_cl:pp_print_cbrace' ~pp_sep
end
-let fprintf_list ?(eol:('a, formatter, unit) format = "") ~sep:sep f fmt l =
+let fprintf_list ?(eol : ('a, formatter, unit) format = "") ~sep f fmt l =
Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "%(%)" sep) f fmt l);
if l <> [] then Format.fprintf fmt "%(%)" eol
let pp_list l pp_fun beg_str end_str sep_str =
- if (beg_str="\n") then
- print_newline ()
- else
- print_string beg_str;
+ if beg_str = "\n" then print_newline () else print_string beg_str;
let rec pp_l l =
match l with
- | [] -> ()
- | [hd] ->
- pp_fun hd
- | hd::tl ->
- pp_fun hd;
- if (sep_str="\n") then
- print_newline ()
- else
- print_string sep_str;
- pp_l tl
+ | [] ->
+ ()
+ | [ hd ] ->
+ pp_fun hd
+ | hd :: tl ->
+ pp_fun hd;
+ if sep_str = "\n" then print_newline () else print_string sep_str;
+ pp_l tl
in
pp_l l;
- if (end_str="\n") then
- print_newline ()
- else
- print_string end_str
+ if end_str = "\n" then print_newline () else print_string end_str
let pp_array a pp_fun beg_str end_str sep_str =
- if (beg_str="\n") then
- print_newline ()
- else
- print_string beg_str;
+ if beg_str = "\n" then print_newline () else print_string beg_str;
let n = Array.length a in
- if n > 0 then
- begin
- Array.iter (fun x -> pp_fun x; print_string sep_str) (Array.sub a 0 (n-1));
- pp_fun a.(n-1)
- end;
- if (end_str="\n") then
- print_newline ()
- else
- print_string end_str
+ if n > 0 then (
+ Array.iter
+ (fun x ->
+ pp_fun x;
+ print_string sep_str)
+ (Array.sub a 0 (n - 1));
+ pp_fun a.(n - 1));
+ if end_str = "\n" then print_newline () else print_string end_str
let pp_iset fmt t =
Format.fprintf fmt "@[<hv 0>@[<hv 2>{";
ISet.iter (fun s -> Format.fprintf fmt "@ %s" s) t;
Format.fprintf fmt "@]@ }@]"
-let pp_imap ?(comment="") pp_val fmt m =
+let pp_imap ?(comment = "") pp_val fmt m =
Format.fprintf fmt "@[<hv 0>@[<hv 2>{ %s" comment;
IMap.iter (fun key v -> Format.fprintf fmt "@ %s -> %a" key pp_val v) m;
Format.fprintf fmt "@]@ }@]"
let pp_hashtbl t pp_fun beg_str end_str sep_str =
- if (beg_str="\n") then
- print_newline ()
- else
- print_string beg_str;
+ if beg_str = "\n" then print_newline () else print_string beg_str;
let pp_fun1 k v =
pp_fun k v;
- if (sep_str="\n") then
- print_newline ()
- else
- print_string sep_str
+ if sep_str = "\n" then print_newline () else print_string sep_str
in
hashtbl_iterlast t pp_fun1 pp_fun;
- if (end_str="\n") then
- print_newline ()
- else
- print_string end_str
+ if end_str = "\n" then print_newline () else print_string end_str
let pp_longident lid =
let pp_fun (nid, tag) =
@@ -445,57 +437,62 @@ let pp_longident lid =
print_int tag;
print_string ")"
in
- pp_list lid pp_fun "" "." "."
+ pp_list lid pp_fun "" "." "."
let pp_date fmt tm =
let open Unix in
- Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i"
- (tm.tm_year + 1900)
- tm.tm_mon
- tm.tm_mday
- tm.tm_hour
- tm.tm_min
- tm.tm_sec
+ Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i" (tm.tm_year + 1900) tm.tm_mon
+ tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
(* Used for uid in variables *)
let get_new_id =
let var_id_cpt = ref 0 in
- fun () -> incr var_id_cpt; !var_id_cpt
+ fun () ->
+ incr var_id_cpt;
+ !var_id_cpt
let new_tag =
let last_tag = ref (-1) in
- fun () -> incr last_tag; !last_tag
-
+ fun () ->
+ incr last_tag;
+ !last_tag
module List = struct
- include List
+ include List
+
let iteri2 f l1 l2 =
if List.length l1 <> List.length l2 then
raise (Invalid_argument "iteri2: lists have different lengths")
else
let rec run idx l1 l2 =
match l1, l2 with
- | [], [] -> ()
- | hd1::tl1, hd2::tl2 ->
+ | [], [] ->
+ ()
+ | hd1 :: tl1, hd2 :: tl2 ->
f idx hd1 hd2;
- run (idx+1) tl1 tl2
- | _ -> assert false
+ run (idx + 1) tl1 tl2
+ | _ ->
+ assert false
in
run 0 l1 l2
let rec extract l fst last =
- if last < fst then assert false else
+ if last < fst then assert false
+ else
match l, fst with
- | hd::tl, 0 -> if last = 0 then [] else hd::(extract tl 0 (last-1))
- | _::tl, _ -> extract tl (fst-1) (last-1)
- | [], 0 -> if last=0 then [] else assert false (* List too short *)
- | _ -> assert false
-
+ | hd :: tl, 0 ->
+ if last = 0 then [] else hd :: extract tl 0 (last - 1)
+ | _ :: tl, _ ->
+ extract tl (fst - 1) (last - 1)
+ | [], 0 ->
+ if last = 0 then [] else assert false (* List too short *)
+ | _ ->
+ assert false
end
let get_date () =
- let tm = Unix.localtime (Unix.time ()) in
+ let tm = Unix.localtime (Unix.time ()) in
let fmt = Format.str_formatter in
pp_date fmt tm;
Format.flush_str_formatter ()
diff --git a/src/verifierList.ml b/src/verifierList.ml
index 254cda864a0d835b5f75d0b0e50e0519d124a91d..e38063e5c5ef7089604fc5dc26eec5febac7d96a 100644
--- a/src/verifierList.ml
+++ b/src/verifierList.ml
@@ -1,8 +1,8 @@
let registered : (module VerifierType.S) list ref = ref []
let verifiers () = !registered
- (* [
- * @LUSTREV_SEAL@
- * @LUSTREV_ZUSTRE@
- * @LUSTREV_TINY@
- * ] *)
+(* [
+ * @LUSTREV_SEAL@
+ * @LUSTREV_ZUSTRE@
+ * @LUSTREV_TINY@
+ * ] *)
diff --git a/src/verifierType.ml b/src/verifierType.ml
index 9ed16beadef01bc98021569d842460027e070a0d..f442ed3ea232ee2cab49f2baead28aa8633e3fc7 100644
--- a/src/verifierType.ml
+++ b/src/verifierType.ml
@@ -1,20 +1,26 @@
-module type S =
-sig
- val name: string
- val activate: unit -> unit
- val is_active: unit -> bool
- val options: (string * Arg.spec * string) list
- val get_normalization_params: unit -> Normalization.param_t
- val run: basename:string -> Lustre_types.program_t -> Machine_code_types.machine_t list -> unit
-end
+module type S = sig
+ val name : string
+
+ val activate : unit -> unit
+
+ val is_active : unit -> bool
-module Default =
- struct
+ val options : (string * Arg.spec * string) list
- let get_normalization_params () = {
- Normalization.unfold_arrow_active = true;
- force_alias_ite = false;
- force_alias_internal_fun = false;
- }
+ val get_normalization_params : unit -> Normalization.param_t
- end
+ val run :
+ basename:string ->
+ Lustre_types.program_t ->
+ Machine_code_types.machine_t list ->
+ unit
+end
+
+module Default = struct
+ let get_normalization_params () =
+ {
+ Normalization.unfold_arrow_active = true;
+ force_alias_ite = false;
+ force_alias_internal_fun = false;
+ }
+end
diff --git a/src/verifiers.ml b/src/verifiers.ml
index 1b08d68cdfa5048d028f7ca02afc25eeca455c19..42b9c5bf59dbfb737951c1ba1d1d9fe608dc0dfc 100644
--- a/src/verifiers.ml
+++ b/src/verifiers.ml
@@ -3,46 +3,47 @@ open VerifierList
let () = Sites.Plugins.Verifiers.load_all ()
let active = ref None
-
-let options () =
- List.flatten (
- List.map Options_management.verifier_opt (
- List.map (fun m ->
- let module M = (val m : VerifierType.S) in
- (M.name, M.activate, M.options)
- ) (verifiers ())
- ))
-
+
+let options () =
+ List.flatten
+ (List.map Options_management.verifier_opt
+ (List.map
+ (fun m ->
+ let module M = (val m : VerifierType.S) in
+ M.name, M.activate, M.options)
+ (verifiers ())))
+
let verifier_list verifiers =
- List.fold_left (fun acc m ->
- let module M = (val m : VerifierType.S) in
- (if acc = "" then "" else acc ^ ", ") ^ M.name
- ) "" verifiers
-
+ List.fold_left
+ (fun acc m ->
+ let module M = (val m : VerifierType.S) in
+ (if acc = "" then "" else acc ^ ", ") ^ M.name)
+ "" verifiers
+
let get_active () =
match !active with
- | None ->
- begin
- (* check that a single one is active and register it *)
- let found =
- List.fold_left (fun found m ->
- let module M = (val m : VerifierType.S) in
- if M.is_active () then
- m::found
- else
- found
- ) [] (verifiers ())
- in
- match found with
- | [] -> raise (Sys_error ("Please select one verifier in " ^ verifier_list (verifiers ())))
- | [m] -> active := Some m; m
- | _ -> raise (Sys_error ("Too many selected verifiers: " ^ verifier_list found))
- end
-
- | Some m -> m
-
+ | None -> (
+ (* check that a single one is active and register it *)
+ let found =
+ List.fold_left
+ (fun found m ->
+ let module M = (val m : VerifierType.S) in
+ if M.is_active () then m :: found else found)
+ [] (verifiers ())
+ in
+ match found with
+ | [] ->
+ raise
+ (Sys_error
+ ("Please select one verifier in " ^ verifier_list (verifiers ())))
+ | [ m ] ->
+ active := Some m;
+ m
+ | _ ->
+ raise (Sys_error ("Too many selected verifiers: " ^ verifier_list found)))
+ | Some m ->
+ m
-
- (* Local Variables: *)
- (* compile-command:"make -C .." *)
- (* End: *)
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
diff --git a/src/version.ml b/src/version.ml
index 6f28fc5b88ccdfc6e439844fbd487e38cd7f64ac..6d82c096d985a049837ee9aaeaecbf14825a4ead 100644
--- a/src/version.ml
+++ b/src/version.ml
@@ -1,6 +1,7 @@
let number = "@PACKAGE_VERSION@-@GITBRANCH@"
-let codename ="@VERSION_CODENAME@"
+let codename = "@VERSION_CODENAME@"
let include_path = Sites.Sites.include_ |> List.hd
+
let testgen_path = Sites.Sites.testgen |> List.hd