From 532069087ed393ccb07688cf827ab6f837a73192 Mon Sep 17 00:00:00 2001
From: xthirioux <xthirioux@041b043f-8d7c-46b2-b46e-ef0dd855326e>
Date: Thu, 26 Nov 2015 15:45:16 +0000
Subject: [PATCH] major branche merging salsa/mpfr with trunk
---
Makefile.in | 34 +-
configure.ac | 3 +-
setup.ml | 5884 ------------------------
src/Makefile.in | 2 +-
src/_tags | 11 +-
src/backends/C/c_backend.ml | 20 +-
src/backends/C/c_backend_common.ml | 209 +-
src/backends/C/c_backend_header.ml | 29 +-
src/backends/C/c_backend_main.ml | 172 +-
src/backends/C/c_backend_makefile.ml | 8 +-
src/backends/C/c_backend_src.ml | 379 +-
src/backends/Horn/horn_backend.ml | 52 +-
src/basic_library.ml | 73 +-
src/causality.ml | 4 +-
src/clock_calculus.ml | 2 +-
src/compiler_common.ml | 17 +
src/corelang.ml | 54 +-
src/corelang.mli | 5 +-
src/dimension.ml | 9 +-
src/env.ml | 1 +
src/inliner.ml | 101 +-
src/lexerLustreSpec.mll | 10 +-
src/lexer_lustre.mll | 202 +-
src/liveness.ml | 14 +-
src/lustreSpec.ml | 37 +-
src/machine_code.ml | 225 +-
src/main_lustre_compiler.ml | 836 ++--
src/normalization.ml | 70 +-
src/optimize_machine.ml | 221 +-
src/options.ml | 41 +-
src/parser_lustre.mly | 91 +-
src/plugins/salsa/machine_salsa_opt.ml | 572 +++
src/plugins/salsa/salsaDatatypes.ml | 337 ++
src/plugins/scopes/scopes.ml | 319 ++
src/printers.ml | 13 +-
src/scheduling.ml | 76 +-
src/splitting.ml | 2 +-
src/stateless.ml | 13 +-
src/type_predef.ml | 1 -
src/types.ml | 29 +-
src/typing.ml | 35 +-
src/utils.ml | 3 +-
test/tests_ok_dev.list | 32 -
43 files changed, 3002 insertions(+), 7246 deletions(-)
delete mode 100644 setup.ml
create mode 100644 src/plugins/salsa/machine_salsa_opt.ml
create mode 100644 src/plugins/salsa/salsaDatatypes.ml
create mode 100644 src/plugins/scopes/scopes.ml
delete mode 100644 test/tests_ok_dev.list
diff --git a/Makefile.in b/Makefile.in
index 749e3bb0..a204a135 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -3,52 +3,44 @@ OCAMLBUILD=@OCAMLBUILD@ -classic-display -no-links
prefix=@prefix@
exec_prefix=@exec_prefix@
bindir=@bindir@
-datadir = ${prefix}/share
+datarootdir = ${prefix}/share
includedir = ${prefix}/include
-LUSI_LIBS=include/math.lusi include/conv.lusi
+LUSI_LIBS=include/math.lusi include/conv.lusi include/mpfr_lustre.lusi
+
LOCAL_BINDIR=bin
LOCAL_DOCDIR=doc/manual
lustrec:
@echo Compiling binary lustrec
- @$(OCAMLBUILD) -cflags -I,@OCAMLGRAPH_PATH@ -lflag @OCAMLGRAPH_PATH@/graph.cmxa -I src -I src/backends/C src/main_lustre_compiler.native
- @mkdir -p $(LOCAL_BINDIR)
- @mv _build/src/main_lustre_compiler.native $(LOCAL_BINDIR)/lustrec
+ @make -C src lustrec
doc:
@echo Generating doc
- @$(OCAMLBUILD) lustrec.docdir/index.html
- @rm -rf $(LOCAL_DOCDIR)
- @cp -rf _build/lustrec.docdir $(LOCAL_DOCDIR)
+ @make -C src doc
dot: doc
- $(OCAMLBUILD) lustrec.docdir/lustrec.dot
- dot -T ps -o lustrec.dot _build/lustrec.docdir/lustrec.dot
- mv _build/lustrec.docdir/lustrec.dot $(LOCAL_DOCDIR)
+ @make -C src dot
clean:
- $(OCAMLBUILD) -clean
+ @make -C src clean
+ @rm -f $(LUSI_LIBS:%.lusi=%.lusic) $(LUSI_LIBS:%.lusi=%.h)
dist-clean: clean
- @rm -f Makefile myocamlbuild.ml config.log config.status configure include/*.lusic include/math.h include/conv.h
-%.lusic: %.lusi
+%.lusic: %.lusi
@echo Compiling $<
- @$(LOCAL_BINDIR)/lustrec -verbose 0 -d include $<
+ @$(LOCAL_BINDIR)/lustrec $(OPTION_LUSIC) -verbose 0 -d include $<
-clean-lusic:
- @rm -f $(LUSI_LIBS:%.lusi=%.lusic)
+include/mpfr_lustre.lusic: OPTION_LUSIC=-mpfr 1
-compile-lusi: $(LUSI_LIBS:%.lusi=%.lusic)
+compile-lusi: lustrec $(LUSI_LIBS:%.lusi=%.lusic)
-install: clean-lusic compile-lusi
+install: compile-lusi
mkdir -p ${bindir}
install -m 0755 $(LOCAL_BINDIR)/* ${bindir}
mkdir -p ${includedir}/lustrec
cp include/* ${includedir}/lustrec
- mkdir -p ${datadir}
- install -m 0655 share/FindLustre.cmake ${datadir}
.PHONY: compile-lusi doc dot lustrec lustrec.odocl clean install dist-clean
diff --git a/configure.ac b/configure.ac
index 8ef82bad..e7141ed1 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,4 +1,4 @@
-define([svnversion], esyscmd([sh -c "svnversion|sed "s/:.*//"|tr -d '\n'"]))dnl
+dnl define([svnversion], esyscmd([sh -c "svnversion|sed "s/:.*//"|tr -d '\n'"]))
AC_INIT([lustrec], [1.1-svnversion], [ploc@garoche.net])
@@ -86,7 +86,6 @@ AC_DEFINE_DIR([abs_datadir], [datadir])
# Instanciation
AC_CONFIG_FILES([Makefile
src/Makefile
- src/myocamlbuild.ml
src/version.ml])
AC_OUTPUT
diff --git a/setup.ml b/setup.ml
deleted file mode 100644
index f192265d..00000000
--- a/setup.ml
+++ /dev/null
@@ -1,5884 +0,0 @@
-(* setup.ml generated for the first time by OASIS v0.2.0 *)
-
-(* OASIS_START *)
-(* DO NOT EDIT (digest: cbef9780a942e499729218b6c22c21f0) *)
-(*
- Regenerated by OASIS v0.3.0
- Visit http://oasis.forge.ocamlcore.org for more information and
- documentation about functions used in this file.
-*)
-module OASISGettext = struct
-(* # 21 "src/oasis/OASISGettext.ml" *)
-
- let ns_ str =
- str
-
- let s_ str =
- str
-
- let f_ (str : ('a, 'b, 'c, 'd) format4) =
- str
-
- let fn_ fmt1 fmt2 n =
- if n = 1 then
- fmt1^^""
- else
- fmt2^^""
-
- let init =
- []
-
-end
-
-module OASISContext = struct
-(* # 21 "src/oasis/OASISContext.ml" *)
-
- open OASISGettext
-
- type level =
- [ `Debug
- | `Info
- | `Warning
- | `Error]
-
- type t =
- {
- quiet: bool;
- info: bool;
- debug: bool;
- ignore_plugins: bool;
- ignore_unknown_fields: bool;
- printf: level -> string -> unit;
- }
-
- let printf lvl str =
- let beg =
- match lvl with
- | `Error -> s_ "E: "
- | `Warning -> s_ "W: "
- | `Info -> s_ "I: "
- | `Debug -> s_ "D: "
- in
- prerr_endline (beg^str)
-
- let default =
- ref
- {
- quiet = false;
- info = false;
- debug = false;
- ignore_plugins = false;
- ignore_unknown_fields = false;
- printf = printf;
- }
-
- let quiet =
- {!default with quiet = true}
-
-
- let args () =
- ["-quiet",
- Arg.Unit (fun () -> default := {!default with quiet = true}),
- (s_ " Run quietly");
-
- "-info",
- Arg.Unit (fun () -> default := {!default with info = true}),
- (s_ " Display information message");
-
-
- "-debug",
- Arg.Unit (fun () -> default := {!default with debug = true}),
- (s_ " Output debug message")]
-end
-
-module OASISString = struct
-(* # 1 "src/oasis/OASISString.ml" *)
-
-
-
- (** Various string utilities.
-
- Mostly inspired by extlib and batteries ExtString and BatString libraries.
-
- @author Sylvain Le Gall
- *)
-
- let nsplitf str f =
- if str = "" then
- []
- else
- let buf = Buffer.create 13 in
- let lst = ref [] in
- let push () =
- lst := Buffer.contents buf :: !lst;
- Buffer.clear buf
- in
- let str_len = String.length str in
- for i = 0 to str_len - 1 do
- if f str.[i] then
- push ()
- else
- Buffer.add_char buf str.[i]
- done;
- push ();
- List.rev !lst
-
- (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the
- separator.
- *)
- let nsplit str c =
- nsplitf str ((=) c)
-
- let find ~what ?(offset=0) str =
- let what_idx = ref 0 in
- let str_idx = ref offset in
- while !str_idx < String.length str &&
- !what_idx < String.length what do
- if str.[!str_idx] = what.[!what_idx] then
- incr what_idx
- else
- what_idx := 0;
- incr str_idx
- done;
- if !what_idx <> String.length what then
- raise Not_found
- else
- !str_idx - !what_idx
-
- let sub_start str len =
- let str_len = String.length str in
- if len >= str_len then
- ""
- else
- String.sub str len (str_len - len)
-
- let sub_end ?(offset=0) str len =
- let str_len = String.length str in
- if len >= str_len then
- ""
- else
- String.sub str 0 (str_len - len)
-
- let starts_with ~what ?(offset=0) str =
- let what_idx = ref 0 in
- let str_idx = ref offset in
- let ok = ref true in
- while !ok &&
- !str_idx < String.length str &&
- !what_idx < String.length what do
- if str.[!str_idx] = what.[!what_idx] then
- incr what_idx
- else
- ok := false;
- incr str_idx
- done;
- if !what_idx = String.length what then
- true
- else
- false
-
- let strip_starts_with ~what str =
- if starts_with ~what str then
- sub_start str (String.length what)
- else
- raise Not_found
-
- let ends_with ~what ?(offset=0) str =
- let what_idx = ref ((String.length what) - 1) in
- let str_idx = ref ((String.length str) - 1) in
- let ok = ref true in
- while !ok &&
- offset <= !str_idx &&
- 0 <= !what_idx do
- if str.[!str_idx] = what.[!what_idx] then
- decr what_idx
- else
- ok := false;
- decr str_idx
- done;
- if !what_idx = -1 then
- true
- else
- false
-
- let strip_ends_with ~what str =
- if ends_with ~what str then
- sub_end str (String.length what)
- else
- raise Not_found
-
- let replace_chars f s =
- let buf = String.make (String.length s) 'X' in
- for i = 0 to String.length s - 1 do
- buf.[i] <- f s.[i]
- done;
- buf
-
-end
-
-module OASISUtils = struct
-(* # 21 "src/oasis/OASISUtils.ml" *)
-
- open OASISGettext
-
- module MapString = Map.Make(String)
-
- let map_string_of_assoc assoc =
- List.fold_left
- (fun acc (k, v) -> MapString.add k v acc)
- MapString.empty
- assoc
-
- module SetString = Set.Make(String)
-
- let set_string_add_list st lst =
- List.fold_left
- (fun acc e -> SetString.add e acc)
- st
- lst
-
- let set_string_of_list =
- set_string_add_list
- SetString.empty
-
-
- let compare_csl s1 s2 =
- String.compare (String.lowercase s1) (String.lowercase s2)
-
- module HashStringCsl =
- Hashtbl.Make
- (struct
- type t = string
-
- let equal s1 s2 =
- (String.lowercase s1) = (String.lowercase s2)
-
- let hash s =
- Hashtbl.hash (String.lowercase s)
- end)
-
- let varname_of_string ?(hyphen='_') s =
- if String.length s = 0 then
- begin
- invalid_arg "varname_of_string"
- end
- else
- begin
- let buf =
- OASISString.replace_chars
- (fun c ->
- if ('a' <= c && c <= 'z')
- ||
- ('A' <= c && c <= 'Z')
- ||
- ('0' <= c && c <= '9') then
- c
- else
- hyphen)
- s;
- in
- let buf =
- (* Start with a _ if digit *)
- if '0' <= s.[0] && s.[0] <= '9' then
- "_"^buf
- else
- buf
- in
- String.lowercase buf
- end
-
- let varname_concat ?(hyphen='_') p s =
- let what = String.make 1 hyphen in
- let p =
- try
- OASISString.strip_ends_with ~what p
- with Not_found ->
- p
- in
- let s =
- try
- OASISString.strip_starts_with ~what s
- with Not_found ->
- s
- in
- p^what^s
-
-
- let is_varname str =
- str = varname_of_string str
-
- let failwithf fmt = Printf.ksprintf failwith fmt
-
-end
-
-module PropList = struct
-(* # 21 "src/oasis/PropList.ml" *)
-
- open OASISGettext
-
- type name = string
-
- exception Not_set of name * string option
- exception No_printer of name
- exception Unknown_field of name * name
-
- let () =
- Printexc.register_printer
- (function
- | Not_set (nm, Some rsn) ->
- Some
- (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn)
- | Not_set (nm, None) ->
- Some
- (Printf.sprintf (f_ "Field '%s' is not set") nm)
- | No_printer nm ->
- Some
- (Printf.sprintf (f_ "No default printer for value %s") nm)
- | Unknown_field (nm, schm) ->
- Some
- (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm)
- | _ ->
- None)
-
- module Data =
- struct
-
- type t =
- (name, unit -> unit) Hashtbl.t
-
- let create () =
- Hashtbl.create 13
-
- let clear t =
- Hashtbl.clear t
-
-(* # 71 "src/oasis/PropList.ml" *)
- end
-
- module Schema =
- struct
-
- type ('ctxt, 'extra) value =
- {
- get: Data.t -> string;
- set: Data.t -> ?context:'ctxt -> string -> unit;
- help: (unit -> string) option;
- extra: 'extra;
- }
-
- type ('ctxt, 'extra) t =
- {
- name: name;
- fields: (name, ('ctxt, 'extra) value) Hashtbl.t;
- order: name Queue.t;
- name_norm: string -> string;
- }
-
- let create ?(case_insensitive=false) nm =
- {
- name = nm;
- fields = Hashtbl.create 13;
- order = Queue.create ();
- name_norm =
- (if case_insensitive then
- String.lowercase
- else
- fun s -> s);
- }
-
- let add t nm set get extra help =
- let key =
- t.name_norm nm
- in
-
- if Hashtbl.mem t.fields key then
- failwith
- (Printf.sprintf
- (f_ "Field '%s' is already defined in schema '%s'")
- nm t.name);
- Hashtbl.add
- t.fields
- key
- {
- set = set;
- get = get;
- help = help;
- extra = extra;
- };
- Queue.add nm t.order
-
- let mem t nm =
- Hashtbl.mem t.fields nm
-
- let find t nm =
- try
- Hashtbl.find t.fields (t.name_norm nm)
- with Not_found ->
- raise (Unknown_field (nm, t.name))
-
- let get t data nm =
- (find t nm).get data
-
- let set t data nm ?context x =
- (find t nm).set
- data
- ?context
- x
-
- let fold f acc t =
- Queue.fold
- (fun acc k ->
- let v =
- find t k
- in
- f acc k v.extra v.help)
- acc
- t.order
-
- let iter f t =
- fold
- (fun () -> f)
- ()
- t
-
- let name t =
- t.name
- end
-
- module Field =
- struct
-
- type ('ctxt, 'value, 'extra) t =
- {
- set: Data.t -> ?context:'ctxt -> 'value -> unit;
- get: Data.t -> 'value;
- sets: Data.t -> ?context:'ctxt -> string -> unit;
- gets: Data.t -> string;
- help: (unit -> string) option;
- extra: 'extra;
- }
-
- let new_id =
- let last_id =
- ref 0
- in
- fun () -> incr last_id; !last_id
-
- let create ?schema ?name ?parse ?print ?default ?update ?help extra =
- (* Default value container *)
- let v =
- ref None
- in
-
- (* If name is not given, create unique one *)
- let nm =
- match name with
- | Some s -> s
- | None -> Printf.sprintf "_anon_%d" (new_id ())
- in
-
- (* Last chance to get a value: the default *)
- let default () =
- match default with
- | Some d -> d
- | None -> raise (Not_set (nm, Some (s_ "no default value")))
- in
-
- (* Get data *)
- let get data =
- (* Get value *)
- try
- (Hashtbl.find data nm) ();
- match !v with
- | Some x -> x
- | None -> default ()
- with Not_found ->
- default ()
- in
-
- (* Set data *)
- let set data ?context x =
- let x =
- match update with
- | Some f ->
- begin
- try
- f ?context (get data) x
- with Not_set _ ->
- x
- end
- | None ->
- x
- in
- Hashtbl.replace
- data
- nm
- (fun () -> v := Some x)
- in
-
- (* Parse string value, if possible *)
- let parse =
- match parse with
- | Some f ->
- f
- | None ->
- fun ?context s ->
- failwith
- (Printf.sprintf
- (f_ "Cannot parse field '%s' when setting value %S")
- nm
- s)
- in
-
- (* Set data, from string *)
- let sets data ?context s =
- set ?context data (parse ?context s)
- in
-
- (* Output value as string, if possible *)
- let print =
- match print with
- | Some f ->
- f
- | None ->
- fun _ -> raise (No_printer nm)
- in
-
- (* Get data, as a string *)
- let gets data =
- print (get data)
- in
-
- begin
- match schema with
- | Some t ->
- Schema.add t nm sets gets extra help
- | None ->
- ()
- end;
-
- {
- set = set;
- get = get;
- sets = sets;
- gets = gets;
- help = help;
- extra = extra;
- }
-
- let fset data t ?context x =
- t.set data ?context x
-
- let fget data t =
- t.get data
-
- let fsets data t ?context s =
- t.sets data ?context s
-
- let fgets data t =
- t.gets data
-
- end
-
- module FieldRO =
- struct
-
- let create ?schema ?name ?parse ?print ?default ?update ?help extra =
- let fld =
- Field.create ?schema ?name ?parse ?print ?default ?update ?help extra
- in
- fun data -> Field.fget data fld
-
- end
-end
-
-module OASISMessage = struct
-(* # 21 "src/oasis/OASISMessage.ml" *)
-
-
- open OASISGettext
- open OASISContext
-
- let generic_message ~ctxt lvl fmt =
- let cond =
- if ctxt.quiet then
- false
- else
- match lvl with
- | `Debug -> ctxt.debug
- | `Info -> ctxt.info
- | _ -> true
- in
- Printf.ksprintf
- (fun str ->
- if cond then
- begin
- ctxt.printf lvl str
- end)
- fmt
-
- let debug ~ctxt fmt =
- generic_message ~ctxt `Debug fmt
-
- let info ~ctxt fmt =
- generic_message ~ctxt `Info fmt
-
- let warning ~ctxt fmt =
- generic_message ~ctxt `Warning fmt
-
- let error ~ctxt fmt =
- generic_message ~ctxt `Error fmt
-
-end
-
-module OASISVersion = struct
-(* # 21 "src/oasis/OASISVersion.ml" *)
-
- open OASISGettext
-
-
-
- type s = string
-
- type t = string
-
- type comparator =
- | VGreater of t
- | VGreaterEqual of t
- | VEqual of t
- | VLesser of t
- | VLesserEqual of t
- | VOr of comparator * comparator
- | VAnd of comparator * comparator
-
-
- (* Range of allowed characters *)
- let is_digit c =
- '0' <= c && c <= '9'
-
- let is_alpha c =
- ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')
-
- let is_special =
- function
- | '.' | '+' | '-' | '~' -> true
- | _ -> false
-
- let rec version_compare v1 v2 =
- if v1 <> "" || v2 <> "" then
- begin
- (* Compare ascii string, using special meaning for version
- * related char
- *)
- let val_ascii c =
- if c = '~' then -1
- else if is_digit c then 0
- else if c = '\000' then 0
- else if is_alpha c then Char.code c
- else (Char.code c) + 256
- in
-
- let len1 = String.length v1 in
- let len2 = String.length v2 in
-
- let p = ref 0 in
-
- (** Compare ascii part *)
- let compare_vascii () =
- let cmp = ref 0 in
- while !cmp = 0 &&
- !p < len1 && !p < len2 &&
- not (is_digit v1.[!p] && is_digit v2.[!p]) do
- cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]);
- incr p
- done;
- if !cmp = 0 && !p < len1 && !p = len2 then
- val_ascii v1.[!p]
- else if !cmp = 0 && !p = len1 && !p < len2 then
- - (val_ascii v2.[!p])
- else
- !cmp
- in
-
- (** Compare digit part *)
- let compare_digit () =
- let extract_int v p =
- let start_p = !p in
- while !p < String.length v && is_digit v.[!p] do
- incr p
- done;
- let substr =
- String.sub v !p ((String.length v) - !p)
- in
- let res =
- match String.sub v start_p (!p - start_p) with
- | "" -> 0
- | s -> int_of_string s
- in
- res, substr
- in
- let i1, tl1 = extract_int v1 (ref !p) in
- let i2, tl2 = extract_int v2 (ref !p) in
- i1 - i2, tl1, tl2
- in
-
- match compare_vascii () with
- | 0 ->
- begin
- match compare_digit () with
- | 0, tl1, tl2 ->
- if tl1 <> "" && is_digit tl1.[0] then
- 1
- else if tl2 <> "" && is_digit tl2.[0] then
- -1
- else
- version_compare tl1 tl2
- | n, _, _ ->
- n
- end
- | n ->
- n
- end
- else
- begin
- 0
- end
-
-
- let version_of_string str = str
-
- let string_of_version t = t
-
- let chop t =
- try
- let pos =
- String.rindex t '.'
- in
- String.sub t 0 pos
- with Not_found ->
- t
-
- let rec comparator_apply v op =
- match op with
- | VGreater cv ->
- (version_compare v cv) > 0
- | VGreaterEqual cv ->
- (version_compare v cv) >= 0
- | VLesser cv ->
- (version_compare v cv) < 0
- | VLesserEqual cv ->
- (version_compare v cv) <= 0
- | VEqual cv ->
- (version_compare v cv) = 0
- | VOr (op1, op2) ->
- (comparator_apply v op1) || (comparator_apply v op2)
- | VAnd (op1, op2) ->
- (comparator_apply v op1) && (comparator_apply v op2)
-
- let rec string_of_comparator =
- function
- | VGreater v -> "> "^(string_of_version v)
- | VEqual v -> "= "^(string_of_version v)
- | VLesser v -> "< "^(string_of_version v)
- | VGreaterEqual v -> ">= "^(string_of_version v)
- | VLesserEqual v -> "<= "^(string_of_version v)
- | VOr (c1, c2) ->
- (string_of_comparator c1)^" || "^(string_of_comparator c2)
- | VAnd (c1, c2) ->
- (string_of_comparator c1)^" && "^(string_of_comparator c2)
-
- let rec varname_of_comparator =
- let concat p v =
- OASISUtils.varname_concat
- p
- (OASISUtils.varname_of_string
- (string_of_version v))
- in
- function
- | VGreater v -> concat "gt" v
- | VLesser v -> concat "lt" v
- | VEqual v -> concat "eq" v
- | VGreaterEqual v -> concat "ge" v
- | VLesserEqual v -> concat "le" v
- | VOr (c1, c2) ->
- (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2)
- | VAnd (c1, c2) ->
- (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2)
-
- let version_0_3_or_after t =
- comparator_apply t (VGreaterEqual (string_of_version "0.3"))
-
-end
-
-module OASISLicense = struct
-(* # 21 "src/oasis/OASISLicense.ml" *)
-
- (** License for _oasis fields
- @author Sylvain Le Gall
- *)
-
-
-
- type license = string
-
- type license_exception = string
-
- type license_version =
- | Version of OASISVersion.t
- | VersionOrLater of OASISVersion.t
- | NoVersion
-
-
- type license_dep_5_unit =
- {
- license: license;
- excption: license_exception option;
- version: license_version;
- }
-
-
- type license_dep_5 =
- | DEP5Unit of license_dep_5_unit
- | DEP5Or of license_dep_5 list
- | DEP5And of license_dep_5 list
-
-
- type t =
- | DEP5License of license_dep_5
- | OtherLicense of string (* URL *)
-
-
-end
-
-module OASISExpr = struct
-(* # 21 "src/oasis/OASISExpr.ml" *)
-
-
-
- open OASISGettext
-
- type test = string
-
- type flag = string
-
- type t =
- | EBool of bool
- | ENot of t
- | EAnd of t * t
- | EOr of t * t
- | EFlag of flag
- | ETest of test * string
-
-
- type 'a choices = (t * 'a) list
-
- let eval var_get t =
- let rec eval' =
- function
- | EBool b ->
- b
-
- | ENot e ->
- not (eval' e)
-
- | EAnd (e1, e2) ->
- (eval' e1) && (eval' e2)
-
- | EOr (e1, e2) ->
- (eval' e1) || (eval' e2)
-
- | EFlag nm ->
- let v =
- var_get nm
- in
- assert(v = "true" || v = "false");
- (v = "true")
-
- | ETest (nm, vl) ->
- let v =
- var_get nm
- in
- (v = vl)
- in
- eval' t
-
- let choose ?printer ?name var_get lst =
- let rec choose_aux =
- function
- | (cond, vl) :: tl ->
- if eval var_get cond then
- vl
- else
- choose_aux tl
- | [] ->
- let str_lst =
- if lst = [] then
- s_ "<empty>"
- else
- String.concat
- (s_ ", ")
- (List.map
- (fun (cond, vl) ->
- match printer with
- | Some p -> p vl
- | None -> s_ "<no printer>")
- lst)
- in
- match name with
- | Some nm ->
- failwith
- (Printf.sprintf
- (f_ "No result for the choice list '%s': %s")
- nm str_lst)
- | None ->
- failwith
- (Printf.sprintf
- (f_ "No result for a choice list: %s")
- str_lst)
- in
- choose_aux (List.rev lst)
-
-end
-
-module OASISTypes = struct
-(* # 21 "src/oasis/OASISTypes.ml" *)
-
-
-
-
- type name = string
- type package_name = string
- type url = string
- type unix_dirname = string
- type unix_filename = string
- type host_dirname = string
- type host_filename = string
- type prog = string
- type arg = string
- type args = string list
- type command_line = (prog * arg list)
-
- type findlib_name = string
- type findlib_full = string
-
- type compiled_object =
- | Byte
- | Native
- | Best
-
-
- type dependency =
- | FindlibPackage of findlib_full * OASISVersion.comparator option
- | InternalLibrary of name
-
-
- type tool =
- | ExternalTool of name
- | InternalExecutable of name
-
-
- type vcs =
- | Darcs
- | Git
- | Svn
- | Cvs
- | Hg
- | Bzr
- | Arch
- | Monotone
- | OtherVCS of url
-
-
- type plugin_kind =
- [ `Configure
- | `Build
- | `Doc
- | `Test
- | `Install
- | `Extra
- ]
-
- type plugin_data_purpose =
- [ `Configure
- | `Build
- | `Install
- | `Clean
- | `Distclean
- | `Install
- | `Uninstall
- | `Test
- | `Doc
- | `Extra
- | `Other of string
- ]
-
- type 'a plugin = 'a * name * OASISVersion.t option
-
- type all_plugin = plugin_kind plugin
-
- type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list
-
-(* # 102 "src/oasis/OASISTypes.ml" *)
-
- type 'a conditional = 'a OASISExpr.choices
-
- type custom =
- {
- pre_command: (command_line option) conditional;
- post_command: (command_line option) conditional;
- }
-
-
- type common_section =
- {
- cs_name: name;
- cs_data: PropList.Data.t;
- cs_plugin_data: plugin_data;
- }
-
-
- type build_section =
- {
- bs_build: bool conditional;
- bs_install: bool conditional;
- bs_path: unix_dirname;
- bs_compiled_object: compiled_object;
- bs_build_depends: dependency list;
- bs_build_tools: tool list;
- bs_c_sources: unix_filename list;
- bs_data_files: (unix_filename * unix_filename option) list;
- bs_ccopt: args conditional;
- bs_cclib: args conditional;
- bs_dlllib: args conditional;
- bs_dllpath: args conditional;
- bs_byteopt: args conditional;
- bs_nativeopt: args conditional;
- }
-
-
- type library =
- {
- lib_modules: string list;
- lib_pack: bool;
- lib_internal_modules: string list;
- lib_findlib_parent: findlib_name option;
- lib_findlib_name: findlib_name option;
- lib_findlib_containers: findlib_name list;
- }
-
- type executable =
- {
- exec_custom: bool;
- exec_main_is: unix_filename;
- }
-
- type flag =
- {
- flag_description: string option;
- flag_default: bool conditional;
- }
-
- type source_repository =
- {
- src_repo_type: vcs;
- src_repo_location: url;
- src_repo_browser: url option;
- src_repo_module: string option;
- src_repo_branch: string option;
- src_repo_tag: string option;
- src_repo_subdir: unix_filename option;
- }
-
- type test =
- {
- test_type: [`Test] plugin;
- test_command: command_line conditional;
- test_custom: custom;
- test_working_directory: unix_filename option;
- test_run: bool conditional;
- test_tools: tool list;
- }
-
- type doc_format =
- | HTML of unix_filename
- | DocText
- | PDF
- | PostScript
- | Info of unix_filename
- | DVI
- | OtherDoc
-
-
- type doc =
- {
- doc_type: [`Doc] plugin;
- doc_custom: custom;
- doc_build: bool conditional;
- doc_install: bool conditional;
- doc_install_dir: unix_filename;
- doc_title: string;
- doc_authors: string list;
- doc_abstract: string option;
- doc_format: doc_format;
- doc_data_files: (unix_filename * unix_filename option) list;
- doc_build_tools: tool list;
- }
-
- type section =
- | Library of common_section * build_section * library
- | Executable of common_section * build_section * executable
- | Flag of common_section * flag
- | SrcRepo of common_section * source_repository
- | Test of common_section * test
- | Doc of common_section * doc
-
-
- type section_kind =
- [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ]
-
- type package =
- {
- oasis_version: OASISVersion.t;
- ocaml_version: OASISVersion.comparator option;
- findlib_version: OASISVersion.comparator option;
- name: package_name;
- version: OASISVersion.t;
- license: OASISLicense.t;
- license_file: unix_filename option;
- copyrights: string list;
- maintainers: string list;
- authors: string list;
- homepage: url option;
- synopsis: string;
- description: string option;
- categories: url list;
-
- conf_type: [`Configure] plugin;
- conf_custom: custom;
-
- build_type: [`Build] plugin;
- build_custom: custom;
-
- install_type: [`Install] plugin;
- install_custom: custom;
- uninstall_custom: custom;
-
- clean_custom: custom;
- distclean_custom: custom;
-
- files_ab: unix_filename list;
- sections: section list;
- plugins: [`Extra] plugin list;
- schema_data: PropList.Data.t;
- plugin_data: plugin_data;
- }
-
-end
-
-module OASISUnixPath = struct
-(* # 21 "src/oasis/OASISUnixPath.ml" *)
-
- type unix_filename = string
- type unix_dirname = string
-
- type host_filename = string
- type host_dirname = string
-
- let current_dir_name = "."
-
- let parent_dir_name = ".."
-
- let is_current_dir fn =
- fn = current_dir_name || fn = ""
-
- let concat f1 f2 =
- if is_current_dir f1 then
- f2
- else
- let f1' =
- try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1
- in
- f1'^"/"^f2
-
- let make =
- function
- | hd :: tl ->
- List.fold_left
- (fun f p -> concat f p)
- hd
- tl
- | [] ->
- invalid_arg "OASISUnixPath.make"
-
- let dirname f =
- try
- String.sub f 0 (String.rindex f '/')
- with Not_found ->
- current_dir_name
-
- let basename f =
- try
- let pos_start =
- (String.rindex f '/') + 1
- in
- String.sub f pos_start ((String.length f) - pos_start)
- with Not_found ->
- f
-
- let chop_extension f =
- try
- let last_dot =
- String.rindex f '.'
- in
- let sub =
- String.sub f 0 last_dot
- in
- try
- let last_slash =
- String.rindex f '/'
- in
- if last_slash < last_dot then
- sub
- else
- f
- with Not_found ->
- sub
-
- with Not_found ->
- f
-
- let capitalize_file f =
- let dir = dirname f in
- let base = basename f in
- concat dir (String.capitalize base)
-
- let uncapitalize_file f =
- let dir = dirname f in
- let base = basename f in
- concat dir (String.uncapitalize base)
-
-end
-
-module OASISHostPath = struct
-(* # 21 "src/oasis/OASISHostPath.ml" *)
-
-
- open Filename
-
- module Unix = OASISUnixPath
-
- let make =
- function
- | [] ->
- invalid_arg "OASISHostPath.make"
- | hd :: tl ->
- List.fold_left Filename.concat hd tl
-
- let of_unix ufn =
- if Sys.os_type = "Unix" then
- ufn
- else
- make
- (List.map
- (fun p ->
- if p = Unix.current_dir_name then
- current_dir_name
- else if p = Unix.parent_dir_name then
- parent_dir_name
- else
- p)
- (OASISString.nsplit ufn '/'))
-
-
-end
-
-module OASISSection = struct
-(* # 21 "src/oasis/OASISSection.ml" *)
-
- open OASISTypes
-
- let section_kind_common =
- function
- | Library (cs, _, _) ->
- `Library, cs
- | Executable (cs, _, _) ->
- `Executable, cs
- | Flag (cs, _) ->
- `Flag, cs
- | SrcRepo (cs, _) ->
- `SrcRepo, cs
- | Test (cs, _) ->
- `Test, cs
- | Doc (cs, _) ->
- `Doc, cs
-
- let section_common sct =
- snd (section_kind_common sct)
-
- let section_common_set cs =
- function
- | Library (_, bs, lib) -> Library (cs, bs, lib)
- | Executable (_, bs, exec) -> Executable (cs, bs, exec)
- | Flag (_, flg) -> Flag (cs, flg)
- | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo)
- | Test (_, tst) -> Test (cs, tst)
- | Doc (_, doc) -> Doc (cs, doc)
-
- (** Key used to identify section
- *)
- let section_id sct =
- let k, cs =
- section_kind_common sct
- in
- k, cs.cs_name
-
- let string_of_section sct =
- let k, nm =
- section_id sct
- in
- (match k with
- | `Library -> "library"
- | `Executable -> "executable"
- | `Flag -> "flag"
- | `SrcRepo -> "src repository"
- | `Test -> "test"
- | `Doc -> "doc")
- ^" "^nm
-
- let section_find id scts =
- List.find
- (fun sct -> id = section_id sct)
- scts
-
- module CSection =
- struct
- type t = section
-
- let id = section_id
-
- let compare t1 t2 =
- compare (id t1) (id t2)
-
- let equal t1 t2 =
- (id t1) = (id t2)
-
- let hash t =
- Hashtbl.hash (id t)
- end
-
- module MapSection = Map.Make(CSection)
- module SetSection = Set.Make(CSection)
-
-end
-
-module OASISBuildSection = struct
-(* # 21 "src/oasis/OASISBuildSection.ml" *)
-
-end
-
-module OASISExecutable = struct
-(* # 21 "src/oasis/OASISExecutable.ml" *)
-
- open OASISTypes
-
- let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program =
- let dir =
- OASISUnixPath.concat
- bs.bs_path
- (OASISUnixPath.dirname exec.exec_main_is)
- in
- let is_native_exec =
- match bs.bs_compiled_object with
- | Native -> true
- | Best -> is_native ()
- | Byte -> false
- in
-
- OASISUnixPath.concat
- dir
- (cs.cs_name^(suffix_program ())),
-
- if not is_native_exec &&
- not exec.exec_custom &&
- bs.bs_c_sources <> [] then
- Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ()))
- else
- None
-
-end
-
-module OASISLibrary = struct
-(* # 21 "src/oasis/OASISLibrary.ml" *)
-
- open OASISTypes
- open OASISUtils
- open OASISGettext
- open OASISSection
-
- type library_name = name
- type findlib_part_name = name
- type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t
-
- exception InternalLibraryNotFound of library_name
- exception FindlibPackageNotFound of findlib_name
-
- type group_t =
- | Container of findlib_name * group_t list
- | Package of (findlib_name *
- common_section *
- build_section *
- library *
- group_t list)
-
- (* Look for a module file, considering capitalization or not. *)
- let find_module source_file_exists (cs, bs, lib) modul =
- let possible_base_fn =
- List.map
- (OASISUnixPath.concat bs.bs_path)
- [modul;
- OASISUnixPath.uncapitalize_file modul;
- OASISUnixPath.capitalize_file modul]
- in
- (* TODO: we should be able to be able to determine the source for every
- * files. Hence we should introduce a Module(source: fn) for the fields
- * Modules and InternalModules
- *)
- List.fold_left
- (fun acc base_fn ->
- match acc with
- | `No_sources _ ->
- begin
- let file_found =
- List.fold_left
- (fun acc ext ->
- if source_file_exists (base_fn^ext) then
- (base_fn^ext) :: acc
- else
- acc)
- []
- [".ml"; ".mli"; ".mll"; ".mly"]
- in
- match file_found with
- | [] ->
- acc
- | lst ->
- `Sources (base_fn, lst)
- end
- | `Sources _ ->
- acc)
- (`No_sources possible_base_fn)
- possible_base_fn
-
- let source_unix_files ~ctxt (cs, bs, lib) source_file_exists =
- List.fold_left
- (fun acc modul ->
- match find_module source_file_exists (cs, bs, lib) modul with
- | `Sources (base_fn, lst) ->
- (base_fn, lst) :: acc
- | `No_sources _ ->
- OASISMessage.warning
- ~ctxt
- (f_ "Cannot find source file matching \
- module '%s' in library %s")
- modul cs.cs_name;
- acc)
- []
- (lib.lib_modules @ lib.lib_internal_modules)
-
- let generated_unix_files
- ~ctxt
- ~is_native
- ~has_native_dynlink
- ~ext_lib
- ~ext_dll
- ~source_file_exists
- (cs, bs, lib) =
-
- let find_modules lst ext =
- let find_module modul =
- match find_module source_file_exists (cs, bs, lib) modul with
- | `Sources (base_fn, _) ->
- [base_fn]
- | `No_sources lst ->
- OASISMessage.warning
- ~ctxt
- (f_ "Cannot find source file matching \
- module '%s' in library %s")
- modul cs.cs_name;
- lst
- in
- List.map
- (fun nm ->
- List.map
- (fun base_fn -> base_fn ^"."^ext)
- (find_module nm))
- lst
- in
-
- (* The headers that should be compiled along *)
- let headers =
- if lib.lib_pack then
- []
- else
- find_modules
- lib.lib_modules
- "cmi"
- in
-
- (* The .cmx that be compiled along *)
- let cmxs =
- let should_be_built =
- (not lib.lib_pack) && (* Do not install .cmx packed submodules *)
- match bs.bs_compiled_object with
- | Native -> true
- | Best -> is_native
- | Byte -> false
- in
- if should_be_built then
- find_modules
- (lib.lib_modules @ lib.lib_internal_modules)
- "cmx"
- else
- []
- in
-
- let acc_nopath =
- []
- in
-
- (* Compute what libraries should be built *)
- let acc_nopath =
- (* Add the packed header file if required *)
- let add_pack_header acc =
- if lib.lib_pack then
- [cs.cs_name^".cmi"] :: acc
- else
- acc
- in
- let byte acc =
- add_pack_header ([cs.cs_name^".cma"] :: acc)
- in
- let native acc =
- let acc =
- add_pack_header
- (if has_native_dynlink then
- [cs.cs_name^".cmxs"] :: acc
- else acc)
- in
- [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc
- in
- match bs.bs_compiled_object with
- | Native ->
- byte (native acc_nopath)
- | Best when is_native ->
- byte (native acc_nopath)
- | Byte | Best ->
- byte acc_nopath
- in
-
- (* Add C library to be built *)
- let acc_nopath =
- if bs.bs_c_sources <> [] then
- begin
- ["lib"^cs.cs_name^"_stubs"^ext_lib]
- ::
- ["dll"^cs.cs_name^"_stubs"^ext_dll]
- ::
- acc_nopath
- end
- else
- acc_nopath
- in
-
- (* All the files generated *)
- List.rev_append
- (List.rev_map
- (List.rev_map
- (OASISUnixPath.concat bs.bs_path))
- acc_nopath)
- (headers @ cmxs)
-
- type data = common_section * build_section * library
- type tree =
- | Node of (data option) * (tree MapString.t)
- | Leaf of data
-
- let findlib_mapping pkg =
- (* Map from library name to either full findlib name or parts + parent. *)
- let fndlb_parts_of_lib_name =
- let fndlb_parts cs lib =
- let name =
- match lib.lib_findlib_name with
- | Some nm -> nm
- | None -> cs.cs_name
- in
- let name =
- String.concat "." (lib.lib_findlib_containers @ [name])
- in
- name
- in
- List.fold_left
- (fun mp ->
- function
- | Library (cs, _, lib) ->
- begin
- let lib_name = cs.cs_name in
- let fndlb_parts = fndlb_parts cs lib in
- if MapString.mem lib_name mp then
- failwithf
- (f_ "The library name '%s' is used more than once.")
- lib_name;
- match lib.lib_findlib_parent with
- | Some lib_name_parent ->
- MapString.add
- lib_name
- (`Unsolved (lib_name_parent, fndlb_parts))
- mp
- | None ->
- MapString.add
- lib_name
- (`Solved fndlb_parts)
- mp
- end
-
- | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ ->
- mp)
- MapString.empty
- pkg.sections
- in
-
- (* Solve the above graph to be only library name to full findlib name. *)
- let fndlb_name_of_lib_name =
- let rec solve visited mp lib_name lib_name_child =
- if SetString.mem lib_name visited then
- failwithf
- (f_ "Library '%s' is involved in a cycle \
- with regard to findlib naming.")
- lib_name;
- let visited = SetString.add lib_name visited in
- try
- match MapString.find lib_name mp with
- | `Solved fndlb_nm ->
- fndlb_nm, mp
- | `Unsolved (lib_nm_parent, post_fndlb_nm) ->
- let pre_fndlb_nm, mp =
- solve visited mp lib_nm_parent lib_name
- in
- let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in
- fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp
- with Not_found ->
- failwithf
- (f_ "Library '%s', which is defined as the findlib parent of \
- library '%s', doesn't exist.")
- lib_name lib_name_child
- in
- let mp =
- MapString.fold
- (fun lib_name status mp ->
- match status with
- | `Solved _ ->
- (* Solved initialy, no need to go further *)
- mp
- | `Unsolved _ ->
- let _, mp = solve SetString.empty mp lib_name "<none>" in
- mp)
- fndlb_parts_of_lib_name
- fndlb_parts_of_lib_name
- in
- MapString.map
- (function
- | `Solved fndlb_nm -> fndlb_nm
- | `Unsolved _ -> assert false)
- mp
- in
-
- (* Convert an internal library name to a findlib name. *)
- let findlib_name_of_library_name lib_nm =
- try
- MapString.find lib_nm fndlb_name_of_lib_name
- with Not_found ->
- raise (InternalLibraryNotFound lib_nm)
- in
-
- (* Add a library to the tree.
- *)
- let add sct mp =
- let fndlb_fullname =
- let cs, _, _ = sct in
- let lib_name = cs.cs_name in
- findlib_name_of_library_name lib_name
- in
- let rec add_children nm_lst (children : tree MapString.t) =
- match nm_lst with
- | (hd :: tl) ->
- begin
- let node =
- try
- add_node tl (MapString.find hd children)
- with Not_found ->
- (* New node *)
- new_node tl
- in
- MapString.add hd node children
- end
- | [] ->
- (* Should not have a nameless library. *)
- assert false
- and add_node tl node =
- if tl = [] then
- begin
- match node with
- | Node (None, children) ->
- Node (Some sct, children)
- | Leaf (cs', _, _) | Node (Some (cs', _, _), _) ->
- (* TODO: allow to merge Package, i.e.
- * archive(byte) = "foo.cma foo_init.cmo"
- *)
- let cs, _, _ = sct in
- failwithf
- (f_ "Library '%s' and '%s' have the same findlib name '%s'")
- cs.cs_name cs'.cs_name fndlb_fullname
- end
- else
- begin
- match node with
- | Leaf data ->
- Node (Some data, add_children tl MapString.empty)
- | Node (data_opt, children) ->
- Node (data_opt, add_children tl children)
- end
- and new_node =
- function
- | [] ->
- Leaf sct
- | hd :: tl ->
- Node (None, MapString.add hd (new_node tl) MapString.empty)
- in
- add_children (OASISString.nsplit fndlb_fullname '.') mp
- in
-
- let rec group_of_tree mp =
- MapString.fold
- (fun nm node acc ->
- let cur =
- match node with
- | Node (Some (cs, bs, lib), children) ->
- Package (nm, cs, bs, lib, group_of_tree children)
- | Node (None, children) ->
- Container (nm, group_of_tree children)
- | Leaf (cs, bs, lib) ->
- Package (nm, cs, bs, lib, [])
- in
- cur :: acc)
- mp []
- in
-
- let group_mp =
- List.fold_left
- (fun mp ->
- function
- | Library (cs, bs, lib) ->
- add (cs, bs, lib) mp
- | _ ->
- mp)
- MapString.empty
- pkg.sections
- in
-
- let groups =
- group_of_tree group_mp
- in
-
- let library_name_of_findlib_name =
- Lazy.lazy_from_fun
- (fun () ->
- (* Revert findlib_name_of_library_name. *)
- MapString.fold
- (fun k v mp -> MapString.add v k mp)
- fndlb_name_of_lib_name
- MapString.empty)
- in
- let library_name_of_findlib_name fndlb_nm =
- try
- MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name)
- with Not_found ->
- raise (FindlibPackageNotFound fndlb_nm)
- in
-
- groups,
- findlib_name_of_library_name,
- library_name_of_findlib_name
-
- let findlib_of_group =
- function
- | Container (fndlb_nm, _)
- | Package (fndlb_nm, _, _, _, _) -> fndlb_nm
-
- let root_of_group grp =
- let rec root_lib_aux =
- (* We do a DFS in the group. *)
- function
- | Container (_, children) ->
- List.fold_left
- (fun res grp ->
- if res = None then
- root_lib_aux grp
- else
- res)
- None
- children
- | Package (_, cs, bs, lib, _) ->
- Some (cs, bs, lib)
- in
- match root_lib_aux grp with
- | Some res ->
- res
- | None ->
- failwithf
- (f_ "Unable to determine root library of findlib library '%s'")
- (findlib_of_group grp)
-
-end
-
-module OASISFlag = struct
-(* # 21 "src/oasis/OASISFlag.ml" *)
-
-end
-
-module OASISPackage = struct
-(* # 21 "src/oasis/OASISPackage.ml" *)
-
-end
-
-module OASISSourceRepository = struct
-(* # 21 "src/oasis/OASISSourceRepository.ml" *)
-
-end
-
-module OASISTest = struct
-(* # 21 "src/oasis/OASISTest.ml" *)
-
-end
-
-module OASISDocument = struct
-(* # 21 "src/oasis/OASISDocument.ml" *)
-
-end
-
-module OASISExec = struct
-(* # 21 "src/oasis/OASISExec.ml" *)
-
- open OASISGettext
- open OASISUtils
- open OASISMessage
-
- (* TODO: I don't like this quote, it is there because $(rm) foo expands to
- * 'rm -f' foo...
- *)
- let run ~ctxt ?f_exit_code ?(quote=true) cmd args =
- let cmd =
- if quote then
- if Sys.os_type = "Win32" then
- if String.contains cmd ' ' then
- (* Double the 1st double quote... win32... sigh *)
- "\""^(Filename.quote cmd)
- else
- cmd
- else
- Filename.quote cmd
- else
- cmd
- in
- let cmdline =
- String.concat " " (cmd :: args)
- in
- info ~ctxt (f_ "Running command '%s'") cmdline;
- match f_exit_code, Sys.command cmdline with
- | None, 0 -> ()
- | None, i ->
- failwithf
- (f_ "Command '%s' terminated with error code %d")
- cmdline i
- | Some f, i ->
- f i
-
- let run_read_output ~ctxt ?f_exit_code cmd args =
- let fn =
- Filename.temp_file "oasis-" ".txt"
- in
- try
- begin
- let () =
- run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn])
- in
- let chn =
- open_in fn
- in
- let routput =
- ref []
- in
- begin
- try
- while true do
- routput := (input_line chn) :: !routput
- done
- with End_of_file ->
- ()
- end;
- close_in chn;
- Sys.remove fn;
- List.rev !routput
- end
- with e ->
- (try Sys.remove fn with _ -> ());
- raise e
-
- let run_read_one_line ~ctxt ?f_exit_code cmd args =
- match run_read_output ~ctxt ?f_exit_code cmd args with
- | [fst] ->
- fst
- | lst ->
- failwithf
- (f_ "Command return unexpected output %S")
- (String.concat "\n" lst)
-end
-
-module OASISFileUtil = struct
-(* # 21 "src/oasis/OASISFileUtil.ml" *)
-
- open OASISGettext
-
- let file_exists_case fn =
- let dirname = Filename.dirname fn in
- let basename = Filename.basename fn in
- if Sys.file_exists dirname then
- if basename = Filename.current_dir_name then
- true
- else
- List.mem
- basename
- (Array.to_list (Sys.readdir dirname))
- else
- false
-
- let find_file ?(case_sensitive=true) paths exts =
-
- (* Cardinal product of two list *)
- let ( * ) lst1 lst2 =
- List.flatten
- (List.map
- (fun a ->
- List.map
- (fun b -> a,b)
- lst2)
- lst1)
- in
-
- let rec combined_paths lst =
- match lst with
- | p1 :: p2 :: tl ->
- let acc =
- (List.map
- (fun (a,b) -> Filename.concat a b)
- (p1 * p2))
- in
- combined_paths (acc :: tl)
- | [e] ->
- e
- | [] ->
- []
- in
-
- let alternatives =
- List.map
- (fun (p,e) ->
- if String.length e > 0 && e.[0] <> '.' then
- p ^ "." ^ e
- else
- p ^ e)
- ((combined_paths paths) * exts)
- in
- List.find
- (if case_sensitive then
- file_exists_case
- else
- Sys.file_exists)
- alternatives
-
- let which ~ctxt prg =
- let path_sep =
- match Sys.os_type with
- | "Win32" ->
- ';'
- | _ ->
- ':'
- in
- let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in
- let exec_ext =
- match Sys.os_type with
- | "Win32" ->
- "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep)
- | _ ->
- [""]
- in
- find_file ~case_sensitive:false [path_lst; [prg]] exec_ext
-
- (**/**)
- let rec fix_dir dn =
- (* Windows hack because Sys.file_exists "src\\" = false when
- * Sys.file_exists "src" = true
- *)
- let ln =
- String.length dn
- in
- if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then
- fix_dir (String.sub dn 0 (ln - 1))
- else
- dn
-
- let q = Filename.quote
- (**/**)
-
- let cp ~ctxt ?(recurse=false) src tgt =
- if recurse then
- match Sys.os_type with
- | "Win32" ->
- OASISExec.run ~ctxt
- "xcopy" [q src; q tgt; "/E"]
- | _ ->
- OASISExec.run ~ctxt
- "cp" ["-r"; q src; q tgt]
- else
- OASISExec.run ~ctxt
- (match Sys.os_type with
- | "Win32" -> "copy"
- | _ -> "cp")
- [q src; q tgt]
-
- let mkdir ~ctxt tgt =
- OASISExec.run ~ctxt
- (match Sys.os_type with
- | "Win32" -> "md"
- | _ -> "mkdir")
- [q tgt]
-
- let rec mkdir_parent ~ctxt f tgt =
- let tgt =
- fix_dir tgt
- in
- if Sys.file_exists tgt then
- begin
- if not (Sys.is_directory tgt) then
- OASISUtils.failwithf
- (f_ "Cannot create directory '%s', a file of the same name already \
- exists")
- tgt
- end
- else
- begin
- mkdir_parent ~ctxt f (Filename.dirname tgt);
- if not (Sys.file_exists tgt) then
- begin
- f tgt;
- mkdir ~ctxt tgt
- end
- end
-
- let rmdir ~ctxt tgt =
- if Sys.readdir tgt = [||] then
- begin
- match Sys.os_type with
- | "Win32" ->
- OASISExec.run ~ctxt "rd" [q tgt]
- | _ ->
- OASISExec.run ~ctxt "rm" ["-r"; q tgt]
- end
-
- let glob ~ctxt fn =
- let basename =
- Filename.basename fn
- in
- if String.length basename >= 2 &&
- basename.[0] = '*' &&
- basename.[1] = '.' then
- begin
- let ext_len =
- (String.length basename) - 2
- in
- let ext =
- String.sub basename 2 ext_len
- in
- let dirname =
- Filename.dirname fn
- in
- Array.fold_left
- (fun acc fn ->
- try
- let fn_ext =
- String.sub
- fn
- ((String.length fn) - ext_len)
- ext_len
- in
- if fn_ext = ext then
- (Filename.concat dirname fn) :: acc
- else
- acc
- with Invalid_argument _ ->
- acc)
- []
- (Sys.readdir dirname)
- end
- else
- begin
- if file_exists_case fn then
- [fn]
- else
- []
- end
-end
-
-
-# 2142 "setup.ml"
-module BaseEnvLight = struct
-(* # 21 "src/base/BaseEnvLight.ml" *)
-
- module MapString = Map.Make(String)
-
- type t = string MapString.t
-
- let default_filename =
- Filename.concat
- (Sys.getcwd ())
- "setup.data"
-
- let load ?(allow_empty=false) ?(filename=default_filename) () =
- if Sys.file_exists filename then
- begin
- let chn =
- open_in_bin filename
- in
- let st =
- Stream.of_channel chn
- in
- let line =
- ref 1
- in
- let st_line =
- Stream.from
- (fun _ ->
- try
- match Stream.next st with
- | '\n' -> incr line; Some '\n'
- | c -> Some c
- with Stream.Failure -> None)
- in
- let lexer =
- Genlex.make_lexer ["="] st_line
- in
- let rec read_file mp =
- match Stream.npeek 3 lexer with
- | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
- Stream.junk lexer;
- Stream.junk lexer;
- Stream.junk lexer;
- read_file (MapString.add nm value mp)
- | [] ->
- mp
- | _ ->
- failwith
- (Printf.sprintf
- "Malformed data file '%s' line %d"
- filename !line)
- in
- let mp =
- read_file MapString.empty
- in
- close_in chn;
- mp
- end
- else if allow_empty then
- begin
- MapString.empty
- end
- else
- begin
- failwith
- (Printf.sprintf
- "Unable to load environment, the file '%s' doesn't exist."
- filename)
- end
-
- let var_get name env =
- let rec var_expand str =
- let buff =
- Buffer.create ((String.length str) * 2)
- in
- Buffer.add_substitute
- buff
- (fun var ->
- try
- var_expand (MapString.find var env)
- with Not_found ->
- failwith
- (Printf.sprintf
- "No variable %s defined when trying to expand %S."
- var
- str))
- str;
- Buffer.contents buff
- in
- var_expand (MapString.find name env)
-
- let var_choose lst env =
- OASISExpr.choose
- (fun nm -> var_get nm env)
- lst
-end
-
-
-# 2240 "setup.ml"
-module BaseContext = struct
-(* # 21 "src/base/BaseContext.ml" *)
-
- open OASISContext
-
- let args = args
-
- let default = default
-
-end
-
-module BaseMessage = struct
-(* # 21 "src/base/BaseMessage.ml" *)
-
- (** Message to user, overrid for Base
- @author Sylvain Le Gall
- *)
- open OASISMessage
- open BaseContext
-
- let debug fmt = debug ~ctxt:!default fmt
-
- let info fmt = info ~ctxt:!default fmt
-
- let warning fmt = warning ~ctxt:!default fmt
-
- let error fmt = error ~ctxt:!default fmt
-
-end
-
-module BaseEnv = struct
-(* # 21 "src/base/BaseEnv.ml" *)
-
- open OASISGettext
- open OASISUtils
- open PropList
-
- module MapString = BaseEnvLight.MapString
-
- type origin_t =
- | ODefault
- | OGetEnv
- | OFileLoad
- | OCommandLine
-
- type cli_handle_t =
- | CLINone
- | CLIAuto
- | CLIWith
- | CLIEnable
- | CLIUser of (Arg.key * Arg.spec * Arg.doc) list
-
- type definition_t =
- {
- hide: bool;
- dump: bool;
- cli: cli_handle_t;
- arg_help: string option;
- group: string option;
- }
-
- let schema =
- Schema.create "environment"
-
- (* Environment data *)
- let env =
- Data.create ()
-
- (* Environment data from file *)
- let env_from_file =
- ref MapString.empty
-
- (* Lexer for var *)
- let var_lxr =
- Genlex.make_lexer []
-
- let rec var_expand str =
- let buff =
- Buffer.create ((String.length str) * 2)
- in
- Buffer.add_substitute
- buff
- (fun var ->
- try
- (* TODO: this is a quick hack to allow calling Test.Command
- * without defining executable name really. I.e. if there is
- * an exec Executable toto, then $(toto) should be replace
- * by its real name. It is however useful to have this function
- * for other variable that depend on the host and should be
- * written better than that.
- *)
- let st =
- var_lxr (Stream.of_string var)
- in
- match Stream.npeek 3 st with
- | [Genlex.Ident "utoh"; Genlex.Ident nm] ->
- OASISHostPath.of_unix (var_get nm)
- | [Genlex.Ident "utoh"; Genlex.String s] ->
- OASISHostPath.of_unix s
- | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] ->
- String.escaped (var_get nm)
- | [Genlex.Ident "ocaml_escaped"; Genlex.String s] ->
- String.escaped s
- | [Genlex.Ident nm] ->
- var_get nm
- | _ ->
- failwithf
- (f_ "Unknown expression '%s' in variable expansion of %s.")
- var
- str
- with
- | Unknown_field (_, _) ->
- failwithf
- (f_ "No variable %s defined when trying to expand %S.")
- var
- str
- | Stream.Error e ->
- failwithf
- (f_ "Syntax error when parsing '%s' when trying to \
- expand %S: %s")
- var
- str
- e)
- str;
- Buffer.contents buff
-
- and var_get name =
- let vl =
- try
- Schema.get schema env name
- with Unknown_field _ as e ->
- begin
- try
- MapString.find name !env_from_file
- with Not_found ->
- raise e
- end
- in
- var_expand vl
-
- let var_choose ?printer ?name lst =
- OASISExpr.choose
- ?printer
- ?name
- var_get
- lst
-
- let var_protect vl =
- let buff =
- Buffer.create (String.length vl)
- in
- String.iter
- (function
- | '$' -> Buffer.add_string buff "\\$"
- | c -> Buffer.add_char buff c)
- vl;
- Buffer.contents buff
-
- let var_define
- ?(hide=false)
- ?(dump=true)
- ?short_desc
- ?(cli=CLINone)
- ?arg_help
- ?group
- name (* TODO: type constraint on the fact that name must be a valid OCaml
- id *)
- dflt =
-
- let default =
- [
- OFileLoad, (fun () -> MapString.find name !env_from_file);
- ODefault, dflt;
- OGetEnv, (fun () -> Sys.getenv name);
- ]
- in
-
- let extra =
- {
- hide = hide;
- dump = dump;
- cli = cli;
- arg_help = arg_help;
- group = group;
- }
- in
-
- (* Try to find a value that can be defined
- *)
- let var_get_low lst =
- let errors, res =
- List.fold_left
- (fun (errors, res) (o, v) ->
- if res = None then
- begin
- try
- errors, Some (v ())
- with
- | Not_found ->
- errors, res
- | Failure rsn ->
- (rsn :: errors), res
- | e ->
- (Printexc.to_string e) :: errors, res
- end
- else
- errors, res)
- ([], None)
- (List.sort
- (fun (o1, _) (o2, _) ->
- Pervasives.compare o2 o1)
- lst)
- in
- match res, errors with
- | Some v, _ ->
- v
- | None, [] ->
- raise (Not_set (name, None))
- | None, lst ->
- raise (Not_set (name, Some (String.concat (s_ ", ") lst)))
- in
-
- let help =
- match short_desc with
- | Some fs -> Some fs
- | None -> None
- in
-
- let var_get_lst =
- FieldRO.create
- ~schema
- ~name
- ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s])
- ~print:var_get_low
- ~default
- ~update:(fun ?context x old_x -> x @ old_x)
- ?help
- extra
- in
-
- fun () ->
- var_expand (var_get_low (var_get_lst env))
-
- let var_redefine
- ?hide
- ?dump
- ?short_desc
- ?cli
- ?arg_help
- ?group
- name
- dflt =
- if Schema.mem schema name then
- begin
- (* TODO: look suspsicious, we want to memorize dflt not dflt () *)
- Schema.set schema env ~context:ODefault name (dflt ());
- fun () -> var_get name
- end
- else
- begin
- var_define
- ?hide
- ?dump
- ?short_desc
- ?cli
- ?arg_help
- ?group
- name
- dflt
- end
-
- let var_ignore (e : unit -> string) =
- ()
-
- let print_hidden =
- var_define
- ~hide:true
- ~dump:false
- ~cli:CLIAuto
- ~arg_help:"Print even non-printable variable. (debug)"
- "print_hidden"
- (fun () -> "false")
-
- let var_all () =
- List.rev
- (Schema.fold
- (fun acc nm def _ ->
- if not def.hide || bool_of_string (print_hidden ()) then
- nm :: acc
- else
- acc)
- []
- schema)
-
- let default_filename =
- BaseEnvLight.default_filename
-
- let load ?allow_empty ?filename () =
- env_from_file := BaseEnvLight.load ?allow_empty ?filename ()
-
- let unload () =
- env_from_file := MapString.empty;
- Data.clear env
-
- let dump ?(filename=default_filename) () =
- let chn =
- open_out_bin filename
- in
- let output nm value =
- Printf.fprintf chn "%s=%S\n" nm value
- in
- let mp_todo =
- (* Dump data from schema *)
- Schema.fold
- (fun mp_todo nm def _ ->
- if def.dump then
- begin
- try
- let value =
- Schema.get
- schema
- env
- nm
- in
- output nm value
- with Not_set _ ->
- ()
- end;
- MapString.remove nm mp_todo)
- !env_from_file
- schema
- in
- (* Dump data defined outside of schema *)
- MapString.iter output mp_todo;
-
- (* End of the dump *)
- close_out chn
-
- let print () =
- let printable_vars =
- Schema.fold
- (fun acc nm def short_descr_opt ->
- if not def.hide || bool_of_string (print_hidden ()) then
- begin
- try
- let value =
- Schema.get
- schema
- env
- nm
- in
- let txt =
- match short_descr_opt with
- | Some s -> s ()
- | None -> nm
- in
- (txt, value) :: acc
- with Not_set _ ->
- acc
- end
- else
- acc)
- []
- schema
- in
- let max_length =
- List.fold_left max 0
- (List.rev_map String.length
- (List.rev_map fst printable_vars))
- in
- let dot_pad str =
- String.make ((max_length - (String.length str)) + 3) '.'
- in
-
- Printf.printf "\nConfiguration: \n";
- List.iter
- (fun (name,value) ->
- Printf.printf "%s: %s %s\n" name (dot_pad name) value)
- (List.rev printable_vars);
- Printf.printf "\n%!"
-
- let args () =
- let arg_concat =
- OASISUtils.varname_concat ~hyphen:'-'
- in
- [
- "--override",
- Arg.Tuple
- (
- let rvr = ref ""
- in
- let rvl = ref ""
- in
- [
- Arg.Set_string rvr;
- Arg.Set_string rvl;
- Arg.Unit
- (fun () ->
- Schema.set
- schema
- env
- ~context:OCommandLine
- !rvr
- !rvl)
- ]
- ),
- "var+val Override any configuration variable.";
-
- ]
- @
- List.flatten
- (Schema.fold
- (fun acc name def short_descr_opt ->
- let var_set s =
- Schema.set
- schema
- env
- ~context:OCommandLine
- name
- s
- in
-
- let arg_name =
- OASISUtils.varname_of_string ~hyphen:'-' name
- in
-
- let hlp =
- match short_descr_opt with
- | Some txt -> txt ()
- | None -> ""
- in
-
- let arg_hlp =
- match def.arg_help with
- | Some s -> s
- | None -> "str"
- in
-
- let default_value =
- try
- Printf.sprintf
- (f_ " [%s]")
- (Schema.get
- schema
- env
- name)
- with Not_set _ ->
- ""
- in
-
- let args =
- match def.cli with
- | CLINone ->
- []
- | CLIAuto ->
- [
- arg_concat "--" arg_name,
- Arg.String var_set,
- Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value
- ]
- | CLIWith ->
- [
- arg_concat "--with-" arg_name,
- Arg.String var_set,
- Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value
- ]
- | CLIEnable ->
- let dflt =
- if default_value = " [true]" then
- s_ " [default: enabled]"
- else
- s_ " [default: disabled]"
- in
- [
- arg_concat "--enable-" arg_name,
- Arg.Unit (fun () -> var_set "true"),
- Printf.sprintf (f_ " %s%s") hlp dflt;
-
- arg_concat "--disable-" arg_name,
- Arg.Unit (fun () -> var_set "false"),
- Printf.sprintf (f_ " %s%s") hlp dflt
- ]
- | CLIUser lst ->
- lst
- in
- args :: acc)
- []
- schema)
-end
-
-module BaseArgExt = struct
-(* # 21 "src/base/BaseArgExt.ml" *)
-
- open OASISUtils
- open OASISGettext
-
- let parse argv args =
- (* Simulate command line for Arg *)
- let current =
- ref 0
- in
-
- try
- Arg.parse_argv
- ~current:current
- (Array.concat [[|"none"|]; argv])
- (Arg.align args)
- (failwithf (f_ "Don't know what to do with arguments: '%s'"))
- (s_ "configure options:")
- with
- | Arg.Help txt ->
- print_endline txt;
- exit 0
- | Arg.Bad txt ->
- prerr_endline txt;
- exit 1
-end
-
-module BaseCheck = struct
-(* # 21 "src/base/BaseCheck.ml" *)
-
- open BaseEnv
- open BaseMessage
- open OASISUtils
- open OASISGettext
-
- let prog_best prg prg_lst =
- var_redefine
- prg
- (fun () ->
- let alternate =
- List.fold_left
- (fun res e ->
- match res with
- | Some _ ->
- res
- | None ->
- try
- Some (OASISFileUtil.which ~ctxt:!BaseContext.default e)
- with Not_found ->
- None)
- None
- prg_lst
- in
- match alternate with
- | Some prg -> prg
- | None -> raise Not_found)
-
- let prog prg =
- prog_best prg [prg]
-
- let prog_opt prg =
- prog_best prg [prg^".opt"; prg]
-
- let ocamlfind =
- prog "ocamlfind"
-
- let version
- var_prefix
- cmp
- fversion
- () =
- (* Really compare version provided *)
- let var =
- var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp)
- in
- var_redefine
- ~hide:true
- var
- (fun () ->
- let version_str =
- match fversion () with
- | "[Distributed with OCaml]" ->
- begin
- try
- (var_get "ocaml_version")
- with Not_found ->
- warning
- (f_ "Variable ocaml_version not defined, fallback \
- to default");
- Sys.ocaml_version
- end
- | res ->
- res
- in
- let version =
- OASISVersion.version_of_string version_str
- in
- if OASISVersion.comparator_apply version cmp then
- version_str
- else
- failwithf
- (f_ "Cannot satisfy version constraint on %s: %s (version: %s)")
- var_prefix
- (OASISVersion.string_of_comparator cmp)
- version_str)
- ()
-
- let package_version pkg =
- OASISExec.run_read_one_line ~ctxt:!BaseContext.default
- (ocamlfind ())
- ["query"; "-format"; "%v"; pkg]
-
- let package ?version_comparator pkg () =
- let var =
- OASISUtils.varname_concat
- "pkg_"
- (OASISUtils.varname_of_string pkg)
- in
- let findlib_dir pkg =
- let dir =
- OASISExec.run_read_one_line ~ctxt:!BaseContext.default
- (ocamlfind ())
- ["query"; "-format"; "%d"; pkg]
- in
- if Sys.file_exists dir && Sys.is_directory dir then
- dir
- else
- failwithf
- (f_ "When looking for findlib package %s, \
- directory %s return doesn't exist")
- pkg dir
- in
- let vl =
- var_redefine
- var
- (fun () -> findlib_dir pkg)
- ()
- in
- (
- match version_comparator with
- | Some ver_cmp ->
- ignore
- (version
- var
- ver_cmp
- (fun _ -> package_version pkg)
- ())
- | None ->
- ()
- );
- vl
-end
-
-module BaseOCamlcConfig = struct
-(* # 21 "src/base/BaseOCamlcConfig.ml" *)
-
-
- open BaseEnv
- open OASISUtils
- open OASISGettext
-
- module SMap = Map.Make(String)
-
- let ocamlc =
- BaseCheck.prog_opt "ocamlc"
-
- let ocamlc_config_map =
- (* Map name to value for ocamlc -config output
- (name ^": "^value)
- *)
- let rec split_field mp lst =
- match lst with
- | line :: tl ->
- let mp =
- try
- let pos_semicolon =
- String.index line ':'
- in
- if pos_semicolon > 1 then
- (
- let name =
- String.sub line 0 pos_semicolon
- in
- let linelen =
- String.length line
- in
- let value =
- if linelen > pos_semicolon + 2 then
- String.sub
- line
- (pos_semicolon + 2)
- (linelen - pos_semicolon - 2)
- else
- ""
- in
- SMap.add name value mp
- )
- else
- (
- mp
- )
- with Not_found ->
- (
- mp
- )
- in
- split_field mp tl
- | [] ->
- mp
- in
-
- let cache =
- lazy
- (var_protect
- (Marshal.to_string
- (split_field
- SMap.empty
- (OASISExec.run_read_output
- ~ctxt:!BaseContext.default
- (ocamlc ()) ["-config"]))
- []))
- in
- var_redefine
- "ocamlc_config_map"
- ~hide:true
- ~dump:false
- (fun () ->
- (* TODO: update if ocamlc change !!! *)
- Lazy.force cache)
-
- let var_define nm =
- (* Extract data from ocamlc -config *)
- let avlbl_config_get () =
- Marshal.from_string
- (ocamlc_config_map ())
- 0
- in
- let chop_version_suffix s =
- try
- String.sub s 0 (String.index s '+')
- with _ ->
- s
- in
-
- let nm_config, value_config =
- match nm with
- | "ocaml_version" ->
- "version", chop_version_suffix
- | _ -> nm, (fun x -> x)
- in
- var_redefine
- nm
- (fun () ->
- try
- let map =
- avlbl_config_get ()
- in
- let value =
- SMap.find nm_config map
- in
- value_config value
- with Not_found ->
- failwithf
- (f_ "Cannot find field '%s' in '%s -config' output")
- nm
- (ocamlc ()))
-
-end
-
-module BaseStandardVar = struct
-(* # 21 "src/base/BaseStandardVar.ml" *)
-
-
- open OASISGettext
- open OASISTypes
- open OASISExpr
- open BaseCheck
- open BaseEnv
-
- let ocamlfind = BaseCheck.ocamlfind
- let ocamlc = BaseOCamlcConfig.ocamlc
- let ocamlopt = prog_opt "ocamlopt"
- let ocamlbuild = prog "ocamlbuild"
-
-
- (**/**)
- let rpkg =
- ref None
-
- let pkg_get () =
- match !rpkg with
- | Some pkg -> pkg
- | None -> failwith (s_ "OASIS Package is not set")
-
- let var_cond = ref []
-
- let var_define_cond ~since_version f dflt =
- let holder = ref (fun () -> dflt) in
- let since_version =
- OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version)
- in
- var_cond :=
- (fun ver ->
- if OASISVersion.comparator_apply ver since_version then
- holder := f ()) :: !var_cond;
- fun () -> !holder ()
-
- (**/**)
-
- let pkg_name =
- var_define
- ~short_desc:(fun () -> s_ "Package name")
- "pkg_name"
- (fun () -> (pkg_get ()).name)
-
- let pkg_version =
- var_define
- ~short_desc:(fun () -> s_ "Package version")
- "pkg_version"
- (fun () ->
- (OASISVersion.string_of_version (pkg_get ()).version))
-
- let c = BaseOCamlcConfig.var_define
-
- let os_type = c "os_type"
- let system = c "system"
- let architecture = c "architecture"
- let ccomp_type = c "ccomp_type"
- let ocaml_version = c "ocaml_version"
-
- (* TODO: Check standard variable presence at runtime *)
-
- let standard_library_default = c "standard_library_default"
- let standard_library = c "standard_library"
- let standard_runtime = c "standard_runtime"
- let bytecomp_c_compiler = c "bytecomp_c_compiler"
- let native_c_compiler = c "native_c_compiler"
- let model = c "model"
- let ext_obj = c "ext_obj"
- let ext_asm = c "ext_asm"
- let ext_lib = c "ext_lib"
- let ext_dll = c "ext_dll"
- let default_executable_name = c "default_executable_name"
- let systhread_supported = c "systhread_supported"
-
- let flexlink =
- BaseCheck.prog "flexlink"
-
- let flexdll_version =
- var_define
- ~short_desc:(fun () -> "FlexDLL version (Win32)")
- "flexdll_version"
- (fun () ->
- let lst =
- OASISExec.run_read_output ~ctxt:!BaseContext.default
- (flexlink ()) ["-help"]
- in
- match lst with
- | line :: _ ->
- Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver)
- | [] ->
- raise Not_found)
-
- (**/**)
- let p name hlp dflt =
- var_define
- ~short_desc:hlp
- ~cli:CLIAuto
- ~arg_help:"dir"
- name
- dflt
-
- let (/) a b =
- if os_type () = Sys.os_type then
- Filename.concat a b
- else if os_type () = "Unix" then
- OASISUnixPath.concat a b
- else
- OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat")
- (os_type ())
- (**/**)
-
- let prefix =
- p "prefix"
- (fun () -> s_ "Install architecture-independent files dir")
- (fun () ->
- match os_type () with
- | "Win32" ->
- let program_files =
- Sys.getenv "PROGRAMFILES"
- in
- program_files/(pkg_name ())
- | _ ->
- "/usr/local")
-
- let exec_prefix =
- p "exec_prefix"
- (fun () -> s_ "Install architecture-dependent files in dir")
- (fun () -> "$prefix")
-
- let bindir =
- p "bindir"
- (fun () -> s_ "User executables")
- (fun () -> "$exec_prefix"/"bin")
-
- let sbindir =
- p "sbindir"
- (fun () -> s_ "System admin executables")
- (fun () -> "$exec_prefix"/"sbin")
-
- let libexecdir =
- p "libexecdir"
- (fun () -> s_ "Program executables")
- (fun () -> "$exec_prefix"/"libexec")
-
- let sysconfdir =
- p "sysconfdir"
- (fun () -> s_ "Read-only single-machine data")
- (fun () -> "$prefix"/"etc")
-
- let sharedstatedir =
- p "sharedstatedir"
- (fun () -> s_ "Modifiable architecture-independent data")
- (fun () -> "$prefix"/"com")
-
- let localstatedir =
- p "localstatedir"
- (fun () -> s_ "Modifiable single-machine data")
- (fun () -> "$prefix"/"var")
-
- let libdir =
- p "libdir"
- (fun () -> s_ "Object code libraries")
- (fun () -> "$exec_prefix"/"lib")
-
- let datarootdir =
- p "datarootdir"
- (fun () -> s_ "Read-only arch-independent data root")
- (fun () -> "$prefix"/"share")
-
- let datadir =
- p "datadir"
- (fun () -> s_ "Read-only architecture-independent data")
- (fun () -> "$datarootdir")
-
- let infodir =
- p "infodir"
- (fun () -> s_ "Info documentation")
- (fun () -> "$datarootdir"/"info")
-
- let localedir =
- p "localedir"
- (fun () -> s_ "Locale-dependent data")
- (fun () -> "$datarootdir"/"locale")
-
- let mandir =
- p "mandir"
- (fun () -> s_ "Man documentation")
- (fun () -> "$datarootdir"/"man")
-
- let docdir =
- p "docdir"
- (fun () -> s_ "Documentation root")
- (fun () -> "$datarootdir"/"doc"/"$pkg_name")
-
- let htmldir =
- p "htmldir"
- (fun () -> s_ "HTML documentation")
- (fun () -> "$docdir")
-
- let dvidir =
- p "dvidir"
- (fun () -> s_ "DVI documentation")
- (fun () -> "$docdir")
-
- let pdfdir =
- p "pdfdir"
- (fun () -> s_ "PDF documentation")
- (fun () -> "$docdir")
-
- let psdir =
- p "psdir"
- (fun () -> s_ "PS documentation")
- (fun () -> "$docdir")
-
- let destdir =
- p "destdir"
- (fun () -> s_ "Prepend a path when installing package")
- (fun () ->
- raise
- (PropList.Not_set
- ("destdir",
- Some (s_ "undefined by construct"))))
-
- let findlib_version =
- var_define
- "findlib_version"
- (fun () ->
- BaseCheck.package_version "findlib")
-
- let is_native =
- var_define
- "is_native"
- (fun () ->
- try
- let _s : string =
- ocamlopt ()
- in
- "true"
- with PropList.Not_set _ ->
- let _s : string =
- ocamlc ()
- in
- "false")
-
- let ext_program =
- var_define
- "suffix_program"
- (fun () ->
- match os_type () with
- | "Win32" -> ".exe"
- | _ -> "")
-
- let rm =
- var_define
- ~short_desc:(fun () -> s_ "Remove a file.")
- "rm"
- (fun () ->
- match os_type () with
- | "Win32" -> "del"
- | _ -> "rm -f")
-
- let rmdir =
- var_define
- ~short_desc:(fun () -> s_ "Remove a directory.")
- "rmdir"
- (fun () ->
- match os_type () with
- | "Win32" -> "rd"
- | _ -> "rm -rf")
-
- let debug =
- var_define
- ~short_desc:(fun () -> s_ "Turn ocaml debug flag on")
- ~cli:CLIEnable
- "debug"
- (fun () -> "true")
-
- let profile =
- var_define
- ~short_desc:(fun () -> s_ "Turn ocaml profile flag on")
- ~cli:CLIEnable
- "profile"
- (fun () -> "false")
-
- let tests =
- var_define_cond ~since_version:"0.3"
- (fun () ->
- var_define
- ~short_desc:(fun () ->
- s_ "Compile tests executable and library and run them")
- ~cli:CLIEnable
- "tests"
- (fun () -> "false"))
- "true"
-
- let docs =
- var_define_cond ~since_version:"0.3"
- (fun () ->
- var_define
- ~short_desc:(fun () -> s_ "Create documentations")
- ~cli:CLIEnable
- "docs"
- (fun () -> "true"))
- "true"
-
- let native_dynlink =
- var_define
- ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.")
- ~cli:CLINone
- "native_dynlink"
- (fun () ->
- let res =
- let ocaml_lt_312 () =
- OASISVersion.comparator_apply
- (OASISVersion.version_of_string (ocaml_version ()))
- (OASISVersion.VLesser
- (OASISVersion.version_of_string "3.12.0"))
- in
- let flexdll_lt_030 () =
- OASISVersion.comparator_apply
- (OASISVersion.version_of_string (flexdll_version ()))
- (OASISVersion.VLesser
- (OASISVersion.version_of_string "0.30"))
- in
- let has_native_dynlink =
- let ocamlfind = ocamlfind () in
- try
- let fn =
- OASISExec.run_read_one_line
- ~ctxt:!BaseContext.default
- ocamlfind
- ["query"; "-predicates"; "native"; "dynlink";
- "-format"; "%d/%a"]
- in
- Sys.file_exists fn
- with _ ->
- false
- in
- if not has_native_dynlink then
- false
- else if ocaml_lt_312 () then
- false
- else if (os_type () = "Win32" || os_type () = "Cygwin")
- && flexdll_lt_030 () then
- begin
- BaseMessage.warning
- (f_ ".cmxs generation disabled because FlexDLL needs to be \
- at least 0.30. Please upgrade FlexDLL from %s to 0.30.")
- (flexdll_version ());
- false
- end
- else
- true
- in
- string_of_bool res)
-
- let init pkg =
- rpkg := Some pkg;
- List.iter (fun f -> f pkg.oasis_version) !var_cond
-
-end
-
-module BaseFileAB = struct
-(* # 21 "src/base/BaseFileAB.ml" *)
-
- open BaseEnv
- open OASISGettext
- open BaseMessage
-
- let to_filename fn =
- let fn =
- OASISHostPath.of_unix fn
- in
- if not (Filename.check_suffix fn ".ab") then
- warning
- (f_ "File '%s' doesn't have '.ab' extension")
- fn;
- Filename.chop_extension fn
-
- let replace fn_lst =
- let buff =
- Buffer.create 13
- in
- List.iter
- (fun fn ->
- let fn =
- OASISHostPath.of_unix fn
- in
- let chn_in =
- open_in fn
- in
- let chn_out =
- open_out (to_filename fn)
- in
- (
- try
- while true do
- Buffer.add_string buff (var_expand (input_line chn_in));
- Buffer.add_char buff '\n'
- done
- with End_of_file ->
- ()
- );
- Buffer.output_buffer chn_out buff;
- Buffer.clear buff;
- close_in chn_in;
- close_out chn_out)
- fn_lst
-end
-
-module BaseLog = struct
-(* # 21 "src/base/BaseLog.ml" *)
-
- open OASISUtils
-
- let default_filename =
- Filename.concat
- (Filename.dirname BaseEnv.default_filename)
- "setup.log"
-
- module SetTupleString =
- Set.Make
- (struct
- type t = string * string
- let compare (s11, s12) (s21, s22) =
- match String.compare s11 s21 with
- | 0 -> String.compare s12 s22
- | n -> n
- end)
-
- let load () =
- if Sys.file_exists default_filename then
- begin
- let chn =
- open_in default_filename
- in
- let scbuf =
- Scanf.Scanning.from_file default_filename
- in
- let rec read_aux (st, lst) =
- if not (Scanf.Scanning.end_of_input scbuf) then
- begin
- let acc =
- try
- Scanf.bscanf scbuf "%S %S\n"
- (fun e d ->
- let t =
- e, d
- in
- if SetTupleString.mem t st then
- st, lst
- else
- SetTupleString.add t st,
- t :: lst)
- with Scanf.Scan_failure _ ->
- failwith
- (Scanf.bscanf scbuf
- "%l"
- (fun line ->
- Printf.sprintf
- "Malformed log file '%s' at line %d"
- default_filename
- line))
- in
- read_aux acc
- end
- else
- begin
- close_in chn;
- List.rev lst
- end
- in
- read_aux (SetTupleString.empty, [])
- end
- else
- begin
- []
- end
-
- let register event data =
- let chn_out =
- open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename
- in
- Printf.fprintf chn_out "%S %S\n" event data;
- close_out chn_out
-
- let unregister event data =
- if Sys.file_exists default_filename then
- begin
- let lst =
- load ()
- in
- let chn_out =
- open_out default_filename
- in
- let write_something =
- ref false
- in
- List.iter
- (fun (e, d) ->
- if e <> event || d <> data then
- begin
- write_something := true;
- Printf.fprintf chn_out "%S %S\n" e d
- end)
- lst;
- close_out chn_out;
- if not !write_something then
- Sys.remove default_filename
- end
-
- let filter events =
- let st_events =
- List.fold_left
- (fun st e ->
- SetString.add e st)
- SetString.empty
- events
- in
- List.filter
- (fun (e, _) -> SetString.mem e st_events)
- (load ())
-
- let exists event data =
- List.exists
- (fun v -> (event, data) = v)
- (load ())
-end
-
-module BaseBuilt = struct
-(* # 21 "src/base/BaseBuilt.ml" *)
-
- open OASISTypes
- open OASISGettext
- open BaseStandardVar
- open BaseMessage
-
- type t =
- | BExec (* Executable *)
- | BExecLib (* Library coming with executable *)
- | BLib (* Library *)
- | BDoc (* Document *)
-
- let to_log_event_file t nm =
- "built_"^
- (match t with
- | BExec -> "exec"
- | BExecLib -> "exec_lib"
- | BLib -> "lib"
- | BDoc -> "doc")^
- "_"^nm
-
- let to_log_event_done t nm =
- "is_"^(to_log_event_file t nm)
-
- let register t nm lst =
- BaseLog.register
- (to_log_event_done t nm)
- "true";
- List.iter
- (fun alt ->
- let registered =
- List.fold_left
- (fun registered fn ->
- if OASISFileUtil.file_exists_case fn then
- begin
- BaseLog.register
- (to_log_event_file t nm)
- (if Filename.is_relative fn then
- Filename.concat (Sys.getcwd ()) fn
- else
- fn);
- true
- end
- else
- registered)
- false
- alt
- in
- if not registered then
- warning
- (f_ "Cannot find an existing alternative files among: %s")
- (String.concat (s_ ", ") alt))
- lst
-
- let unregister t nm =
- List.iter
- (fun (e, d) ->
- BaseLog.unregister e d)
- (BaseLog.filter
- [to_log_event_file t nm;
- to_log_event_done t nm])
-
- let fold t nm f acc =
- List.fold_left
- (fun acc (_, fn) ->
- if OASISFileUtil.file_exists_case fn then
- begin
- f acc fn
- end
- else
- begin
- warning
- (f_ "File '%s' has been marked as built \
- for %s but doesn't exist")
- fn
- (Printf.sprintf
- (match t with
- | BExec | BExecLib ->
- (f_ "executable %s")
- | BLib ->
- (f_ "library %s")
- | BDoc ->
- (f_ "documentation %s"))
- nm);
- acc
- end)
- acc
- (BaseLog.filter
- [to_log_event_file t nm])
-
- let is_built t nm =
- List.fold_left
- (fun is_built (_, d) ->
- (try
- bool_of_string d
- with _ ->
- false))
- false
- (BaseLog.filter
- [to_log_event_done t nm])
-
- let of_executable ffn (cs, bs, exec) =
- let unix_exec_is, unix_dll_opt =
- OASISExecutable.unix_exec_is
- (cs, bs, exec)
- (fun () ->
- bool_of_string
- (is_native ()))
- ext_dll
- ext_program
- in
- let evs =
- (BExec, cs.cs_name, [[ffn unix_exec_is]])
- ::
- (match unix_dll_opt with
- | Some fn ->
- [BExecLib, cs.cs_name, [[ffn fn]]]
- | None ->
- [])
- in
- evs,
- unix_exec_is,
- unix_dll_opt
-
- let of_library ffn (cs, bs, lib) =
- let unix_lst =
- OASISLibrary.generated_unix_files
- ~ctxt:!BaseContext.default
- ~source_file_exists:(fun fn ->
- OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn))
- ~is_native:(bool_of_string (is_native ()))
- ~has_native_dynlink:(bool_of_string (native_dynlink ()))
- ~ext_lib:(ext_lib ())
- ~ext_dll:(ext_dll ())
- (cs, bs, lib)
- in
- let evs =
- [BLib,
- cs.cs_name,
- List.map (List.map ffn) unix_lst]
- in
- evs, unix_lst
-
-end
-
-module BaseCustom = struct
-(* # 21 "src/base/BaseCustom.ml" *)
-
- open BaseEnv
- open BaseMessage
- open OASISTypes
- open OASISGettext
-
- let run cmd args extra_args =
- OASISExec.run ~ctxt:!BaseContext.default ~quote:false
- (var_expand cmd)
- (List.map
- var_expand
- (args @ (Array.to_list extra_args)))
-
- let hook ?(failsafe=false) cstm f e =
- let optional_command lst =
- let printer =
- function
- | Some (cmd, args) -> String.concat " " (cmd :: args)
- | None -> s_ "No command"
- in
- match
- var_choose
- ~name:(s_ "Pre/Post Command")
- ~printer
- lst with
- | Some (cmd, args) ->
- begin
- try
- run cmd args [||]
- with e when failsafe ->
- warning
- (f_ "Command '%s' fail with error: %s")
- (String.concat " " (cmd :: args))
- (match e with
- | Failure msg -> msg
- | e -> Printexc.to_string e)
- end
- | None ->
- ()
- in
- let res =
- optional_command cstm.pre_command;
- f e
- in
- optional_command cstm.post_command;
- res
-end
-
-module BaseDynVar = struct
-(* # 21 "src/base/BaseDynVar.ml" *)
-
-
- open OASISTypes
- open OASISGettext
- open BaseEnv
- open BaseBuilt
-
- let init pkg =
- (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *)
- (* TODO: provide compile option for library libary_byte_args_VARNAME... *)
- List.iter
- (function
- | Executable (cs, bs, exec) ->
- if var_choose bs.bs_build then
- var_ignore
- (var_redefine
- (* We don't save this variable *)
- ~dump:false
- ~short_desc:(fun () ->
- Printf.sprintf
- (f_ "Filename of executable '%s'")
- cs.cs_name)
- (OASISUtils.varname_of_string cs.cs_name)
- (fun () ->
- let fn_opt =
- fold
- BExec cs.cs_name
- (fun _ fn -> Some fn)
- None
- in
- match fn_opt with
- | Some fn -> fn
- | None ->
- raise
- (PropList.Not_set
- (cs.cs_name,
- Some (Printf.sprintf
- (f_ "Executable '%s' not yet built.")
- cs.cs_name)))))
-
- | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ ->
- ())
- pkg.sections
-end
-
-module BaseTest = struct
-(* # 21 "src/base/BaseTest.ml" *)
-
- open BaseEnv
- open BaseMessage
- open OASISTypes
- open OASISExpr
- open OASISGettext
-
- let test lst pkg extra_args =
-
- let one_test (failure, n) (test_plugin, cs, test) =
- if var_choose
- ~name:(Printf.sprintf
- (f_ "test %s run")
- cs.cs_name)
- ~printer:string_of_bool
- test.test_run then
- begin
- let () =
- info (f_ "Running test '%s'") cs.cs_name
- in
- let back_cwd =
- match test.test_working_directory with
- | Some dir ->
- let cwd =
- Sys.getcwd ()
- in
- let chdir d =
- info (f_ "Changing directory to '%s'") d;
- Sys.chdir d
- in
- chdir dir;
- fun () -> chdir cwd
-
- | None ->
- fun () -> ()
- in
- try
- let failure_percent =
- BaseCustom.hook
- test.test_custom
- (test_plugin pkg (cs, test))
- extra_args
- in
- back_cwd ();
- (failure_percent +. failure, n + 1)
- with e ->
- begin
- back_cwd ();
- raise e
- end
- end
- else
- begin
- info (f_ "Skipping test '%s'") cs.cs_name;
- (failure, n)
- end
- in
- let (failed, n) =
- List.fold_left
- one_test
- (0.0, 0)
- lst
- in
- let failure_percent =
- if n = 0 then
- 0.0
- else
- failed /. (float_of_int n)
- in
- let msg =
- Printf.sprintf
- (f_ "Tests had a %.2f%% failure rate")
- (100. *. failure_percent)
- in
- if failure_percent > 0.0 then
- failwith msg
- else
- info "%s" msg;
-
- (* Possible explanation why the tests where not run. *)
- if OASISVersion.version_0_3_or_after pkg.oasis_version &&
- not (bool_of_string (BaseStandardVar.tests ())) &&
- lst <> [] then
- BaseMessage.warning
- "Tests are turned off, consider enabling with \
- 'ocaml setup.ml -configure --enable-tests'"
-end
-
-module BaseDoc = struct
-(* # 21 "src/base/BaseDoc.ml" *)
-
- open BaseEnv
- open BaseMessage
- open OASISTypes
- open OASISGettext
-
- let doc lst pkg extra_args =
-
- let one_doc (doc_plugin, cs, doc) =
- if var_choose
- ~name:(Printf.sprintf
- (f_ "documentation %s build")
- cs.cs_name)
- ~printer:string_of_bool
- doc.doc_build then
- begin
- info (f_ "Building documentation '%s'") cs.cs_name;
- BaseCustom.hook
- doc.doc_custom
- (doc_plugin pkg (cs, doc))
- extra_args
- end
- in
- List.iter one_doc lst;
-
- if OASISVersion.version_0_3_or_after pkg.oasis_version &&
- not (bool_of_string (BaseStandardVar.docs ())) &&
- lst <> [] then
- BaseMessage.warning
- "Docs are turned off, consider enabling with \
- 'ocaml setup.ml -configure --enable-docs'"
-end
-
-module BaseSetup = struct
-(* # 21 "src/base/BaseSetup.ml" *)
-
- open BaseEnv
- open BaseMessage
- open OASISTypes
- open OASISSection
- open OASISGettext
- open OASISUtils
-
- type std_args_fun =
- package -> string array -> unit
-
- type ('a, 'b) section_args_fun =
- name * (package -> (common_section * 'a) -> string array -> 'b)
-
- type t =
- {
- configure: std_args_fun;
- build: std_args_fun;
- doc: ((doc, unit) section_args_fun) list;
- test: ((test, float) section_args_fun) list;
- install: std_args_fun;
- uninstall: std_args_fun;
- clean: std_args_fun list;
- clean_doc: (doc, unit) section_args_fun list;
- clean_test: (test, unit) section_args_fun list;
- distclean: std_args_fun list;
- distclean_doc: (doc, unit) section_args_fun list;
- distclean_test: (test, unit) section_args_fun list;
- package: package;
- oasis_fn: string option;
- oasis_version: string;
- oasis_digest: Digest.t option;
- oasis_exec: string option;
- oasis_setup_args: string list;
- setup_update: bool;
- }
-
- (* Associate a plugin function with data from package *)
- let join_plugin_sections filter_map lst =
- List.rev
- (List.fold_left
- (fun acc sct ->
- match filter_map sct with
- | Some e ->
- e :: acc
- | None ->
- acc)
- []
- lst)
-
- (* Search for plugin data associated with a section name *)
- let lookup_plugin_section plugin action nm lst =
- try
- List.assoc nm lst
- with Not_found ->
- failwithf
- (f_ "Cannot find plugin %s matching section %s for %s action")
- plugin
- nm
- action
-
- let configure t args =
- (* Run configure *)
- BaseCustom.hook
- t.package.conf_custom
- (fun () ->
- (* Reload if preconf has changed it *)
- begin
- try
- unload ();
- load ();
- with _ ->
- ()
- end;
-
- (* Run plugin's configure *)
- t.configure t.package args;
-
- (* Dump to allow postconf to change it *)
- dump ())
- ();
-
- (* Reload environment *)
- unload ();
- load ();
-
- (* Save environment *)
- print ();
-
- (* Replace data in file *)
- BaseFileAB.replace t.package.files_ab
-
- let build t args =
- BaseCustom.hook
- t.package.build_custom
- (t.build t.package)
- args
-
- let doc t args =
- BaseDoc.doc
- (join_plugin_sections
- (function
- | Doc (cs, e) ->
- Some
- (lookup_plugin_section
- "documentation"
- (s_ "build")
- cs.cs_name
- t.doc,
- cs,
- e)
- | _ ->
- None)
- t.package.sections)
- t.package
- args
-
- let test t args =
- BaseTest.test
- (join_plugin_sections
- (function
- | Test (cs, e) ->
- Some
- (lookup_plugin_section
- "test"
- (s_ "run")
- cs.cs_name
- t.test,
- cs,
- e)
- | _ ->
- None)
- t.package.sections)
- t.package
- args
-
- let all t args =
- let rno_doc =
- ref false
- in
- let rno_test =
- ref false
- in
- Arg.parse_argv
- ~current:(ref 0)
- (Array.of_list
- ((Sys.executable_name^" all") ::
- (Array.to_list args)))
- [
- "-no-doc",
- Arg.Set rno_doc,
- s_ "Don't run doc target";
-
- "-no-test",
- Arg.Set rno_test,
- s_ "Don't run test target";
- ]
- (failwithf (f_ "Don't know what to do with '%s'"))
- "";
-
- info "Running configure step";
- configure t [||];
-
- info "Running build step";
- build t [||];
-
- (* Load setup.log dynamic variables *)
- BaseDynVar.init t.package;
-
- if not !rno_doc then
- begin
- info "Running doc step";
- doc t [||];
- end
- else
- begin
- info "Skipping doc step"
- end;
-
- if not !rno_test then
- begin
- info "Running test step";
- test t [||]
- end
- else
- begin
- info "Skipping test step"
- end
-
- let install t args =
- BaseCustom.hook
- t.package.install_custom
- (t.install t.package)
- args
-
- let uninstall t args =
- BaseCustom.hook
- t.package.uninstall_custom
- (t.uninstall t.package)
- args
-
- let reinstall t args =
- uninstall t args;
- install t args
-
- let clean, distclean =
- let failsafe f a =
- try
- f a
- with e ->
- warning
- (f_ "Action fail with error: %s")
- (match e with
- | Failure msg -> msg
- | e -> Printexc.to_string e)
- in
-
- let generic_clean t cstm mains docs tests args =
- BaseCustom.hook
- ~failsafe:true
- cstm
- (fun () ->
- (* Clean section *)
- List.iter
- (function
- | Test (cs, test) ->
- let f =
- try
- List.assoc cs.cs_name tests
- with Not_found ->
- fun _ _ _ -> ()
- in
- failsafe
- (f t.package (cs, test))
- args
- | Doc (cs, doc) ->
- let f =
- try
- List.assoc cs.cs_name docs
- with Not_found ->
- fun _ _ _ -> ()
- in
- failsafe
- (f t.package (cs, doc))
- args
- | Library _
- | Executable _
- | Flag _
- | SrcRepo _ ->
- ())
- t.package.sections;
- (* Clean whole package *)
- List.iter
- (fun f ->
- failsafe
- (f t.package)
- args)
- mains)
- ()
- in
-
- let clean t args =
- generic_clean
- t
- t.package.clean_custom
- t.clean
- t.clean_doc
- t.clean_test
- args
- in
-
- let distclean t args =
- (* Call clean *)
- clean t args;
-
- (* Call distclean code *)
- generic_clean
- t
- t.package.distclean_custom
- t.distclean
- t.distclean_doc
- t.distclean_test
- args;
-
- (* Remove generated file *)
- List.iter
- (fun fn ->
- if Sys.file_exists fn then
- begin
- info (f_ "Remove '%s'") fn;
- Sys.remove fn
- end)
- (BaseEnv.default_filename
- ::
- BaseLog.default_filename
- ::
- (List.rev_map BaseFileAB.to_filename t.package.files_ab))
- in
-
- clean, distclean
-
- let version t _ =
- print_endline t.oasis_version
-
- let update_setup_ml, no_update_setup_ml_cli =
- let b = ref true in
- b,
- ("-no-update-setup-ml",
- Arg.Clear b,
- s_ " Don't try to update setup.ml, even if _oasis has changed.")
-
- let update_setup_ml t =
- let oasis_fn =
- match t.oasis_fn with
- | Some fn -> fn
- | None -> "_oasis"
- in
- let oasis_exec =
- match t.oasis_exec with
- | Some fn -> fn
- | None -> "oasis"
- in
- let ocaml =
- Sys.executable_name
- in
- let setup_ml, args =
- match Array.to_list Sys.argv with
- | setup_ml :: args ->
- setup_ml, args
- | [] ->
- failwith
- (s_ "Expecting non-empty command line arguments.")
- in
- let ocaml, setup_ml =
- if Sys.executable_name = Sys.argv.(0) then
- (* We are not running in standard mode, probably the script
- * is precompiled.
- *)
- "ocaml", "setup.ml"
- else
- ocaml, setup_ml
- in
- let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in
- let do_update () =
- let oasis_exec_version =
- OASISExec.run_read_one_line
- ~ctxt:!BaseContext.default
- ~f_exit_code:
- (function
- | 0 ->
- ()
- | 1 ->
- failwithf
- (f_ "Executable '%s' is probably an old version \
- of oasis (< 0.3.0), please update to version \
- v%s.")
- oasis_exec t.oasis_version
- | 127 ->
- failwithf
- (f_ "Cannot find executable '%s', please install \
- oasis v%s.")
- oasis_exec t.oasis_version
- | n ->
- failwithf
- (f_ "Command '%s version' exited with code %d.")
- oasis_exec n)
- oasis_exec ["version"]
- in
- if OASISVersion.comparator_apply
- (OASISVersion.version_of_string oasis_exec_version)
- (OASISVersion.VGreaterEqual
- (OASISVersion.version_of_string t.oasis_version)) then
- begin
- (* We have a version >= for the executable oasis, proceed with
- * update.
- *)
- (* TODO: delegate this check to 'oasis setup'. *)
- if Sys.os_type = "Win32" then
- failwithf
- (f_ "It is not possible to update the running script \
- setup.ml on Windows. Please update setup.ml by \
- running '%s'.")
- (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args))
- else
- begin
- OASISExec.run
- ~ctxt:!BaseContext.default
- ~f_exit_code:
- (function
- | 0 ->
- ()
- | n ->
- failwithf
- (f_ "Unable to update setup.ml using '%s', \
- please fix the problem and retry.")
- oasis_exec)
- oasis_exec ("setup" :: t.oasis_setup_args);
- OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args)
- end
- end
- else
- failwithf
- (f_ "The version of '%s' (v%s) doesn't match the version of \
- oasis used to generate the %s file. Please install at \
- least oasis v%s.")
- oasis_exec oasis_exec_version setup_ml t.oasis_version
- in
-
- if !update_setup_ml then
- begin
- try
- match t.oasis_digest with
- | Some dgst ->
- if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then
- begin
- do_update ();
- true
- end
- else
- false
- | None ->
- false
- with e ->
- error
- (f_ "Error when updating setup.ml. If you want to avoid this error, \
- you can bypass the update of %s by running '%s %s %s %s'")
- setup_ml ocaml setup_ml no_update_setup_ml_cli
- (String.concat " " args);
- raise e
- end
- else
- false
-
- let setup t =
- let catch_exn =
- ref true
- in
- try
- let act_ref =
- ref (fun _ ->
- failwithf
- (f_ "No action defined, run '%s %s -help'")
- Sys.executable_name
- Sys.argv.(0))
-
- in
- let extra_args_ref =
- ref []
- in
- let allow_empty_env_ref =
- ref false
- in
- let arg_handle ?(allow_empty_env=false) act =
- Arg.Tuple
- [
- Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref);
-
- Arg.Unit
- (fun () ->
- allow_empty_env_ref := allow_empty_env;
- act_ref := act);
- ]
- in
-
- Arg.parse
- (Arg.align
- ([
- "-configure",
- arg_handle ~allow_empty_env:true configure,
- s_ "[options*] Configure the whole build process.";
-
- "-build",
- arg_handle build,
- s_ "[options*] Build executables and libraries.";
-
- "-doc",
- arg_handle doc,
- s_ "[options*] Build documents.";
-
- "-test",
- arg_handle test,
- s_ "[options*] Run tests.";
-
- "-all",
- arg_handle ~allow_empty_env:true all,
- s_ "[options*] Run configure, build, doc and test targets.";
-
- "-install",
- arg_handle install,
- s_ "[options*] Install libraries, data, executables \
- and documents.";
-
- "-uninstall",
- arg_handle uninstall,
- s_ "[options*] Uninstall libraries, data, executables \
- and documents.";
-
- "-reinstall",
- arg_handle reinstall,
- s_ "[options*] Uninstall and install libraries, data, \
- executables and documents.";
-
- "-clean",
- arg_handle ~allow_empty_env:true clean,
- s_ "[options*] Clean files generated by a build.";
-
- "-distclean",
- arg_handle ~allow_empty_env:true distclean,
- s_ "[options*] Clean files generated by a build and configure.";
-
- "-version",
- arg_handle ~allow_empty_env:true version,
- s_ " Display version of OASIS used to generate this setup.ml.";
-
- "-no-catch-exn",
- Arg.Clear catch_exn,
- s_ " Don't catch exception, useful for debugging.";
- ]
- @
- (if t.setup_update then
- [no_update_setup_ml_cli]
- else
- [])
- @ (BaseContext.args ())))
- (failwithf (f_ "Don't know what to do with '%s'"))
- (s_ "Setup and run build process current package\n");
-
- (* Build initial environment *)
- load ~allow_empty:!allow_empty_env_ref ();
-
- (** Initialize flags *)
- List.iter
- (function
- | Flag (cs, {flag_description = hlp;
- flag_default = choices}) ->
- begin
- let apply ?short_desc () =
- var_ignore
- (var_define
- ~cli:CLIEnable
- ?short_desc
- (OASISUtils.varname_of_string cs.cs_name)
- (fun () ->
- string_of_bool
- (var_choose
- ~name:(Printf.sprintf
- (f_ "default value of flag %s")
- cs.cs_name)
- ~printer:string_of_bool
- choices)))
- in
- match hlp with
- | Some hlp ->
- apply ~short_desc:(fun () -> hlp) ()
- | None ->
- apply ()
- end
- | _ ->
- ())
- t.package.sections;
-
- BaseStandardVar.init t.package;
-
- BaseDynVar.init t.package;
-
- if t.setup_update && update_setup_ml t then
- ()
- else
- !act_ref t (Array.of_list (List.rev !extra_args_ref))
-
- with e when !catch_exn ->
- error "%s" (Printexc.to_string e);
- exit 1
-
-end
-
-
-# 4480 "setup.ml"
-module InternalConfigurePlugin = struct
-(* # 21 "src/plugins/internal/InternalConfigurePlugin.ml" *)
-
- (** Configure using internal scheme
- @author Sylvain Le Gall
- *)
-
- open BaseEnv
- open OASISTypes
- open OASISUtils
- open OASISGettext
- open BaseMessage
-
- (** Configure build using provided series of check to be done
- * and then output corresponding file.
- *)
- let configure pkg argv =
- let var_ignore_eval var =
- let _s : string =
- var ()
- in
- ()
- in
-
- let errors =
- ref SetString.empty
- in
-
- let buff =
- Buffer.create 13
- in
-
- let add_errors fmt =
- Printf.kbprintf
- (fun b ->
- errors := SetString.add (Buffer.contents b) !errors;
- Buffer.clear b)
- buff
- fmt
- in
-
- let warn_exception e =
- warning "%s" (Printexc.to_string e)
- in
-
- (* Check tools *)
- let check_tools lst =
- List.iter
- (function
- | ExternalTool tool ->
- begin
- try
- var_ignore_eval (BaseCheck.prog tool)
- with e ->
- warn_exception e;
- add_errors (f_ "Cannot find external tool '%s'") tool
- end
- | InternalExecutable nm1 ->
- (* Check that matching tool is built *)
- List.iter
- (function
- | Executable ({cs_name = nm2},
- {bs_build = build},
- _) when nm1 = nm2 ->
- if not (var_choose build) then
- add_errors
- (f_ "Cannot find buildable internal executable \
- '%s' when checking build depends")
- nm1
- | _ ->
- ())
- pkg.sections)
- lst
- in
-
- let build_checks sct bs =
- if var_choose bs.bs_build then
- begin
- if bs.bs_compiled_object = Native then
- begin
- try
- var_ignore_eval BaseStandardVar.ocamlopt
- with e ->
- warn_exception e;
- add_errors
- (f_ "Section %s requires native compilation")
- (OASISSection.string_of_section sct)
- end;
-
- (* Check tools *)
- check_tools bs.bs_build_tools;
-
- (* Check depends *)
- List.iter
- (function
- | FindlibPackage (findlib_pkg, version_comparator) ->
- begin
- try
- var_ignore_eval
- (BaseCheck.package ?version_comparator findlib_pkg)
- with e ->
- warn_exception e;
- match version_comparator with
- | None ->
- add_errors
- (f_ "Cannot find findlib package %s")
- findlib_pkg
- | Some ver_cmp ->
- add_errors
- (f_ "Cannot find findlib package %s (%s)")
- findlib_pkg
- (OASISVersion.string_of_comparator ver_cmp)
- end
- | InternalLibrary nm1 ->
- (* Check that matching library is built *)
- List.iter
- (function
- | Library ({cs_name = nm2},
- {bs_build = build},
- _) when nm1 = nm2 ->
- if not (var_choose build) then
- add_errors
- (f_ "Cannot find buildable internal library \
- '%s' when checking build depends")
- nm1
- | _ ->
- ())
- pkg.sections)
- bs.bs_build_depends
- end
- in
-
- (* Parse command line *)
- BaseArgExt.parse argv (BaseEnv.args ());
-
- (* OCaml version *)
- begin
- match pkg.ocaml_version with
- | Some ver_cmp ->
- begin
- try
- var_ignore_eval
- (BaseCheck.version
- "ocaml"
- ver_cmp
- BaseStandardVar.ocaml_version)
- with e ->
- warn_exception e;
- add_errors
- (f_ "OCaml version %s doesn't match version constraint %s")
- (BaseStandardVar.ocaml_version ())
- (OASISVersion.string_of_comparator ver_cmp)
- end
- | None ->
- ()
- end;
-
- (* Findlib version *)
- begin
- match pkg.findlib_version with
- | Some ver_cmp ->
- begin
- try
- var_ignore_eval
- (BaseCheck.version
- "findlib"
- ver_cmp
- BaseStandardVar.findlib_version)
- with e ->
- warn_exception e;
- add_errors
- (f_ "Findlib version %s doesn't match version constraint %s")
- (BaseStandardVar.findlib_version ())
- (OASISVersion.string_of_comparator ver_cmp)
- end
- | None ->
- ()
- end;
-
- (* FlexDLL *)
- if BaseStandardVar.os_type () = "Win32" ||
- BaseStandardVar.os_type () = "Cygwin" then
- begin
- try
- var_ignore_eval BaseStandardVar.flexlink
- with e ->
- warn_exception e;
- add_errors (f_ "Cannot find 'flexlink'")
- end;
-
- (* Check build depends *)
- List.iter
- (function
- | Executable (_, bs, _)
- | Library (_, bs, _) as sct ->
- build_checks sct bs
- | Doc (_, doc) ->
- if var_choose doc.doc_build then
- check_tools doc.doc_build_tools
- | Test (_, test) ->
- if var_choose test.test_run then
- check_tools test.test_tools
- | _ ->
- ())
- pkg.sections;
-
- (* Check if we need native dynlink (presence of libraries that compile to
- * native)
- *)
- begin
- let has_cmxa =
- List.exists
- (function
- | Library (_, bs, _) ->
- var_choose bs.bs_build &&
- (bs.bs_compiled_object = Native ||
- (bs.bs_compiled_object = Best &&
- bool_of_string (BaseStandardVar.is_native ())))
- | _ ->
- false)
- pkg.sections
- in
- if has_cmxa then
- var_ignore_eval BaseStandardVar.native_dynlink
- end;
-
- (* Check errors *)
- if SetString.empty != !errors then
- begin
- List.iter
- (fun e -> error "%s" e)
- (SetString.elements !errors);
- failwithf
- (fn_
- "%d configuration error"
- "%d configuration errors"
- (SetString.cardinal !errors))
- (SetString.cardinal !errors)
- end
-
-end
-
-module InternalInstallPlugin = struct
-(* # 21 "src/plugins/internal/InternalInstallPlugin.ml" *)
-
- (** Install using internal scheme
- @author Sylvain Le Gall
- *)
-
- open BaseEnv
- open BaseStandardVar
- open BaseMessage
- open OASISTypes
- open OASISLibrary
- open OASISGettext
- open OASISUtils
-
- let exec_hook =
- ref (fun (cs, bs, exec) -> cs, bs, exec)
-
- let lib_hook =
- ref (fun (cs, bs, lib) -> cs, bs, lib, [])
-
- let doc_hook =
- ref (fun (cs, doc) -> cs, doc)
-
- let install_file_ev =
- "install-file"
-
- let install_dir_ev =
- "install-dir"
-
- let install_findlib_ev =
- "install-findlib"
-
- let win32_max_command_line_length = 8000
-
- let split_install_command ocamlfind findlib_name meta files =
- if Sys.os_type = "Win32" then
- (* Arguments for the first command: *)
- let first_args = ["install"; findlib_name; meta] in
- (* Arguments for remaining commands: *)
- let other_args = ["install"; findlib_name; "-add"] in
- (* Extract as much files as possible from [files], [len] is
- the current command line length: *)
- let rec get_files len acc files =
- match files with
- | [] ->
- (List.rev acc, [])
- | file :: rest ->
- let len = len + 1 + String.length file in
- if len > win32_max_command_line_length then
- (List.rev acc, files)
- else
- get_files len (file :: acc) rest
- in
- (* Split the command into several commands. *)
- let rec split args files =
- match files with
- | [] ->
- []
- | _ ->
- (* Length of "ocamlfind install <lib> [META|-add]" *)
- let len =
- List.fold_left
- (fun len arg ->
- len + 1 (* for the space *) + String.length arg)
- (String.length ocamlfind)
- args
- in
- match get_files len [] files with
- | ([], _) ->
- failwith (s_ "Command line too long.")
- | (firsts, others) ->
- let cmd = args @ firsts in
- (* Use -add for remaining commands: *)
- let () =
- let findlib_ge_132 =
- OASISVersion.comparator_apply
- (OASISVersion.version_of_string
- (BaseStandardVar.findlib_version ()))
- (OASISVersion.VGreaterEqual
- (OASISVersion.version_of_string "1.3.2"))
- in
- if not findlib_ge_132 then
- failwithf
- (f_ "Installing the library %s require to use the flag \
- '-add' of ocamlfind because the command line is too \
- long. This flag is only available for findlib 1.3.2. \
- Please upgrade findlib from %s to 1.3.2")
- findlib_name (BaseStandardVar.findlib_version ())
- in
- let cmds = split other_args others in
- cmd :: cmds
- in
- (* The first command does not use -add: *)
- split first_args files
- else
- ["install" :: findlib_name :: meta :: files]
-
- let install pkg argv =
-
- let in_destdir =
- try
- let destdir =
- destdir ()
- in
- (* Practically speaking destdir is prepended
- * at the beginning of the target filename
- *)
- fun fn -> destdir^fn
- with PropList.Not_set _ ->
- fun fn -> fn
- in
-
- let install_file ?tgt_fn src_file envdir =
- let tgt_dir =
- in_destdir (envdir ())
- in
- let tgt_file =
- Filename.concat
- tgt_dir
- (match tgt_fn with
- | Some fn ->
- fn
- | None ->
- Filename.basename src_file)
- in
- (* Create target directory if needed *)
- OASISFileUtil.mkdir_parent
- ~ctxt:!BaseContext.default
- (fun dn ->
- info (f_ "Creating directory '%s'") dn;
- BaseLog.register install_dir_ev dn)
- tgt_dir;
-
- (* Really install files *)
- info (f_ "Copying file '%s' to '%s'") src_file tgt_file;
- OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file;
- BaseLog.register install_file_ev tgt_file
- in
-
- (* Install data into defined directory *)
- let install_data srcdir lst tgtdir =
- let tgtdir =
- OASISHostPath.of_unix (var_expand tgtdir)
- in
- List.iter
- (fun (src, tgt_opt) ->
- let real_srcs =
- OASISFileUtil.glob
- ~ctxt:!BaseContext.default
- (Filename.concat srcdir src)
- in
- if real_srcs = [] then
- failwithf
- (f_ "Wildcard '%s' doesn't match any files")
- src;
- List.iter
- (fun fn ->
- install_file
- fn
- (fun () ->
- match tgt_opt with
- | Some s ->
- OASISHostPath.of_unix (var_expand s)
- | None ->
- tgtdir))
- real_srcs)
- lst
- in
-
- (** Install all libraries *)
- let install_libs pkg =
-
- let files_of_library (f_data, acc) data_lib =
- let cs, bs, lib, lib_extra =
- !lib_hook data_lib
- in
- if var_choose bs.bs_install &&
- BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then
- begin
- let acc =
- (* Start with acc + lib_extra *)
- List.rev_append lib_extra acc
- in
- let acc =
- (* Add uncompiled header from the source tree *)
- let path =
- OASISHostPath.of_unix bs.bs_path
- in
- List.fold_left
- (fun acc modul ->
- try
- List.find
- OASISFileUtil.file_exists_case
- (List.map
- (Filename.concat path)
- [modul^".mli";
- modul^".ml";
- String.uncapitalize modul^".mli";
- String.capitalize modul^".mli";
- String.uncapitalize modul^".ml";
- String.capitalize modul^".ml"])
- :: acc
- with Not_found ->
- begin
- warning
- (f_ "Cannot find source header for module %s \
- in library %s")
- modul cs.cs_name;
- acc
- end)
- acc
- lib.lib_modules
- in
-
- let acc =
- (* Get generated files *)
- BaseBuilt.fold
- BaseBuilt.BLib
- cs.cs_name
- (fun acc fn -> fn :: acc)
- acc
- in
-
- let f_data () =
- (* Install data associated with the library *)
- install_data
- bs.bs_path
- bs.bs_data_files
- (Filename.concat
- (datarootdir ())
- pkg.name);
- f_data ()
- in
-
- (f_data, acc)
- end
- else
- begin
- (f_data, acc)
- end
- in
-
- (* Install one group of library *)
- let install_group_lib grp =
- (* Iterate through all group nodes *)
- let rec install_group_lib_aux data_and_files grp =
- let data_and_files, children =
- match grp with
- | Container (_, children) ->
- data_and_files, children
- | Package (_, cs, bs, lib, children) ->
- files_of_library data_and_files (cs, bs, lib), children
- in
- List.fold_left
- install_group_lib_aux
- data_and_files
- children
- in
-
- (* Findlib name of the root library *)
- let findlib_name =
- findlib_of_group grp
- in
-
- (* Determine root library *)
- let root_lib =
- root_of_group grp
- in
-
- (* All files to install for this library *)
- let f_data, files =
- install_group_lib_aux (ignore, []) grp
- in
-
- (* Really install, if there is something to install *)
- if files = [] then
- begin
- warning
- (f_ "Nothing to install for findlib library '%s'")
- findlib_name
- end
- else
- begin
- let meta =
- (* Search META file *)
- let (_, bs, _) =
- root_lib
- in
- let res =
- Filename.concat bs.bs_path "META"
- in
- if not (OASISFileUtil.file_exists_case res) then
- failwithf
- (f_ "Cannot find file '%s' for findlib library %s")
- res
- findlib_name;
- res
- in
- let files =
- (* Make filename shorter to avoid hitting command max line length
- * too early, esp. on Windows.
- *)
- let remove_prefix p n =
- let plen = String.length p in
- let nlen = String.length n in
- if plen <= nlen && String.sub n 0 plen = p then
- begin
- let fn_sep =
- if Sys.os_type = "Win32" then
- '\\'
- else
- '/'
- in
- let cutpoint = plen +
- (if plen < nlen && n.[plen] = fn_sep then
- 1
- else
- 0)
- in
- String.sub n cutpoint (nlen - cutpoint)
- end
- else
- n
- in
- List.map (remove_prefix (Sys.getcwd ())) files
- in
- info
- (f_ "Installing findlib library '%s'")
- findlib_name;
- let ocamlfind = ocamlfind () in
- let commands =
- split_install_command
- ocamlfind
- findlib_name
- meta
- files
- in
- List.iter
- (OASISExec.run ~ctxt:!BaseContext.default ocamlfind)
- commands;
- BaseLog.register install_findlib_ev findlib_name
- end;
-
- (* Install data files *)
- f_data ();
-
- in
-
- let group_libs, _, _ =
- findlib_mapping pkg
- in
-
- (* We install libraries in groups *)
- List.iter install_group_lib group_libs
- in
-
- let install_execs pkg =
- let install_exec data_exec =
- let (cs, bs, exec) =
- !exec_hook data_exec
- in
- if var_choose bs.bs_install &&
- BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then
- begin
- let exec_libdir () =
- Filename.concat
- (libdir ())
- pkg.name
- in
- BaseBuilt.fold
- BaseBuilt.BExec
- cs.cs_name
- (fun () fn ->
- install_file
- ~tgt_fn:(cs.cs_name ^ ext_program ())
- fn
- bindir)
- ();
- BaseBuilt.fold
- BaseBuilt.BExecLib
- cs.cs_name
- (fun () fn ->
- install_file
- fn
- exec_libdir)
- ();
- install_data
- bs.bs_path
- bs.bs_data_files
- (Filename.concat
- (datarootdir ())
- pkg.name)
- end
- in
- List.iter
- (function
- | Executable (cs, bs, exec)->
- install_exec (cs, bs, exec)
- | _ ->
- ())
- pkg.sections
- in
-
- let install_docs pkg =
- let install_doc data =
- let (cs, doc) =
- !doc_hook data
- in
- if var_choose doc.doc_install &&
- BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then
- begin
- let tgt_dir =
- OASISHostPath.of_unix (var_expand doc.doc_install_dir)
- in
- BaseBuilt.fold
- BaseBuilt.BDoc
- cs.cs_name
- (fun () fn ->
- install_file
- fn
- (fun () -> tgt_dir))
- ();
- install_data
- Filename.current_dir_name
- doc.doc_data_files
- doc.doc_install_dir
- end
- in
- List.iter
- (function
- | Doc (cs, doc) ->
- install_doc (cs, doc)
- | _ ->
- ())
- pkg.sections
- in
-
- install_libs pkg;
- install_execs pkg;
- install_docs pkg
-
- (* Uninstall already installed data *)
- let uninstall _ argv =
- List.iter
- (fun (ev, data) ->
- if ev = install_file_ev then
- begin
- if OASISFileUtil.file_exists_case data then
- begin
- info
- (f_ "Removing file '%s'")
- data;
- Sys.remove data
- end
- else
- begin
- warning
- (f_ "File '%s' doesn't exist anymore")
- data
- end
- end
- else if ev = install_dir_ev then
- begin
- if Sys.file_exists data && Sys.is_directory data then
- begin
- if Sys.readdir data = [||] then
- begin
- info
- (f_ "Removing directory '%s'")
- data;
- OASISFileUtil.rmdir ~ctxt:!BaseContext.default data
- end
- else
- begin
- warning
- (f_ "Directory '%s' is not empty (%s)")
- data
- (String.concat
- ", "
- (Array.to_list
- (Sys.readdir data)))
- end
- end
- else
- begin
- warning
- (f_ "Directory '%s' doesn't exist anymore")
- data
- end
- end
- else if ev = install_findlib_ev then
- begin
- info (f_ "Removing findlib library '%s'") data;
- OASISExec.run ~ctxt:!BaseContext.default
- (ocamlfind ()) ["remove"; data]
- end
- else
- failwithf (f_ "Unknown log event '%s'") ev;
- BaseLog.unregister ev data)
- (* We process event in reverse order *)
- (List.rev
- (BaseLog.filter
- [install_file_ev;
- install_dir_ev;
- install_findlib_ev;]))
-
-end
-
-
-# 5233 "setup.ml"
-module OCamlbuildCommon = struct
-(* # 21 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *)
-
- (** Functions common to OCamlbuild build and doc plugin
- *)
-
- open OASISGettext
- open BaseEnv
- open BaseStandardVar
-
- let ocamlbuild_clean_ev =
- "ocamlbuild-clean"
-
- let ocamlbuildflags =
- var_define
- ~short_desc:(fun () -> "OCamlbuild additional flags")
- "ocamlbuildflags"
- (fun () -> "")
-
- (** Fix special arguments depending on environment *)
- let fix_args args extra_argv =
- List.flatten
- [
- if (os_type ()) = "Win32" then
- [
- "-classic-display";
- "-no-log";
- "-no-links";
- "-install-lib-dir";
- (Filename.concat (standard_library ()) "ocamlbuild")
- ]
- else
- [];
-
- if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then
- [
- "-byte-plugin"
- ]
- else
- [];
- args;
-
- if bool_of_string (debug ()) then
- ["-tag"; "debug"]
- else
- [];
-
- if bool_of_string (profile ()) then
- ["-tag"; "profile"]
- else
- [];
-
- OASISString.nsplit (ocamlbuildflags ()) ' ';
-
- Array.to_list extra_argv;
- ]
-
- (** Run 'ocamlbuild -clean' if not already done *)
- let run_clean extra_argv =
- let extra_cli =
- String.concat " " (Array.to_list extra_argv)
- in
- (* Run if never called with these args *)
- if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then
- begin
- OASISExec.run ~ctxt:!BaseContext.default
- (ocamlbuild ()) (fix_args ["-clean"] extra_argv);
- BaseLog.register ocamlbuild_clean_ev extra_cli;
- at_exit
- (fun () ->
- try
- BaseLog.unregister ocamlbuild_clean_ev extra_cli
- with _ ->
- ())
- end
-
- (** Run ocamlbuild, unregister all clean events *)
- let run_ocamlbuild args extra_argv =
- (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html
- *)
- OASISExec.run ~ctxt:!BaseContext.default
- (ocamlbuild ()) (fix_args args extra_argv);
- (* Remove any clean event, we must run it again *)
- List.iter
- (fun (e, d) -> BaseLog.unregister e d)
- (BaseLog.filter [ocamlbuild_clean_ev])
-
- (** Determine real build directory *)
- let build_dir extra_argv =
- let rec search_args dir =
- function
- | "-build-dir" :: dir :: tl ->
- search_args dir tl
- | _ :: tl ->
- search_args dir tl
- | [] ->
- dir
- in
- search_args "_build" (fix_args [] extra_argv)
-
-end
-
-module OCamlbuildPlugin = struct
-(* # 21 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *)
-
- (** Build using ocamlbuild
- @author Sylvain Le Gall
- *)
-
- open OASISTypes
- open OASISGettext
- open OASISUtils
- open BaseEnv
- open OCamlbuildCommon
- open BaseStandardVar
- open BaseMessage
-
- let cond_targets_hook =
- ref (fun lst -> lst)
-
- let build pkg argv =
-
- (* Return the filename in build directory *)
- let in_build_dir fn =
- Filename.concat
- (build_dir argv)
- fn
- in
-
- (* Return the unix filename in host build directory *)
- let in_build_dir_of_unix fn =
- in_build_dir (OASISHostPath.of_unix fn)
- in
-
- let cond_targets =
- List.fold_left
- (fun acc ->
- function
- | Library (cs, bs, lib) when var_choose bs.bs_build ->
- begin
- let evs, unix_files =
- BaseBuilt.of_library
- in_build_dir_of_unix
- (cs, bs, lib)
- in
-
- let ends_with nd fn =
- let nd_len =
- String.length nd
- in
- (String.length fn >= nd_len)
- &&
- (String.sub
- fn
- (String.length fn - nd_len)
- nd_len) = nd
- in
-
- let tgts =
- List.flatten
- (List.filter
- (fun l -> l <> [])
- (List.map
- (List.filter
- (fun fn ->
- ends_with ".cma" fn
- || ends_with ".cmxs" fn
- || ends_with ".cmxa" fn
- || ends_with (ext_lib ()) fn
- || ends_with (ext_dll ()) fn))
- unix_files))
- in
-
- match tgts with
- | _ :: _ ->
- (evs, tgts) :: acc
- | [] ->
- failwithf
- (f_ "No possible ocamlbuild targets for library %s")
- cs.cs_name
- end
-
- | Executable (cs, bs, exec) when var_choose bs.bs_build ->
- begin
- let evs, unix_exec_is, unix_dll_opt =
- BaseBuilt.of_executable
- in_build_dir_of_unix
- (cs, bs, exec)
- in
-
- let target ext =
- let unix_tgt =
- (OASISUnixPath.concat
- bs.bs_path
- (OASISUnixPath.chop_extension
- exec.exec_main_is))^ext
- in
- let evs =
- (* Fix evs, we want to use the unix_tgt, without copying *)
- List.map
- (function
- | BaseBuilt.BExec, nm, lst when nm = cs.cs_name ->
- BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]]
- | ev ->
- ev)
- evs
- in
- evs, [unix_tgt]
- in
-
- (* Add executable *)
- let acc =
- match bs.bs_compiled_object with
- | Native ->
- (target ".native") :: acc
- | Best when bool_of_string (is_native ()) ->
- (target ".native") :: acc
- | Byte
- | Best ->
- (target ".byte") :: acc
- in
- acc
- end
-
- | Library _ | Executable _ | Test _
- | SrcRepo _ | Flag _ | Doc _ ->
- acc)
- []
- (* Keep the pkg.sections ordered *)
- (List.rev pkg.sections);
- in
-
- (* Check and register built files *)
- let check_and_register (bt, bnm, lst) =
- List.iter
- (fun fns ->
- if not (List.exists OASISFileUtil.file_exists_case fns) then
- failwithf
- (f_ "No one of expected built files %s exists")
- (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns)))
- lst;
- (BaseBuilt.register bt bnm lst)
- in
-
- let cond_targets =
- (* Run the hook *)
- !cond_targets_hook cond_targets
- in
-
- (* Run a list of target... *)
- run_ocamlbuild
- (List.flatten
- (List.map snd cond_targets))
- argv;
- (* ... and register events *)
- List.iter
- check_and_register
- (List.flatten (List.map fst cond_targets))
-
-
- let clean pkg extra_args =
- run_clean extra_args;
- List.iter
- (function
- | Library (cs, _, _) ->
- BaseBuilt.unregister BaseBuilt.BLib cs.cs_name
- | Executable (cs, _, _) ->
- BaseBuilt.unregister BaseBuilt.BExec cs.cs_name;
- BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name
- | _ ->
- ())
- pkg.sections
-
-end
-
-module OCamlbuildDocPlugin = struct
-(* # 21 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *)
-
- (* Create documentation using ocamlbuild .odocl files
- @author Sylvain Le Gall
- *)
-
- open OASISTypes
- open OASISGettext
- open OASISMessage
- open OCamlbuildCommon
- open BaseStandardVar
-
-
-
- let doc_build path pkg (cs, doc) argv =
- let index_html =
- OASISUnixPath.make
- [
- path;
- cs.cs_name^".docdir";
- "index.html";
- ]
- in
- let tgt_dir =
- OASISHostPath.make
- [
- build_dir argv;
- OASISHostPath.of_unix path;
- cs.cs_name^".docdir";
- ]
- in
- run_ocamlbuild [index_html] argv;
- List.iter
- (fun glb ->
- BaseBuilt.register
- BaseBuilt.BDoc
- cs.cs_name
- [OASISFileUtil.glob ~ctxt:!BaseContext.default
- (Filename.concat tgt_dir glb)])
- ["*.html"; "*.css"]
-
- let doc_clean t pkg (cs, doc) argv =
- run_clean argv;
- BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name
-
-end
-
-
-# 5558 "setup.ml"
-module CustomPlugin = struct
-(* # 21 "src/plugins/custom/CustomPlugin.ml" *)
-
- (** Generate custom configure/build/doc/test/install system
- @author
- *)
-
- open BaseEnv
- open OASISGettext
- open OASISTypes
-
-
-
- type t =
- {
- cmd_main: command_line conditional;
- cmd_clean: (command_line option) conditional;
- cmd_distclean: (command_line option) conditional;
- }
-
- let run = BaseCustom.run
-
- let main t _ extra_args =
- let cmd, args =
- var_choose
- ~name:(s_ "main command")
- t.cmd_main
- in
- run cmd args extra_args
-
- let clean t pkg extra_args =
- match var_choose t.cmd_clean with
- | Some (cmd, args) ->
- run cmd args extra_args
- | _ ->
- ()
-
- let distclean t pkg extra_args =
- match var_choose t.cmd_distclean with
- | Some (cmd, args) ->
- run cmd args extra_args
- | _ ->
- ()
-
- module Build =
- struct
- let main t pkg extra_args =
- main t pkg extra_args;
- List.iter
- (fun sct ->
- let evs =
- match sct with
- | Library (cs, bs, lib) when var_choose bs.bs_build ->
- begin
- let evs, _ =
- BaseBuilt.of_library
- OASISHostPath.of_unix
- (cs, bs, lib)
- in
- evs
- end
- | Executable (cs, bs, exec) when var_choose bs.bs_build ->
- begin
- let evs, _, _ =
- BaseBuilt.of_executable
- OASISHostPath.of_unix
- (cs, bs, exec)
- in
- evs
- end
- | _ ->
- []
- in
- List.iter
- (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst)
- evs)
- pkg.sections
-
- let clean t pkg extra_args =
- clean t pkg extra_args;
- (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild
- * considering moving this to BaseSetup?
- *)
- List.iter
- (function
- | Library (cs, _, _) ->
- BaseBuilt.unregister BaseBuilt.BLib cs.cs_name
- | Executable (cs, _, _) ->
- BaseBuilt.unregister BaseBuilt.BExec cs.cs_name;
- BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name
- | _ ->
- ())
- pkg.sections
-
- let distclean t pkg extra_args =
- distclean t pkg extra_args
- end
-
- module Test =
- struct
- let main t pkg (cs, test) extra_args =
- try
- main t pkg extra_args;
- 0.0
- with Failure s ->
- BaseMessage.warning
- (f_ "Test '%s' fails: %s")
- cs.cs_name
- s;
- 1.0
-
- let clean t pkg (cs, test) extra_args =
- clean t pkg extra_args
-
- let distclean t pkg (cs, test) extra_args =
- distclean t pkg extra_args
- end
-
- module Doc =
- struct
- let main t pkg (cs, _) extra_args =
- main t pkg extra_args;
- BaseBuilt.register BaseBuilt.BDoc cs.cs_name []
-
- let clean t pkg (cs, _) extra_args =
- clean t pkg extra_args;
- BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name
-
- let distclean t pkg (cs, _) extra_args =
- distclean t pkg extra_args
- end
-
-end
-
-
-# 5694 "setup.ml"
-open OASISTypes;;
-
-let setup_t =
- {
- BaseSetup.configure = InternalConfigurePlugin.configure;
- build = OCamlbuildPlugin.build;
- test =
- [
- ("nonregression",
- CustomPlugin.Test.main
- {
- CustomPlugin.cmd_main =
- [(OASISExpr.EBool true, ("make", ["test-compile"]))];
- cmd_clean = [(OASISExpr.EBool true, None)];
- cmd_distclean = [(OASISExpr.EBool true, None)]
- })
- ];
- doc = [];
- install = InternalInstallPlugin.install;
- uninstall = InternalInstallPlugin.uninstall;
- clean = [OCamlbuildPlugin.clean];
- clean_test =
- [
- ("nonregression",
- CustomPlugin.Test.clean
- {
- CustomPlugin.cmd_main =
- [(OASISExpr.EBool true, ("make", ["test-compile"]))];
- cmd_clean = [(OASISExpr.EBool true, None)];
- cmd_distclean = [(OASISExpr.EBool true, None)]
- })
- ];
- clean_doc = [];
- distclean = [];
- distclean_test =
- [
- ("nonregression",
- CustomPlugin.Test.distclean
- {
- CustomPlugin.cmd_main =
- [(OASISExpr.EBool true, ("make", ["test-compile"]))];
- cmd_clean = [(OASISExpr.EBool true, None)];
- cmd_distclean = [(OASISExpr.EBool true, None)]
- })
- ];
- distclean_doc = [];
- package =
- {
- oasis_version = "0.2";
- ocaml_version = None;
- findlib_version = None;
- name = "Lustre Compiler";
- version = "1.2";
- license =
- OASISLicense.DEP5License
- (OASISLicense.DEP5Unit
- {
- OASISLicense.license = "LGPL";
- excption = None;
- version = OASISLicense.Version "2.1"
- });
- license_file = None;
- copyrights = [];
- maintainers = [];
- authors = [];
- homepage = None;
- synopsis = "Lustre compiler C and Java backends";
- description = None;
- categories = [];
- conf_type = (`Configure, "internal", Some "0.3");
- conf_custom =
- {
- pre_command = [(OASISExpr.EBool true, None)];
- post_command = [(OASISExpr.EBool true, None)]
- };
- build_type = (`Build, "ocamlbuild", Some "0.3");
- build_custom =
- {
- pre_command =
- [
- (OASISExpr.EBool true,
- Some (("./svn_version.sh", ["$(prefix)"])))
- ];
- post_command = [(OASISExpr.EBool true, None)]
- };
- install_type = (`Install, "internal", Some "0.3");
- install_custom =
- {
- pre_command = [(OASISExpr.EBool true, None)];
- post_command =
- [
- (OASISExpr.EBool true,
- Some
- (("mkdir",
- [
- "-p";
- "$(prefix)/include/lustrec;";
- "cp";
- "-rf";
- "include/*";
- "$(prefix)/include/lustrec"
- ])))
- ]
- };
- uninstall_custom =
- {
- pre_command = [(OASISExpr.EBool true, None)];
- post_command = [(OASISExpr.EBool true, None)]
- };
- clean_custom =
- {
- pre_command = [(OASISExpr.EBool true, None)];
- post_command = [(OASISExpr.EBool true, None)]
- };
- distclean_custom =
- {
- pre_command = [(OASISExpr.EBool true, None)];
- post_command = [(OASISExpr.EBool true, None)]
- };
- files_ab = [];
- sections =
- [
- Executable
- ({
- cs_name = "lustrec";
- cs_data = PropList.Data.create ();
- cs_plugin_data = []
- },
- {
- bs_build = [(OASISExpr.EBool true, true)];
- bs_install = [(OASISExpr.EBool true, true)];
- bs_path = "src";
- bs_compiled_object = Native;
- bs_build_depends =
- [
- FindlibPackage ("ocamlgraph", None);
- FindlibPackage ("str", None);
- FindlibPackage ("unix", None)
- ];
- bs_build_tools = [ExternalTool "ocamlbuild"];
- bs_c_sources = [];
- bs_data_files = [];
- bs_ccopt = [(OASISExpr.EBool true, [])];
- bs_cclib = [(OASISExpr.EBool true, [])];
- bs_dlllib = [(OASISExpr.EBool true, [])];
- bs_dllpath = [(OASISExpr.EBool true, [])];
- bs_byteopt = [(OASISExpr.EBool true, [])];
- bs_nativeopt = [(OASISExpr.EBool true, [])]
- },
- {
- exec_custom = false;
- exec_main_is = "main_lustre_compiler.ml"
- });
- Test
- ({
- cs_name = "nonregression";
- cs_data = PropList.Data.create ();
- cs_plugin_data = []
- },
- {
- test_type = (`Test, "custom", None);
- test_command =
- [(OASISExpr.EBool true, ("make", ["test-compile"]))];
- test_custom =
- {
- pre_command = [(OASISExpr.EBool true, None)];
- post_command = [(OASISExpr.EBool true, None)]
- };
- test_working_directory = Some "test";
- test_run = [(OASISExpr.EBool true, true)];
- test_tools = []
- })
- ];
- plugins = [(`Extra, "DevFiles", Some "0.2")];
- schema_data = PropList.Data.create ();
- plugin_data = []
- };
- oasis_fn = Some "_oasis";
- oasis_version = "0.3.0";
- oasis_digest = Some "wX\249B\007\151\134\1970p\217\138\017\214\244\241";
- oasis_exec = None;
- oasis_setup_args = [];
- setup_update = false
- };;
-
-let setup () = BaseSetup.setup setup_t;;
-
-# 5883 "setup.ml"
-(* OASIS_STOP *)
-let () = setup ();;
diff --git a/src/Makefile.in b/src/Makefile.in
index 9d7e902c..126a31f7 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -1,4 +1,4 @@
-OCAMLBUILD=@OCAMLBUILD@ -classic-display -no-links
+OCAMLBUILD=@OCAMLBUILD@ -classic-display -use-ocamlfind -no-links
prefix=@prefix@
exec_prefix=@exec_prefix@
diff --git a/src/_tags b/src/_tags
index bcfbd0e4..e3fd0e0e 100644
--- a/src/_tags
+++ b/src/_tags
@@ -1,10 +1,15 @@
"backends/C": include
"backends/Horn": include
+"plugins/salsa": include
+"plugins/scopes": include
<**/.svn>: -traverse
<**/.svn>: not_hygienic
"main_lustre_compiler.native": use_graph
"main_lustre_compiler.native": use_str
"main_lustre_compiler.native": use_unix
-<*.ml{,i}>: use_graph
-<*.ml{,i}>: use_str
-<*.ml{,i}>: use_unix
+"main_lustre_compiler.native": use_num, package(salsa)
+#<*.ml{,i}>: package(salsa)
+<**/*.cm?>: use_graph
+#<*.ml{,i}>: use_str
+#<*.ml{,i}>: use_unix
+<**/*.cm?>: package(salsa)
diff --git a/src/backends/C/c_backend.ml b/src/backends/C/c_backend.ml
index a6d1d711..7938f974 100644
--- a/src/backends/C/c_backend.ml
+++ b/src/backends/C/c_backend.ml
@@ -26,19 +26,18 @@ let makefile_opt print basename dependencies makefile_fmt machines =
*)
let gen_files funs basename prog machines dependencies header_file source_lib_file source_main_file makefile_file machines =
-
let header_out = open_out header_file in
let header_fmt = formatter_of_out_channel header_out in
let source_lib_out = open_out source_lib_file in
let source_lib_fmt = formatter_of_out_channel source_lib_out in
-
+
let print_header, print_lib_c, print_main_c, print_makefile = funs in
(* Generating H file *)
print_header header_fmt basename prog machines dependencies;
-
+
(* Generating Lib C file *)
print_lib_c source_lib_fmt basename prog machines dependencies;
-
+
close_out header_out;
close_out source_lib_out;
@@ -46,7 +45,11 @@ let gen_files funs basename prog machines dependencies header_file source_lib_fi
| "" -> () (* No main node: we do not genenrate main nor makefile *)
| 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; assert false
+ | None -> begin
+ Global.main_node := main_node;
+ Format.eprintf "Code generation error: %a@." Corelang.pp_error LustreSpec.Main_not_found;
+ raise (Corelang.Error (Location.dummy_loc, LustreSpec.Main_not_found))
+ end
| Some m -> begin
let source_main_out = open_out source_main_file in
let source_main_fmt = formatter_of_out_channel source_main_out in
@@ -65,7 +68,8 @@ let gen_files funs basename prog machines dependencies header_file source_lib_fi
end
)
-let translate_to_c header source_lib source_main makefile basename prog machines dependencies =
+let translate_to_c header source_lib source_main makefile basename prog machines dependencies =
+
match !Options.spec with
| "no" -> begin
let module HeaderMod = C_backend_header.EmptyMod in
@@ -77,7 +81,7 @@ let translate_to_c header source_lib source_main makefile basename prog machines
let module Source = C_backend_src.Main (SourceMod) in
let module SourceMain = C_backend_main.Main (SourceMainMod) in
let module Makefile = C_backend_makefile.Main (MakefileMod) in
-
+
let funs =
Header.print_alloc_header,
Source.print_lib_c,
@@ -100,7 +104,7 @@ let translate_to_c header source_lib source_main makefile basename prog machines
let module Source = C_backend_src.Main (SourceMod) in
let module SourceMain = C_backend_main.Main (SourceMainMod) in
let module Makefile = C_backend_makefile.Main (MakefileMod) in
-
+
let funs =
Header.print_alloc_header,
Source.print_lib_c,
diff --git a/src/backends/C/c_backend_common.ml b/src/backends/C/c_backend_common.ml
index d7674274..a6d2bac8 100644
--- a/src/backends/C/c_backend_common.ml
+++ b/src/backends/C/c_backend_common.ml
@@ -90,6 +90,8 @@ 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_reset_name fmt id = fprintf fmt "%s_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 rec pp_c_dimension fmt dim =
@@ -116,16 +118,17 @@ let is_basic_c_type t =
let pp_basic_c_type fmt t =
match (Types.repr t).Types.tdesc with
- | Types.Tbool -> fprintf fmt "_Bool"
- | Types.Treal -> fprintf fmt "double"
- | Types.Tint -> fprintf fmt "int"
+ | Types.Tbool -> fprintf fmt "_Bool"
+ | Types.Treal when !Options.mpfr -> fprintf fmt "%s" Mpfr.mpfr_t
+ | Types.Treal -> fprintf fmt "double"
+ | Types.Tint -> fprintf fmt "int"
| _ -> assert false (* Not a basic C type. Do not handle arrays or pointers *)
let pp_c_type var fmt t =
let rec aux t pp_suffix =
match (Types.repr t).Types.tdesc with
| Types.Tclock t' -> aux t' pp_suffix
- | Types.Tbool | Types.Treal | Types.Tint
+ | Types.Tbool | Types.Tint | Types.Treal
-> fprintf fmt "%a %s%a" pp_basic_c_type t var pp_suffix ()
| Types.Tarray (d, t') ->
let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
@@ -135,30 +138,29 @@ let pp_c_type var fmt t =
| Types.Tarrow (_, _) -> fprintf fmt "void (*%s)()" var
| _ -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false
in aux t (fun fmt () -> ())
-
+(*
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 -> 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)
-
(* Prints a constant value *)
let rec pp_c_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_real (c,e,s)-> pp_print_string fmt s (* Format.fprintf fmt "%ie%i" c e*)
+ (* | Const_float r -> pp_print_float fmt r *)
| Const_tag t -> pp_c_tag fmt t
| Const_array ca -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca
| Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl
@@ -169,17 +171,16 @@ let rec pp_c_const fmt c =
but an offset suffix may be added for array variables
*)
let rec pp_c_val self pp_var fmt v =
- (*Format.eprintf "C_backend_common.pp_c_val %a@." pp_val v;*)
- match v with
+ match v.value_desc with
| Cst c -> pp_c_const fmt c
| Array vl -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
| Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
- | Power (v, n) -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." pp_val v; assert false)
+ | Power (v, n) -> assert false
| LocalVar v -> pp_var fmt v
| StateVar v ->
(* 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
+ 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
| Fun (n, vl) -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl
@@ -191,9 +192,10 @@ let rec pp_c_val self pp_var fmt v =
- moreover, dereference memory array variables.
*)
let pp_c_var_read m fmt id =
+ (* mpfr_t is a static array, not treated as general arrays *)
if Types.is_address_type id.var_type
then
- if is_memory m id
+ if 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
@@ -289,9 +291,9 @@ let pp_c_checks self fmt m =
let pp_registers_struct fmt m =
if m.mmemory <> []
then
- fprintf fmt "@[%a {@[%a; @]}@] _reg; "
+ fprintf fmt "@[%a {@[<v>%a;@ @]}@] _reg; "
pp_machine_regtype_name m.mname.node_id
- (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
+ (Utils.fprintf_list ~sep:";@ " pp_c_decl_struct_var) m.mmemory
else
()
@@ -302,11 +304,12 @@ let print_machine_struct fmt m =
else
begin
(* Define struct *)
- fprintf fmt "@[%a {@[%a%a%t@]};@]@."
+ fprintf fmt "@[%a {@[<v>%a%t%a%t@]};@]@."
pp_machine_memtype_name m.mname.node_id
pp_registers_struct m
- (Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances
- (Utils.pp_final_char_if_non_empty "; " m.minstances)
+ (Utils.pp_final_char_if_non_empty "@ " m.mmemory)
+ (Utils.fprintf_list ~sep:";@ " pp_c_decl_instance_var) m.minstances
+ (Utils.pp_final_char_if_non_empty ";@ " m.minstances)
end
let print_machine_struct_from_header fmt inode =
@@ -338,6 +341,22 @@ let print_reset_prototype self fmt (name, static) =
pp_machine_memtype_name name
self
+let print_init_prototype self fmt (name, static) =
+ fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
+ pp_machine_init_name name
+ (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
+ (Utils.pp_final_char_if_non_empty ",@," static)
+ pp_machine_memtype_name name
+ self
+
+let print_clear_prototype self fmt (name, static) =
+ fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
+ pp_machine_clear_name name
+ (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
+ (Utils.pp_final_char_if_non_empty ",@," static)
+ pp_machine_memtype_name name
+ self
+
let print_stateless_prototype fmt (name, inputs, outputs) =
fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
pp_machine_step_name name
@@ -383,6 +402,156 @@ let print_extern_alloc_prototypes fmt (Dep (_,_, header,_)) =
| _ -> ()
) header
+
+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_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) =
+ if m.mmemory = []
+ then
+ fprintf fmt "%a (%a%t%a);"
+ pp_machine_step_name mname
+ (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
+ (Utils.pp_final_char_if_non_empty ", " inputs)
+ (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
+ else
+ fprintf fmt "%a (%a%t%a%t%s);"
+ pp_machine_step_name mname
+ (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
+ (Utils.pp_final_char_if_non_empty ", " inputs)
+ (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
+ (Utils.pp_final_char_if_non_empty ", " outputs)
+ self
+
+let pp_c_var m self pp_var fmt var =
+ if is_memory m var
+ then
+ pp_c_val self pp_var fmt (mk_val (StateVar var) var.var_type)
+ else
+ pp_c_val self pp_var fmt (mk_val (LocalVar var) var.var_type)
+
+let pp_array_suffix fmt loop_vars =
+ Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars
+
+(* type directed initialization: useless wrt the lustre compilation model,
+ 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
+ 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_var_suffix fmt var =
+ 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
+ if Types.is_real_type (Types.array_base_type var.var_type) && !Options.mpfr
+ then
+ begin
+ reset_loop_counter ();
+ aux [] fmt var.var_type
+ end
+
+(* 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
+ 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_var_suffix fmt var =
+ 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
+ if Types.is_real_type (Types.array_base_type var.var_type) && !Options.mpfr
+ then
+ begin
+ reset_loop_counter ();
+ aux [] fmt var.var_type
+ end
+
+let pp_call m self pp_read pp_write fmt i (inputs: value_t list) (outputs: var_decl list) =
+ try (* stateful node instance *)
+ let (n,_) = List.assoc i m.minstances in
+ fprintf fmt "%a (%a%t%a%t%s->%s);"
+ pp_machine_step_name (node_name n)
+ (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
+ (Utils.pp_final_char_if_non_empty ", " inputs)
+ (Utils.fprintf_list ~sep:", " pp_write) outputs
+ (Utils.pp_final_char_if_non_empty ", " outputs)
+ self
+ i
+ with Not_found -> (* stateless node instance *)
+ let (n,_) = List.assoc i m.mcalls in
+ fprintf fmt "%a (%a%t%a);"
+ pp_machine_step_name (node_name n)
+ (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
+ (Utils.pp_final_char_if_non_empty ", " inputs)
+ (Utils.fprintf_list ~sep:", " pp_write) outputs
+
+let pp_basic_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
+ pp_call m self (pp_c_var_read m) (pp_c_var_write m) fmt i inputs outputs
+(*
+ try (* stateful node instance *)
+ let (n,_) = List.assoc i m.minstances in
+ fprintf fmt "%a (%a%t%a%t%s->%s);"
+ pp_machine_step_name (node_name n)
+ (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
+ (Utils.pp_final_char_if_non_empty ", " inputs)
+ (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
+ (Utils.pp_final_char_if_non_empty ", " outputs)
+ self
+ i
+ with Not_found -> (* stateless node instance *)
+ let (n,_) = List.assoc i m.mcalls in
+ fprintf fmt "%a (%a%t%a);"
+ pp_machine_step_name (node_name n)
+ (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
+ (Utils.pp_final_char_if_non_empty ", " inputs)
+ (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
+*)
+
+let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
+ let pp_offset pp_var indices fmt var =
+ match indices with
+ | [] -> fprintf fmt "%a" pp_var var
+ | _ -> fprintf fmt "%a[%a]" pp_var var (Utils.fprintf_list ~sep:"][" pp_print_string) 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 pp_read pp_write fmt i inputs outputs
+ in
+ begin
+ reset_loop_counter ();
+ aux [] fmt (List.hd inputs).value_type
+ end
+
(* Local Variables: *)
(* compile-command:"make -C ../../.." *)
(* End: *)
diff --git a/src/backends/C/c_backend_header.ml b/src/backends/C/c_backend_header.ml
index ffe95755..0a11a467 100644
--- a/src/backends/C/c_backend_header.ml
+++ b/src/backends/C/c_backend_header.ml
@@ -34,10 +34,16 @@ module Main = functor (Mod: MODIFIERS_HDR) ->
struct
let print_import_standard fmt =
- fprintf fmt "#include \"%s/arrow.h\"@.@." Version.include_path
+ begin
+ if !Options.mpfr then
+ begin
+ fprintf fmt "#include <mpfr.h>@."
+ end;
+ fprintf fmt "#include \"%s/arrow.h\"@.@." Version.include_path
+ end
let rec print_static_val pp_var fmt v =
- match v with
+ match v.value_desc with
| Cst c -> pp_c_const fmt c
| LocalVar v -> pp_var fmt v
| Fun (n, vl) -> Basic_library.pp_c n (print_static_val pp_var) fmt vl
@@ -144,6 +150,7 @@ let print_static_alloc_macro fmt (m, attr, inst) =
pp_machine_static_link_name m.mname.node_id
inst
+
let print_machine_decl fmt m =
Mod.print_machine_decl_prefix fmt m;
if fst (get_stateless_status m) then
@@ -175,6 +182,12 @@ let print_machine_decl fmt m =
fprintf fmt "extern %a;@.@."
(print_reset_prototype self) (m.mname.node_id, m.mstatic);
+ fprintf fmt "extern %a;@.@."
+ (print_init_prototype self) (m.mname.node_id, m.mstatic);
+
+ fprintf fmt "extern %a;@.@."
+ (print_clear_prototype self) (m.mname.node_id, m.mstatic);
+
fprintf fmt "extern %a;@.@."
(print_step_prototype self)
(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
@@ -233,7 +246,13 @@ let print_machine_decl_from_header fmt inode =
let self = mk_new_name used "self" in
fprintf fmt "extern %a;@.@."
(print_reset_prototype self) (inode.nodei_id, static_inputs);
-
+
+ fprintf fmt "extern %a;@.@."
+ (print_init_prototype self) (inode.nodei_id, static_inputs);
+
+ fprintf fmt "extern %a;@.@."
+ (print_clear_prototype self) (inode.nodei_id, static_inputs);
+
fprintf fmt "extern %a;@.@."
(print_step_prototype self)
(inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs)
@@ -249,8 +268,10 @@ and 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_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
diff --git a/src/backends/C/c_backend_main.ml b/src/backends/C/c_backend_main.ml
index 578c6a3e..f10bc45d 100644
--- a/src/backends/C/c_backend_main.ml
+++ b/src/backends/C/c_backend_main.ml
@@ -30,80 +30,122 @@ struct
(* Main related functions *)
(********************************************************************************************)
-let print_get_input fmt v =
- match (Types.repr v.var_type).Types.tdesc with
- | Types.Tint -> fprintf fmt "_get_int(\"%s\")" v.var_id
- | Types.Tbool -> fprintf fmt "_get_bool(\"%s\")" v.var_id
- | Types.Treal -> fprintf fmt "_get_double(\"%s\")" v.var_id
- | _ -> assert false
+let print_get_inputs fmt m =
+ let pi fmt (v', v) =
+ match v.var_type.Types.tdesc with
+ | Types.Tint -> fprintf fmt "%s = _get_int(\"%s\")" v.var_id v'.var_id
+ | Types.Tbool -> fprintf fmt "%s = _get_bool(\"%s\")" v.var_id v'.var_id
+ | Types.Treal when !Options.mpfr -> fprintf fmt "mpfr_set_d(%s, _get_double(\"%s\"), %i)" v.var_id v'.var_id (Mpfr.mpfr_prec ())
+ | Types.Treal -> fprintf fmt "%s = _get_double(\"%s\")" v.var_id v'.var_id
+ | _ ->
+ begin
+ Global.main_node := !Options.main_node;
+ Format.eprintf "Code generation error: %a%a@."
+ pp_error Main_wrong_kind
+ Location.pp_loc v'.var_loc;
+ raise (Error (v'.var_loc, Main_wrong_kind))
+ end
+ in
+ List.iter2 (fun v' v -> fprintf fmt "@ %a;" pi (v', v)) m.mname.node_inputs m.mstep.step_inputs
-let print_put_outputs fmt ol =
- let po fmt o =
- match (Types.repr 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
+let print_put_outputs fmt m =
+ let po fmt (o', o) =
+ 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 when !Options.mpfr -> fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s))" o'.var_id o.var_id (Mpfr.mpfr_rnd ())
+ | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o'.var_id o.var_id
| _ -> assert false
in
- List.iter (fprintf fmt "@ %a;" po) ol
+ List.iter2 (fun v' v -> fprintf fmt "@ %a;" po (v', v)) m.mname.node_outputs m.mstep.step_outputs
+
+let print_main_inout_declaration fmt m =
+ begin
+ fprintf fmt "/* Declaration of inputs/outputs variables */@ ";
+ List.iter
+ (fun v -> fprintf fmt "%a;@ " (pp_c_type v.var_id) v.var_type
+ ) m.mstep.step_inputs;
+ List.iter
+ (fun v -> fprintf fmt "%a;@ " (pp_c_type v.var_id) v.var_type
+ ) m.mstep.step_outputs
+ end
+
+let print_main_memory_allocation mname main_mem fmt m =
+ if m.mmemory <> [] then
+ begin
+ fprintf fmt "@ /* Main memory allocation */@ ";
+ 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 mname pp_machine_alloc_name mname);
+ fprintf fmt "@ /* Initialize the main memory */@ ";
+ fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem;
+ end
+
+let print_main_initialize mname main_mem fmt m =
+ if m.mmemory <> []
+ then
+ fprintf fmt "@ /* Initialize inputs, outputs and memories */@ %a%t%a%t%a(%s);@ "
+ (Utils.fprintf_list ~sep:"@ " (pp_initialize m main_mem (pp_c_var_read m))) m.mstep.step_inputs
+ (Utils.pp_newline_if_non_empty m.mstep.step_inputs)
+ (Utils.fprintf_list ~sep:"@ " (pp_initialize m main_mem (pp_c_var_read m))) m.mstep.step_outputs
+ (Utils.pp_newline_if_non_empty m.mstep.step_inputs)
+ pp_machine_init_name mname
+ main_mem
+ else
+ fprintf fmt "@ /* Initialize inputs and outputs */@ %a%t%a@ "
+ (Utils.fprintf_list ~sep:"@ " (pp_initialize m main_mem (pp_c_var_read m))) m.mstep.step_inputs
+ (Utils.pp_newline_if_non_empty m.mstep.step_inputs)
+ (Utils.fprintf_list ~sep:"@ " (pp_initialize m main_mem (pp_c_var_read m))) m.mstep.step_outputs
+
+let print_main_clear mname main_mem fmt m =
+ if m.mmemory <> []
+ then
+ fprintf fmt "@ /* Clear inputs, outputs and memories */@ %a%t%a%t%a(%s);@ "
+ (Utils.fprintf_list ~sep:"@ " (pp_clear m main_mem (pp_c_var_read m))) m.mstep.step_inputs
+ (Utils.pp_newline_if_non_empty m.mstep.step_inputs)
+ (Utils.fprintf_list ~sep:"@ " (pp_clear m main_mem (pp_c_var_read m))) m.mstep.step_outputs
+ (Utils.pp_newline_if_non_empty m.mstep.step_inputs)
+ pp_machine_clear_name mname
+ main_mem
+ else
+ fprintf fmt "@ /* Clear inputs and outputs */@ %a%t%a@ "
+ (Utils.fprintf_list ~sep:"@ " (pp_clear m main_mem (pp_c_var_read m))) m.mstep.step_inputs
+ (Utils.pp_newline_if_non_empty m.mstep.step_inputs)
+ (Utils.fprintf_list ~sep:"@ " (pp_clear m main_mem (pp_c_var_read m))) m.mstep.step_outputs
+
+let print_main_loop mname main_mem fmt m =
+ let input_values =
+ List.map (fun v -> mk_val (LocalVar v) v.var_type)
+ m.mstep.step_inputs in
+ begin
+ fprintf fmt "@ ISATTY = isatty(0);@ ";
+ fprintf fmt "@ /* Infinite loop */@ ";
+ fprintf fmt "@[<v 2>while(1){@ ";
+ fprintf fmt "fflush(stdout);@ ";
+ fprintf fmt "%a@ %t%a"
+ print_get_inputs m
+ (fun fmt -> pp_main_call mname main_mem fmt m input_values m.mstep.step_outputs)
+ print_put_outputs m
+ end
-let print_main_fun machines m fmt =
+let print_main_code fmt m =
let mname = m.mname.node_id in
let main_mem =
if (!Options.static_mem && !Options.main_node <> "")
then "&main_mem"
else "main_mem" in
fprintf fmt "@[<v 2>int main (int argc, char *argv[]) {@ ";
- fprintf fmt "/* Declaration of inputs/outputs variables */@ ";
- List.iter
- (fun v -> fprintf fmt "%a = %a;@ " (pp_c_type v.var_id) v.var_type pp_c_initialize v.var_type
- ) m.mstep.step_inputs;
- List.iter
- (fun v -> fprintf fmt "%a = %a;@ " (pp_c_type v.var_id) v.var_type 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(static,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);
- fprintf fmt "@ /* Initialize the main memory */@ ";
- fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem;
- fprintf fmt "@ ISATTY = isatty(0);@ ";
- fprintf fmt "@ /* Infinite loop */@ ";
- fprintf fmt "@[<v 2>while(1){@ ";
- fprintf fmt "fflush(stdout);@ ";
- List.iter
- (fun v -> fprintf fmt "%s = %a;@ "
- v.var_id
- print_get_input v
- ) m.mstep.step_inputs;
- (match m.mstep.step_outputs with
- (* | [] -> ( *)
- (* 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 *)
- (* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
- (* main_mem *)
- (* ) *)
- (* | [o] -> ( *)
- (* 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 *)
- (* 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
- (Utils.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)
- );
- fprintf fmt "@]@ }@ ";
- fprintf fmt "return 1;";
+ print_main_inout_declaration fmt m;
+ print_main_memory_allocation mname main_mem fmt m;
+ print_main_initialize mname main_mem fmt m;
+ print_main_loop mname main_mem fmt m;
+ if Scopes.Plugin.is_active () then
+ begin
+ fprintf fmt "@ %t" Scopes.Plugin.pp
+ end;
+ fprintf fmt "@]@ }@ @ ";
+ print_main_clear mname main_mem fmt m;
+ fprintf fmt "@ return 1;";
fprintf fmt "@]@ }@."
let print_main_header fmt =
@@ -118,7 +160,7 @@ let print_main_c main_fmt main_machine basename prog machines _ (*dependencies*)
(* Print the svn version number and the supported C standard (C90 or C99) *)
print_version main_fmt;
- print_main_fun machines main_machine main_fmt
+ print_main_code main_fmt main_machine
end
(* Local Variables: *)
diff --git a/src/backends/C/c_backend_makefile.ml b/src/backends/C/c_backend_makefile.ml
index 70371b40..99c10b05 100644
--- a/src/backends/C/c_backend_makefile.ml
+++ b/src/backends/C/c_backend_makefile.ml
@@ -18,7 +18,7 @@ let header_has_code header =
(fun top ->
match top.top_decl_desc with
| Const _ -> true
- | ImportedNode nd -> nd.nodei_in_lib = None
+ | ImportedNode nd -> nd.nodei_in_lib = []
| _ -> false
)
header
@@ -26,9 +26,7 @@ let header_has_code header =
let header_libs header =
List.fold_left (fun accu top ->
match top.top_decl_desc with
- | ImportedNode nd -> (match nd.nodei_in_lib with
- | None -> accu
- | Some lib -> Utils.list_union [lib] accu)
+ | ImportedNode nd -> Utils.list_union nd.nodei_in_lib accu
| _ -> accu
) [] header
@@ -87,6 +85,8 @@ let print_makefile basename nodename (dependencies: dep_t list) 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 "@.";
diff --git a/src/backends/C/c_backend_src.ml b/src/backends/C/c_backend_src.ml
index c8c06713..d1b46796 100644
--- a/src/backends/C/c_backend_src.ml
+++ b/src/backends/C/c_backend_src.ml
@@ -30,42 +30,50 @@ struct
(* Instruction Printing functions *)
(********************************************************************************************)
-
(* 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 with
- | Cst (Const_array cl) -> 1 + List.fold_right (fun c -> max (expansion_depth (Cst c))) cl 0
- | Cst _
- | LocalVar _
- | StateVar _ -> 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, i) -> max 0 (expansion_depth v - 1)
- | Power (v, n) -> 0 (*1 + expansion_depth v*)
-
-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
+ let rec expansion_depth v =
+ match v.value_desc with
+ | Cst cst -> expansion_depth_cst cst
+ | LocalVar _
+ | StateVar _ -> 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, i) -> max 0 (expansion_depth v - 1)
+ | Power (v, n) -> 0 (*1 + expansion_depth v*)
+ 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
+
+ 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 with
- | Cst (Const_array cl) ->
- List.fold_right (fun c lp -> merge_static_loop_profiles lp (static_loop_profile (Cst c))) cl []
- | Cst _
- | LocalVar _
- | StateVar _ -> []
- | 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, i) -> (match (static_loop_profile v) with [] -> [] | _ :: q -> q)
- | Power (v, n) -> false :: static_loop_profile v
-
+ let rec static_loop_profile v =
+ match v.value_desc with
+ | Cst cst -> static_loop_profile_cst cst
+ | LocalVar _
+ | StateVar _ -> []
+ | 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, i) -> (match (static_loop_profile v) with [] -> [] | _ :: q -> q)
+ | Power (v, n) -> 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
+ []
+ | _ -> []
+
+
let rec is_const_index v =
- match v with
+ match v.value_desc with
| Cst (Const_int _) -> true
| Fun (_, vl) -> List.for_all is_const_index vl
| _ -> false
@@ -114,65 +122,29 @@ let pp_loop_var fmt lv =
let pp_suffix fmt loop_vars =
Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars
-(* 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
- | 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_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 (Utils.fprintf_list ~sep:", " (pp_c_const_suffix var_type)) ca
- | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)) fl
- | Const_string _ -> 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 self var_type loop_vars pp_value fmt value =
-(*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)
- match loop_vars, value with
- | (x, LAcc i) :: q, _ when is_const_index i ->
- let r = ref (Dimension.size_const_dimension (Machine_code.dimension_of_value i)) in
- pp_value_suffix self var_type ((x, LInt r)::q) pp_value fmt value
- | (_, LInt r) :: q, Cst (Const_array cl) ->
- let var_type = Types.array_element_type var_type in
- pp_value_suffix self var_type q pp_value fmt (Cst (List.nth cl !r))
+(* Prints a [value] indexed by the suffix list [loop_vars] *)
+let rec pp_value_suffix self loop_vars pp_value fmt value =
+ match loop_vars, value.value_desc with
| (_, LInt r) :: q, Array vl ->
- let var_type = Types.array_element_type var_type in
- pp_value_suffix self var_type q pp_value fmt (List.nth vl !r)
- | loop_var :: q, Array vl ->
- let var_type = Types.array_element_type var_type in
- Format.fprintf fmt "(%a[]){%a }%a" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix self var_type q pp_value)) vl pp_suffix [loop_var]
- | [] , Array vl ->
- let var_type = Types.array_element_type var_type in
- Format.fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix self var_type [] pp_value)) vl
+ pp_value_suffix self q pp_value fmt (List.nth vl !r)
| _ :: q, Power (v, n) ->
- pp_value_suffix self var_type q pp_value fmt v
+ pp_value_suffix self q pp_value fmt v
| _ , Fun (n, vl) ->
- Basic_library.pp_c n (pp_value_suffix self var_type loop_vars pp_value) fmt vl
+ Basic_library.pp_c n (pp_value_suffix self loop_vars pp_value) fmt vl
| _ , Access (v, i) ->
- let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in
- pp_value_suffix self var_type ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v
- | _ , LocalVar v -> Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars
- | _ , StateVar v ->
- (* 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 Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars
- else Format.fprintf fmt "%s->_reg.%a%a" self pp_value v pp_suffix loop_vars
- | _ , Cst cst -> pp_c_const_suffix var_type fmt cst
- | _ , _ -> (Format.eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars; assert false)
-
-(* 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 self pp_var fmt (t, v) =
- pp_value_suffix self t [] pp_var fmt v
+ pp_value_suffix self ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v
+ | _ , _ ->
+ let pp_var_suffix fmt v = fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in
+ pp_c_val self pp_var_suffix fmt value
+
+let pp_basic_assign pp_var fmt typ var_name value =
+ 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
@@ -180,49 +152,68 @@ let pp_c_val self pp_var fmt (t, v) =
- [value]: assigned value
- [pp_var]: printer for variables
*)
-(*
-let pp_assign_rec pp_var var_type var_name value =
- match (Types.repr var_type).Types.tdesc, value with
- | Types.Tarray (d, ty'), Array vl ->
- let szl = Utils.enumerate (Dimension.size_const_dimension d) in
- fprintf fmt "@[<v 2>{@,%a@]@,}"
- (Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
- | Types.Tarray (d, ty'), Power (v, _) ->
- | Types.Tarray (d, ty'), _ ->
- | _ , _ ->
- fprintf fmt "%a = %a;"
- pp_var var_name
- (pp_value_suffix self loop_vars pp_var) value
-*)
let pp_assign m self pp_var fmt var_type var_name value =
let depth = expansion_depth value in
-(*Format.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 %d@." Types.print_ty var_type pp_val var_name 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 fmt vars =
+ let rec aux typ fmt vars =
match vars with
| [] ->
- fprintf fmt "%a = %a;"
- (pp_value_suffix self var_type loop_vars pp_var) var_name
- (pp_value_suffix self var_type loop_vars pp_var) value
+ pp_basic_assign (pp_value_suffix self loop_vars pp_var) fmt typ var_name 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 Dimension.pp_dimension d i
- aux q
+ 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 szl = Utils.enumerate (Dimension.size_const_dimension d) in
- fprintf fmt "@[<v 2>{@,%a@]@,}"
- (Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
+ let typ' = Types.array_element_type typ in
+ let szl = Utils.enumerate (Dimension.size_const_dimension d) in
+ fprintf fmt "@[<v 2>{@,%a@]@,}"
+ (Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux typ' fmt q)) szl
| _ -> assert false
in
begin
reset_loop_counter ();
(*reset_addr_counter ();*)
- aux fmt reordered_loop_vars
+ aux var_type fmt reordered_loop_vars
end
+let pp_machine_reset (m: machine_t) self fmt inst =
+ let (node, static) =
+ try
+ List.assoc inst m.minstances
+ with Not_found -> (Format.eprintf "internal error: pp_machine_reset %s %s %s:@." m.mname.node_id self inst; raise Not_found) in
+ fprintf fmt "%a(%a%t%s->%s);"
+ pp_machine_reset_name (node_name node)
+ (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
+ (Utils.pp_final_char_if_non_empty ", " static)
+ self inst
+
+let pp_machine_init (m: machine_t) self fmt inst =
+ let (node, static) =
+ try
+ List.assoc inst m.minstances
+ with Not_found -> (Format.eprintf "internal error: pp_machine_init %s %s %s@." m.mname.node_id self inst; raise Not_found) in
+ fprintf fmt "%a(%a%t%s->%s);"
+ pp_machine_init_name (node_name node)
+ (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
+ (Utils.pp_final_char_if_non_empty ", " static)
+ self inst
+
+let pp_machine_clear (m: machine_t) self fmt inst =
+ let (node, static) =
+ try
+ List.assoc inst m.minstances
+ with Not_found -> (Format.eprintf "internal error: pp_machine_clear %s %s %s@." m.mname.node_id self inst; raise Not_found) in
+ fprintf fmt "%a(%a%t%s->%s);"
+ pp_machine_clear_name (node_name node)
+ (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
+ (Utils.pp_final_char_if_non_empty ", " static)
+ self inst
+
let has_c_prototype funname dependencies =
let imported_node_opt = (* We select the last imported node with the name funname.
The order of evaluation of dependencies should be
@@ -248,51 +239,9 @@ let has_c_prototype funname dependencies =
| None -> false
| Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
-let pp_instance_call dependencies m self fmt i (inputs: value_t list) (outputs: var_decl list) =
- try (* stateful node instance *)
- let (n,_) = List.assoc i m.minstances in
- let (input_types, _) = Typing.get_type_of_call n in
- let inputs = List.combine input_types inputs in
- fprintf fmt "%a (%a%t%a%t%s->%s);"
- pp_machine_step_name (node_name n)
- (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
- (Utils.pp_final_char_if_non_empty ", " inputs)
- (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
- (Utils.pp_final_char_if_non_empty ", " outputs)
- self
- i
- with Not_found -> (* stateless node instance *)
- let (n,_) = List.assoc i m.mcalls in
- let (input_types, output_types) = Typing.get_type_of_call n in
- let inputs = List.combine input_types inputs in
- if has_c_prototype i dependencies
- then (* external C function *)
- let outputs = List.map2 (fun t v -> t, LocalVar v) output_types outputs in
- fprintf fmt "%a = %s(%a);"
- (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) outputs
- i
- (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
- else
- fprintf fmt "%a (%a%t%a);"
- pp_machine_step_name (node_name n)
- (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
- (Utils.pp_final_char_if_non_empty ", " inputs)
- (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
-
-let pp_machine_reset (m: machine_t) self fmt inst =
- let (node, static) =
- try
- List.assoc inst m.minstances
- with Not_found -> (Format.eprintf "pp_machine_reset %s %s %s: internal error@," m.mname.node_id self inst; raise Not_found) in
- fprintf fmt "%a(%a%t%s->%s);"
- pp_machine_reset_name (node_name node)
- (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
- (Utils.pp_final_char_if_non_empty ", " static)
- self inst
-
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
- (pp_c_val self (pp_c_var_read m)) (Type_predef.type_bool, c)
+ (pp_c_val self (pp_c_var_read m)) c
(Utils.pp_newline_if_non_empty tl)
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
(Utils.pp_newline_if_non_empty el)
@@ -305,31 +254,42 @@ and pp_machine_instr dependencies (m: machine_t) self fmt instr =
| MLocalAssign (i,v) ->
pp_assign
m self (pp_c_var_read m) fmt
- i.var_type (LocalVar i) v
+ i.var_type (mk_val (LocalVar i) i.var_type) v
| MStateAssign (i,v) ->
pp_assign
m self (pp_c_var_read m) fmt
- i.var_type (StateVar i) v
- | MStep ([i0], i, vl) when Basic_library.is_internal_fun i ->
- pp_machine_instr dependencies m self fmt (MLocalAssign (i0, Fun (i, vl)))
+ i.var_type (mk_val (StateVar i) i.var_type) 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 fmt
+ (MLocalAssign (i0, mk_val (Fun (i, vl)) i0.var_type))
+ | MStep ([i0], i, vl) when has_c_prototype i dependencies ->
+ fprintf fmt "%a = %s(%a);"
+ (pp_c_val self (pp_c_var_read m)) (mk_val (LocalVar i0) i0.var_type)
+ i
+ (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl
+ | MStep (il, i, vl) when Mpfr.is_homomorphic_fun i ->
+ pp_instance_call m self fmt i vl il
| MStep (il, i, vl) ->
- pp_instance_call dependencies m self fmt i vl il
- | MBranch (_, []) -> (Format.eprintf "internal error: C_backend_src.pp_machine_instr %a@." pp_instr instr; assert false)
- | MBranch (g, hl) ->
- if let t = fst (List.hd hl) in t = tag_true || t = tag_false
+ pp_basic_instance_call m self fmt i vl il
+ | MBranch (g,hl) ->
+ if hl <> [] && 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 *)
+ (* 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
pp_conditional dependencies m self fmt g tl 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 self (pp_c_var_read m)) (g_typ, g)
+ (pp_c_val self (pp_c_var_read m)) g
(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl
+ | MComment s ->
+ fprintf fmt "//%s@ " s
+
and pp_machine_branch dependencies m self fmt (t, h) =
- fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_c_tag t (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) h
+ fprintf fmt "@[<v 2>case %a:@,%a@,break;@]"
+ pp_c_tag t
+ (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) h
(********************************************************************************************)
@@ -379,31 +339,43 @@ let print_stateless_code dependencies fmt m =
if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc; top_decl_owner = ""; top_decl_itf = false })
then
(* C99 code *)
- fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
+ fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
(* locals *)
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals
(Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
+ (* locals initialization *)
+ (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
+ (Utils.pp_newline_if_non_empty m.mstep.step_locals)
(* check assertions *)
(pp_c_checks self) m
(* instrs *)
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
(Utils.pp_newline_if_non_empty m.mstep.step_instrs)
+ (* locals clear *)
+ (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
+ (Utils.pp_newline_if_non_empty m.mstep.step_locals)
(fun fmt -> fprintf fmt "return;")
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
- fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
+ fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
(* locals *)
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals
(Utils.pp_final_char_if_non_empty ";" base_locals)
+ (* locals initialization *)
+ (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
+ (Utils.pp_newline_if_non_empty m.mstep.step_locals)
(* check assertions *)
(pp_c_checks self) m
(* instrs *)
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
(Utils.pp_newline_if_non_empty m.mstep.step_instrs)
+ (* locals clear *)
+ (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
+ (Utils.pp_newline_if_non_empty m.mstep.step_locals)
(fun fmt -> fprintf fmt "return;")
let print_reset_code dependencies fmt m self =
@@ -417,39 +389,81 @@ let print_reset_code dependencies fmt m self =
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit
(Utils.pp_newline_if_non_empty m.minit)
+let print_init_code dependencies fmt m self =
+ let minit = List.map (function 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_clear_code dependencies fmt m self =
+ let minit = List.map (function 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 print_step_code dependencies fmt m self =
if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc; top_decl_owner = ""; top_decl_itf = false })
then
(* C99 code *)
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%a%t%t@]@,}@.@."
+ fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
(print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
- (* locals *)
+ (* locals declaration *)
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals
(Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
(* array mems *)
(Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
(Utils.pp_final_char_if_non_empty ";@," array_mems)
+ (* locals initialization *)
+ (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
+ (Utils.pp_newline_if_non_empty m.mstep.step_locals)
(* check assertions *)
(pp_c_checks self) m
(* instrs *)
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
(Utils.pp_newline_if_non_empty m.mstep.step_instrs)
+ (* locals clear *)
+ (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
+ (Utils.pp_newline_if_non_empty m.mstep.step_locals)
(fun fmt -> fprintf fmt "return;")
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
- fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
+ fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
(print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
- (* locals *)
+ (* locals declaration *)
(Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals
(Utils.pp_final_char_if_non_empty ";" base_locals)
+ (* locals initialization *)
+ (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
+ (Utils.pp_newline_if_non_empty m.mstep.step_locals)
(* check assertions *)
(pp_c_checks self) m
(* instrs *)
(Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
(Utils.pp_newline_if_non_empty m.mstep.step_instrs)
+ (* locals clear *)
+ (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
+ (Utils.pp_newline_if_non_empty m.mstep.step_locals)
(fun fmt -> fprintf fmt "return;")
@@ -476,18 +490,29 @@ let print_machine dependencies fmt m =
let self = mk_self m in
(* Reset function *)
print_reset_code dependencies fmt m self;
+ (* Init function *)
+ print_init_code dependencies fmt m self;
+ (* Clear function *)
+ print_clear_code dependencies fmt m self;
(* Step function *)
print_step_code dependencies fmt m self
end
+let print_import_standard source_fmt =
+ begin
+ fprintf source_fmt "#include <assert.h>@.";
+ if not !Options.static_mem then
+ begin
+ fprintf source_fmt "#include <stdlib.h>@.";
+ end;
+ if !Options.mpfr then
+ begin
+ fprintf source_fmt "#include <mpfr.h>@.";
+ end
+ end
let print_lib_c source_fmt basename prog machines dependencies =
-
- fprintf source_fmt "#include <assert.h>@.";
- if not !Options.static_mem then
- begin
- fprintf source_fmt "#include <stdlib.h>@.";
- end;
+ print_import_standard source_fmt;
print_import_prototype source_fmt (Dep (true, basename, [], true (* assuming it is stateful *)));
pp_print_newline source_fmt ();
(* Print the svn version number and the supported C standard (C90 or C99) *)
diff --git a/src/backends/Horn/horn_backend.ml b/src/backends/Horn/horn_backend.ml
index 24f58617..bf533895 100644
--- a/src/backends/Horn/horn_backend.ml
+++ b/src/backends/Horn/horn_backend.ml
@@ -111,8 +111,8 @@ let pp_horn_tag fmt t =
let rec pp_horn_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_real (c,e,s) -> assert false (* TODO rational pp_print_string fmt r *)
+ (* | Const_float r -> pp_print_float fmt r *)
| Const_tag t -> pp_horn_tag fmt t
| _ -> assert false
@@ -121,7 +121,7 @@ let rec pp_horn_const fmt c =
but an offset suffix may be added for array variables
*)
let rec pp_horn_val ?(is_lhs=false) self pp_var fmt v =
- match v with
+ match v.value_desc with
| Cst c -> pp_horn_const fmt c
| Array _
| Access _ -> assert false (* no arrays *)
@@ -135,7 +135,7 @@ let rec pp_horn_val ?(is_lhs=false) self pp_var fmt v =
(* Prints a [value] indexed by the suffix list [loop_vars] *)
let rec pp_value_suffix self pp_value fmt value =
- match value with
+ match value.value_desc with
| Fun (n, vl) ->
Basic_library.pp_horn n (pp_value_suffix self pp_value) fmt vl
| _ ->
@@ -163,12 +163,12 @@ let pp_instance_call
self
(pp_horn_var m)
fmt
- o.var_type (LocalVar o) i1
+ o.var_type (mk_val (LocalVar o) o.var_type) i1
else
pp_assign
m self (pp_horn_var m) fmt
- o.var_type (LocalVar o) i2
-
+ o.var_type (mk_val (LocalVar o) o.var_type) i2
+
end
| name, _, _ ->
begin
@@ -181,8 +181,8 @@ let pp_instance_call
inputs
(Utils.pp_final_char_if_non_empty " " inputs)
(* outputs *)
- (Utils.fprintf_list ~sep:" " (pp_horn_val self (pp_horn_var m)))
- (List.map (fun v -> LocalVar v) outputs)
+ (Utils.fprintf_list ~sep:" " (pp_horn_val self (pp_horn_var m)))
+ (List.map (fun v -> mk_val (LocalVar v) v.var_type) outputs)
(Utils.pp_final_char_if_non_empty " " outputs)
(* memories (next) *)
(Utils.fprintf_list ~sep:" " pp_var) (
@@ -195,9 +195,9 @@ let pp_instance_call
Format.fprintf fmt "(%a %a%t%a%t%a)"
pp_machine_step_name (node_name n)
(Utils.fprintf_list ~sep:" " (pp_horn_val self (pp_horn_var m))) inputs
- (Utils.pp_final_char_if_non_empty " " inputs)
- (Utils.fprintf_list ~sep:" " (pp_horn_val self (pp_horn_var m)))
- (List.map (fun v -> LocalVar v) outputs)
+ (Utils.pp_final_char_if_non_empty " " inputs)
+ (Utils.fprintf_list ~sep:" " (pp_horn_val self (pp_horn_var m)))
+ (List.map (fun v -> mk_val (LocalVar v) v.var_type) outputs)
(Utils.pp_final_char_if_non_empty " " outputs)
(Utils.fprintf_list ~sep:" " pp_var) (
(rename_machine_list
@@ -218,9 +218,9 @@ let pp_instance_call
(node_name n)
(Utils.fprintf_list ~sep:" " (pp_horn_val self (pp_horn_var m)))
inputs
- (Utils.pp_final_char_if_non_empty " " inputs)
- (Utils.fprintf_list ~sep:" " (pp_horn_val self (pp_horn_var m)))
- (List.map (fun v -> LocalVar v) outputs)
+ (Utils.pp_final_char_if_non_empty " " inputs)
+ (Utils.fprintf_list ~sep:" " (pp_horn_val self (pp_horn_var m)))
+ (List.map (fun v -> mk_val (LocalVar v) v.var_type) outputs)
)
let pp_machine_init (m: machine_t) self fmt inst =
@@ -247,12 +247,12 @@ and pp_machine_instr machines ?(init=false) (m: machine_t) self fmt instr =
| MLocalAssign (i,v) ->
pp_assign
m self (pp_horn_var m) fmt
- i.var_type (LocalVar i) v
+ i.var_type (mk_val (LocalVar i) i.var_type) v
| MStateAssign (i,v) ->
pp_assign
m self (pp_horn_var m) fmt
- i.var_type (StateVar i) v
- | MStep ([i0], i, vl) when Basic_library.is_internal_fun i ->
+ i.var_type (mk_val (StateVar i) i.var_type) v
+ | MStep ([i0], i, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (i, vl)) i0.var_type) ->
assert false (* This should not happen anymore *)
| MStep (il, i, vl) ->
pp_instance_call machines ~init:init m self fmt i vl il
@@ -264,6 +264,7 @@ and pp_machine_instr machines ?(init=false) (m: machine_t) self fmt instr =
let el = try List.assoc tag_false hl with Not_found -> [] in
pp_conditional machines ~init:init m self fmt g tl el
else assert false (* enum type case *)
+ | MComment _ -> ()
(**************************************************************)
@@ -362,6 +363,18 @@ let print_machine machines fmt m =
(Utils.fprintf_list ~sep:" " pp_var) (step_vars machines m);
end
);
+
+(*
+ match m.mspec with
+ None -> () (* No node spec; we do nothing *)
+ | Some {requires = []; ensures = [EnsuresExpr e]; behaviors = []} ->
+ (
+ (* For the moment, we only deal with simple case: single ensures, no other parameters *)
+ ()
+
+ )
+ | _ -> () (* Other cases give nothing *)
+*)
end
end
@@ -427,7 +440,8 @@ let check_prop machines fmt node machine =
(pp_conj pp_var) main_output
(Utils.fprintf_list ~sep:" " pp_var) main_memory_next
;
- if !Options.horn_query then Format.fprintf fmt "(query ERR)@."
+ if !Options.horn_queries then
+ Format.fprintf fmt "(query ERR)@."
let cex_computation machines fmt node machine =
diff --git a/src/basic_library.ml b/src/basic_library.ml
index 7e35b8a4..e290f787 100644
--- a/src/basic_library.ml
+++ b/src/basic_library.ml
@@ -23,15 +23,15 @@ let static_op ty =
type_static (mkdim_var ()) ty
let type_env =
- List.fold_left
+ 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);
+ "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);
@@ -48,7 +48,7 @@ let type_env =
"=", (static_op type_bin_comp_op);
"not", (static_op type_unary_bool_op)
]
-
+
module CE = Env
let clock_env =
@@ -56,10 +56,10 @@ let clock_env =
let env' =
List.fold_right (fun op env -> CE.add_value env op ck_nullary_univ)
["true"; "false"] init_env in
- let env' =
+ let env' =
List.fold_right (fun op env -> CE.add_value env op ck_unary_univ)
["uminus"; "not"] env' in
- let env' =
+ let env' =
List.fold_right (fun op env -> CE.add_value env op ck_bin_univ)
["+"; "-"; "*"; "/"; "mod"; "&&"; "||"; "xor"; "equi"; "impl"; "<"; "<="; ">"; ">="; "!="; "="] env' in
env'
@@ -74,10 +74,10 @@ let delay_env =
let env' =
List.fold_right (fun op env -> DE.add_value env op delay_unary_poly_op)
["uminus"; "not"] env' in
- let env' =
+ let env' =
List.fold_right (fun op env -> DE.add_value env op delay_binary_poly_op)
["+"; "-"; "*"; "/"; "mod"; "&&"; "||"; "xor"; "equi"; "impl"; "<"; "<="; ">"; ">="; "!="; "="] env' in
- let env' =
+ let env' =
List.fold_right (fun op env -> DE.add_value env op delay_ternary_poly_op)
[] env' in
env'
@@ -85,7 +85,7 @@ let delay_env =
module VE = Env
let eval_env =
- let defs = [
+ 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);
@@ -106,14 +106,42 @@ let eval_env =
"=", (function [a; b] -> Dbool (a=b) | _ -> assert false);
]
in
- List.fold_left
+ List.fold_left
(fun env (op, op_eval) -> VE.add_value env op op_eval)
VE.initial
defs
-let internal_funs = ["+";"-";"*";"/";"mod";"&&";"||";"xor";"equi";"impl";"<";">";"<=";">=";"!=";"=";"uminus";"not"]
+let bool_ops = ["&&";"||";"xor";"equi";"impl";"not"]
+let rel_ops = ["<";">";"<=";">=";"!=";"="]
+let num_ops = ["+";"-";"*";"/";"mod";"uminus"]
+
+let internal_funs = bool_ops@rel_ops@num_ops
+
+let rec is_internal_fun x 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
+
+let is_expr_internal_fun expr =
+ match expr.expr_desc with
+ | Expr_appl (f, e, _) -> is_internal_fun f (Types.type_list_of_type e.expr_type)
+ | _ -> assert false
-let is_internal_fun x =
+let is_value_internal_fun v =
+ 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 num_ops
+
+let is_homomorphic_fun x =
+ List.mem x internal_funs
+
+let is_stateless_fun x =
List.mem x internal_funs
let pp_c i pp_val fmt vl =
@@ -133,25 +161,24 @@ 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 *)
| "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
+ | "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)
-let pp_horn i pp_val fmt vl =
+let pp_horn 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
-
+ | "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
+ | "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
| "mod", [v1; v2] -> Format.fprintf fmt "(mod %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
diff --git a/src/causality.ml b/src/causality.ml
index 00efa543..e616ec5f 100644
--- a/src/causality.ml
+++ b/src/causality.ml
@@ -225,7 +225,7 @@ let add_eq_dependencies mems inputs node_vars eq (g, 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_internal_fun f
+ 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
@@ -278,7 +278,7 @@ module NodeDep = struct
| Expr_pre e
| Expr_when (e,_,_) -> get_expr_calls prednode e
| Expr_appl (id,e, _) ->
- if not (Basic_library.is_internal_fun id) && prednode id
+ 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)
diff --git a/src/clock_calculus.ml b/src/clock_calculus.ml
index ee201a88..879d4313 100755
--- a/src/clock_calculus.ml
+++ b/src/clock_calculus.ml
@@ -608,7 +608,7 @@ and clock_subtyping_arg env ?(sub=true) real_arg formal_clock =
(* 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_internal_fun f && List.exists is_tuple_expr args
+ 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)
diff --git a/src/compiler_common.ml b/src/compiler_common.ml
index f375d06a..8d5e2040 100644
--- a/src/compiler_common.ml
+++ b/src/compiler_common.ml
@@ -14,6 +14,13 @@ open Format
open LustreSpec
open Corelang
+let check_main () =
+ if !Options.main_node = "" then
+ begin
+ eprintf "Code generation error: %a@." pp_error No_main_specified;
+ raise (Error (Location.dummy_loc, No_main_specified))
+ end
+
let create_dest_dir () =
begin
if not (Sys.file_exists !Options.dest_dir) then
@@ -88,6 +95,16 @@ let check_stateless_decls decls =
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
+ Location.pp_loc loc;
+ raise exc
+
let type_decls env decls =
Log.report ~level:1 (fun fmt -> fprintf fmt ".. typing@ ");
let new_env =
diff --git a/src/corelang.ml b/src/corelang.ml
index 857209ec..57450e82 100755
--- a/src/corelang.ml
+++ b/src/corelang.ml
@@ -1,4 +1,3 @@
-(********************************************************************)
(* *)
(* The LustreC compiler toolset / The LustreC Development Team *)
(* Copyright 2012 - -- ONERA - CNRS - INPT *)
@@ -55,6 +54,7 @@ let mkvar_decl loc ?(orig=false) (id, ty_dec, ck_dec, is_const, value) =
let mkexpr loc d =
{ expr_tag = Utils.new_tag ();
+
expr_desc = d;
expr_type = Types.new_var ();
expr_clock = Clocks.new_var true;
@@ -245,14 +245,14 @@ let mktop = mktop_decl Location.dummy_loc Version.include_path 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_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_float, top_float_type; *)
Tydec_real , top_real_type
]
@@ -270,7 +270,7 @@ let print_type_table fmt () =
let rec is_user_type typ =
match typ with
| Tydec_int | Tydec_bool | Tydec_real
- | Tydec_float | Tydec_any | Tydec_const _ -> false
+ (* | Tydec_float *) | Tydec_any | Tydec_const _ -> false
| Tydec_clock typ' -> is_user_type typ'
| _ -> true
@@ -289,7 +289,7 @@ let rec coretype_equal ty1 ty2 =
| _ , Tydec_const _ -> coretype_equal ty2 ty1
| Tydec_int , Tydec_int
| Tydec_real , Tydec_real
- | Tydec_float , Tydec_float
+ (* | 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
@@ -461,7 +461,7 @@ let rec dimension_of_expr expr =
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_appl (f, args, None) when Basic_library.is_internal_fun f ->
+ | 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))
@@ -501,7 +501,7 @@ let mk_new_node_name nd id =
mk_new_name used id
let get_var id var_list =
- List.find (fun v -> v.var_id = id) var_list
+ List.find (fun v -> v.var_id = id) var_list
let get_node_var id node =
get_var id (get_node_vars node)
@@ -579,7 +579,7 @@ let get_node_interface nd =
nodei_stateless = nd.node_dec_stateless;
nodei_spec = nd.node_spec;
nodei_prototype = None;
- nodei_in_lib = None;
+ nodei_in_lib = [];
}
(************************************************************************)
@@ -624,16 +624,15 @@ let rec rename_carrier rename cck =
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 = replace_desc lhs rhs.expr_desc }
- and replace_desc lhs rhs_desc =
+ { rhs with expr_desc =
match lhs with
| [] -> assert false
- | [_] -> if pvar lhs then expr_desc_replace_var fvar rhs_desc else rhs_desc
+ | [_] -> if pvar lhs then expr_desc_replace_var fvar rhs.expr_desc else rhs.expr_desc
| _ ->
- (match rhs_desc with
+ (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_internal_fun f ->
+ | 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 _
@@ -643,8 +642,8 @@ let rec rename_carrier rename cck =
| Expr_ident _
| Expr_appl _ ->
if pvar lhs
- then expr_desc_replace_var fvar rhs_desc
- else rhs_desc
+ then expr_desc_replace_var 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)
@@ -654,6 +653,7 @@ let rec rename_carrier rename cck =
| 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 }
@@ -792,15 +792,15 @@ let pp_prog_clock fmt prog =
Utils.fprintf_list ~sep:"" pp_decl_clock fmt prog
let pp_error fmt = function
- | Main_not_found ->
- fprintf fmt "cannot compile node %s: could not find the node definition.@."
- !Options.main_node
+ Main_not_found ->
+ fprintf fmt "could not find the definition of main node %s.@."
+ !Global.main_node
| Main_wrong_kind ->
fprintf fmt
- "name %s does not correspond to a (non-imported) node definition.@."
- !Options.main_node
+ "name %s does not correspond to a valid main node definition.@."
+ !Global.main_node
| No_main_specified ->
- fprintf fmt "no main node specified.@."
+ fprintf fmt "no main node specified (use -node option)@."
| Unbound_symbol sym ->
fprintf fmt
"%s is undefined.@."
@@ -811,11 +811,11 @@ let pp_error fmt = function
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 the compiler.@.Please recompile the corresponding interface or source file.@."
sym
(* filling node table with internal functions *)
@@ -844,7 +844,7 @@ let mk_internal_node id =
nodei_stateless = Types.get_static_value ty <> None;
nodei_spec = spec;
nodei_prototype = None;
- nodei_in_lib = None;
+ nodei_in_lib = [];
})
let add_internal_funs () =
@@ -927,10 +927,8 @@ let rec substitute_expr vars_to_replace defs e =
*)
let rec get_expr_calls nodes e =
- get_calls_expr_desc nodes e.expr_desc
-and get_calls_expr_desc nodes expr_desc =
let get_calls = get_expr_calls nodes in
- match expr_desc with
+ match e.expr_desc with
| Expr_const _
| Expr_ident _ -> Utils.ISet.empty
| Expr_tuple el
@@ -944,7 +942,7 @@ and get_calls_expr_desc nodes expr_desc =
| 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', i') ->
- if Basic_library.is_internal_fun i then
+ if Basic_library.is_expr_internal_fun e then
(get_calls e')
else
let calls = Utils.ISet.add i (get_calls e') in
diff --git a/src/corelang.mli b/src/corelang.mli
index d4a1d568..e31c4c9d 100755
--- a/src/corelang.mli
+++ b/src/corelang.mli
@@ -29,6 +29,8 @@ 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 node_table : (ident, top_decl) Hashtbl.t
val print_node_table: Format.formatter -> unit -> unit
@@ -122,6 +124,7 @@ val eq_replace_rhs_var: (ident -> bool) -> (ident -> ident) -> eq -> eq
(** rename_prog f_node f_var f_const prog *)
val rename_prog: (ident -> ident) -> (ident -> ident) -> (ident -> ident) -> program -> program
+
val substitute_expr: var_decl list -> eq list -> expr -> expr
val copy_var_decl: var_decl -> var_decl
@@ -134,7 +137,7 @@ val copy_prog: top_decl list -> top_decl list
val mkeexpr: Location.t -> expr -> eexpr
val merge_node_annot: node_annot -> node_annot -> node_annot
val extend_eexpr: (quantifier_type * var_decl list) list -> eexpr -> eexpr
-val update_expr_annot: ident -> expr -> LustreSpec.expr_annot -> expr
+val update_expr_annot: ident -> expr -> expr_annot -> expr
(* val mkpredef_call: Location.t -> ident -> eexpr list -> eexpr*)
(* Local Variables: *)
diff --git a/src/dimension.ml b/src/dimension.ml
index 79d6f1f0..ec0b2f26 100644
--- a/src/dimension.ml
+++ b/src/dimension.ml
@@ -243,14 +243,7 @@ let rec eval eval_op eval_const dim =
end
| Dvar -> ()
| Dunivar -> assert false
-(*
-in
-begin
- Format.eprintf "Dimension.eval %a = " pp_dimension dim;
- eval eval_op eval_const dim;
- Format.eprintf "%a@." pp_dimension dim
-end
-*)
+
let uneval const univar =
let univar = repr univar in
match univar.dim_desc with
diff --git a/src/env.ml b/src/env.ml
index 31111bb5..9fc32db2 100755
--- a/src/env.ml
+++ b/src/env.ml
@@ -13,6 +13,7 @@
clock-calculus. *)
open Utils
+type 'a t = 'a IMap.t
(* Same namespace for nodes, variables and constants *)
let initial = IMap.empty
diff --git a/src/inliner.ml b/src/inliner.ml
index 1a2dd103..691e387a 100644
--- a/src/inliner.ml
+++ b/src/inliner.ml
@@ -64,6 +64,7 @@ We select the called node equations and variables.
the resulting expression is tuple_of_renamed_outputs
TODO: convert the specification/annotation/assert and inject them
+DONE: annotations
TODO: deal with reset
*)
let inline_call node orig_expr args reset locals caller =
@@ -136,10 +137,14 @@ in
})
node.node_asserts
in
+ let annots' =
+ Plugins.inline_annots rename node.node_annot
+ in
expr,
inputs'@outputs'@locals'@locals,
assign_inputs::eqs',
- asserts'
+ asserts',
+ annots'
@@ -156,27 +161,27 @@ 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) ->
- let e', locals', eqs', asserts' = inline_expr e locals node nodes in
- e'::el_tail, locals', eqs'@eqs, asserts@asserts'
- ) el ([], locals, [], [])
+ 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' = inline_tuple [e1;e2] in
+ let el', l', eqs', asserts', annots' = inline_tuple [e1;e2] in
match el' with
- | [e1'; e2'] -> e1', e2', l', eqs', asserts'
+ | [e1'; e2'] -> e1', e2', l', eqs', asserts', annots'
| _ -> assert false
in
let inline_triple e1 e2 e3 =
- let el', l', eqs', asserts' = inline_tuple [e1;e2;e3] in
+ let el', l', eqs', asserts', annots' = inline_tuple [e1;e2;e3] in
match el' with
- | [e1'; e2'; e3'] -> e1', e2', e3', l', eqs', asserts'
+ | [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' = inline_expr args locals node nodes in
+ 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,
@@ -188,68 +193,70 @@ let rec inline_expr ?(selection_on_annotation=false) expr locals node 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'' =
+ let expr, locals', eqs'', asserts'', annots'' =
inline_call called' expr args' reset locals' node in
- expr, locals', eqs'@eqs'', asserts'@asserts''
+ 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'
+ asserts',
+ annots'
(* For other cases, we just keep the structure, but convert sub-expressions *)
| Expr_const _
- | Expr_ident _ -> expr, locals, [], []
+ | Expr_ident _ -> expr, locals, [], [], []
| Expr_tuple el ->
- let el', l', eqs', asserts' = inline_tuple el in
- { expr with expr_desc = Expr_tuple el' }, l', eqs', asserts'
+ 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' = inline_triple g t e in
- { expr with expr_desc = Expr_ite (g', t', e') }, l', eqs', asserts'
+ 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' = inline_pair e1 e2 in
- { expr with expr_desc = Expr_arrow (e1', e2') } , l', eqs', asserts'
+ 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' = inline_pair e1 e2 in
- { expr with expr_desc = Expr_fby (e1', e2') }, l', eqs', asserts'
+ 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' = inline_tuple el in
- { expr with expr_desc = Expr_array el' }, l', eqs', asserts'
+ 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' = inline_expr e locals node nodes in
- { expr with expr_desc = Expr_access (e', dim) }, l', eqs', asserts'
+ 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' = inline_expr e locals node nodes in
- { expr with expr_desc = Expr_power (e', dim) }, l', eqs', asserts'
+ 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' = inline_expr e locals node nodes in
- { expr with expr_desc = Expr_pre e' }, l', eqs', asserts'
+ 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' = inline_expr e locals node nodes in
- { expr with expr_desc = Expr_when (e', id, label) }, l', eqs', asserts'
+ 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' = inline_tuple (List.map snd branches) in
+ 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'
+ { 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 new_locals, eqs, asserts =
- List.fold_left (fun (locals, eqs, asserts) eq ->
- let eq_rhs', locals', new_eqs', asserts' =
+ let new_locals, eqs, asserts, annots =
+ List.fold_left (fun (locals, eqs, asserts, annots) eq ->
+ let eq_rhs', locals', new_eqs', asserts', annots' =
inline_expr eq.eq_rhs locals node nodes
in
- locals', { eq with eq_rhs = eq_rhs' }::new_eqs'@eqs, asserts'@asserts
- ) (node.node_locals, [], node.node_asserts) (get_node_eqs node)
+ locals', { eq with eq_rhs = eq_rhs' }::new_eqs'@eqs, asserts'@asserts, annots'@annots
+ ) (node.node_locals, [], node.node_asserts, node.node_annot) (get_node_eqs node)
in
let inlined =
{ node with
node_locals = new_locals;
node_stmts = List.map (fun eq -> Eq eq) eqs;
node_asserts = asserts;
+ node_annot = annots;
}
in
begin
@@ -363,6 +370,11 @@ let witness filename main_name orig inlined type_env clock_env =
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.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
@@ -387,11 +399,16 @@ let global_inline basename prog type_env clock_env =
| _ -> 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
+ 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 local_inline basename prog type_env clock_env =
diff --git a/src/lexerLustreSpec.mll b/src/lexerLustreSpec.mll
index da4ca6ca..8a000223 100644
--- a/src/lexerLustreSpec.mll
+++ b/src/lexerLustreSpec.mll
@@ -44,7 +44,7 @@ let keyword_table =
"wcet", WCET;
"int", TINT;
"bool", TBOOL;
- "float", TFLOAT;
+ (* "float", TFLOAT; *)
"real", TREAL;
"clock", TCLOCK;
"not", NOT;
@@ -86,11 +86,13 @@ rule token = parse
token lexbuf }
| blank +
{token lexbuf}
- | '-'? ['0'-'9'] ['0'-'9']* '.' ['0'-'9']*
- {FLOAT (float_of_string (Lexing.lexeme lexbuf))}
+ | (('-'? ['0'-'9'] ['0'-'9']* as l) '.' (['0'-'9']* as r)) as s
+ {REAL (Num.num_of_string (l^r), String.length r, s)}
| '-'? ['0'-'9']+
{INT (int_of_string (Lexing.lexeme lexbuf)) }
- | '-'? ['0'-'9']+ '.' ['0'-'9']+ ('E'|'e') ('+'|'-') ['0'-'9'] ['0'-'9'] as s {REAL s}
+ | (('-'? ['0'-'9']+ as l) '.' (['0'-'9']+ as r) ('E'|'e') (('+'|'-') ['0'-'9'] ['0'-'9']* as exp)) as s
+ {REAL (Num.num_of_string (l^r), String.length r + -1 * int_of_string exp, s)}
+
(* | '/' (['_' 'A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '_' '0'-'9']* '/')+ as s
{IDENT s}
*)
diff --git a/src/lexer_lustre.mll b/src/lexer_lustre.mll
index 6fa09b53..5fbdb4d8 100755
--- a/src/lexer_lustre.mll
+++ b/src/lexer_lustre.mll
@@ -48,7 +48,7 @@ let keyword_table =
"type", TYPE;
"int", TINT;
"bool", TBOOL;
- "float", TFLOAT;
+ (* "float", TFLOAT; *)
"real", TREAL;
"clock", TCLOCK;
"not", NOT;
@@ -89,113 +89,115 @@ let newline = ('\010' | '\013' | "\013\010")
let notnewline = [^ '\010' '\013']
let blank = [' ' '\009' '\012']
-rule token = parse
-| "--@" { Buffer.clear buf;
- spec_singleline lexbuf }
-| "(*@" { Buffer.clear buf;
- spec_multiline 0 lexbuf }
-| "--!" { Buffer.clear buf;
- annot_singleline lexbuf }
-| "(*!" { Buffer.clear buf;
- annot_multiline 0 lexbuf }
-| "(*"
- { comment 0 lexbuf }
-| "--" [^ '!' '@'] notnewline* (newline|eof)
- { incr_line lexbuf;
- token lexbuf }
-| newline
- { incr_line lexbuf;
- token lexbuf }
-| blank +
- {token lexbuf}
-| ['0'-'9'] ['0'-'9']* '.' ['0'-'9']*
- {FLOAT (float_of_string (Lexing.lexeme lexbuf))}
-| ['0'-'9']+
- {INT (int_of_string (Lexing.lexeme lexbuf)) }
-| ['0'-'9']+ '.' ['0'-'9']+ ('E'|'e') ('+'|'-') ['0'-'9'] ['0'-'9']* as s {REAL s}
-| "tel." {TEL}
-| "tel;" {TEL}
-| "#open" { OPEN }
-| ['_' 'a'-'z'] [ '_' 'a'-'z' 'A'-'Z' '0'-'9']*
- {let s = Lexing.lexeme lexbuf in
- try
- Hashtbl.find keyword_table s
- with Not_found ->
- IDENT s}
-| ['A'-'Z'] [ '_' 'a'-'z' 'A'-'Z' '0'-'9']*
- {let s = Lexing.lexeme lexbuf in
- try
- Hashtbl.find keyword_table s
- with Not_found ->
- UIDENT s}
-| "->" {ARROW}
-| "=>" {IMPL}
-| "<=" {LTE}
-| ">=" {GTE}
-| "<>" {NEQ}
-| '<' {LT}
-| '>' {GT}
-| "!=" {NEQ}
-| '-' {MINUS}
-| '+' {PLUS}
-| '/' {DIV}
-| '*' {MULT}
-| '=' {EQ}
-| '(' {LPAR}
-| ')' {RPAR}
-| '[' {LBRACKET}
-| ']' {RBRACKET}
-| '{' {LCUR}
-| '}' {RCUR}
-| ';' {SCOL}
-| ':' {COL}
-| ',' {COMMA}
-| '=' {EQ}
-| '/' {DIV}
-| "&&" {AMPERAMPER}
-| "||" {BARBAR}
-| "::" {COLCOL}
-| "^" {POWER}
-| '"' {QUOTE}
-| eof { EOF }
-| _ { raise (Error (Location.curr lexbuf)) }
+ rule token = parse
+ | "--@" { Buffer.clear buf;
+ spec_singleline lexbuf }
+ | "(*@" { Buffer.clear buf;
+ spec_multiline 0 lexbuf }
+ | "--!" { Buffer.clear buf;
+ annot_singleline lexbuf }
+ | "(*!" { Buffer.clear buf;
+ annot_multiline 0 lexbuf }
+ | "(*"
+ { comment 0 lexbuf }
+ | "--" [^ '!' '@'] notnewline* (newline|eof)
+ { incr_line lexbuf;
+ token lexbuf }
+ | newline
+ { incr_line lexbuf;
+ token lexbuf }
+ | blank +
+ {token lexbuf}
+
+ | ((['0'-'9']+ as l) '.' (['0'-'9']* as r) ('E'|'e') (('+'|'-')? ['0'-'9']+ as exp)) as s
+ {REAL (Num.num_of_string (l^r), String.length r + -1 * int_of_string exp , s)}
+ | ((['0'-'9']+ as l) '.' (['0'-'9']* as r)) as s
+ {REAL (Num.num_of_string (l^r), String.length r, s)}
+ | ['0'-'9']+
+ {INT (int_of_string (Lexing.lexeme lexbuf)) }
+ | "tel." {TEL}
+ | "tel;" {TEL}
+ | "#open" { OPEN }
+ | ['_' 'a'-'z'] [ '_' 'a'-'z' 'A'-'Z' '0'-'9']*
+ {let s = Lexing.lexeme lexbuf in
+ try
+ Hashtbl.find keyword_table s
+ with Not_found ->
+ IDENT s}
+ | ['A'-'Z'] [ '_' 'a'-'z' 'A'-'Z' '0'-'9']*
+ {let s = Lexing.lexeme lexbuf in
+ try
+ Hashtbl.find keyword_table s
+ with Not_found ->
+ UIDENT s}
+ | "->" {ARROW}
+ | "=>" {IMPL}
+ | "<=" {LTE}
+ | ">=" {GTE}
+ | "<>" {NEQ}
+ | '<' {LT}
+ | '>' {GT}
+ | "!=" {NEQ}
+ | '-' {MINUS}
+ | '+' {PLUS}
+ | '/' {DIV}
+ | '*' {MULT}
+ | '=' {EQ}
+ | '(' {LPAR}
+ | ')' {RPAR}
+ | '[' {LBRACKET}
+ | ']' {RBRACKET}
+ | '{' {LCUR}
+ | '}' {RCUR}
+ | ';' {SCOL}
+ | ':' {COL}
+ | ',' {COMMA}
+ | '=' {EQ}
+ | '/' {DIV}
+ | "&&" {AMPERAMPER}
+ | "||" {BARBAR}
+ | "::" {COLCOL}
+ | "^" {POWER}
+ | '"' {QUOTE}
+ | eof { EOF }
+ | _ { raise (Error (Location.curr lexbuf)) }
and comment n = parse
-| eof
- { raise (Error (Location.curr lexbuf)) }
-| "(*"
- { comment (n+1) lexbuf }
-| "*)"
- { if n > 0 then comment (n-1) lexbuf else token lexbuf }
-| newline
- { incr_line lexbuf;
- comment n lexbuf }
-| _ { comment n lexbuf }
+ | eof
+ { raise (Error (Location.curr lexbuf)) }
+ | "(*"
+ { comment (n+1) lexbuf }
+ | "*)"
+ { if n > 0 then comment (n-1) lexbuf else token lexbuf }
+ | newline
+ { incr_line lexbuf;
+ comment n lexbuf }
+ | _ { comment n lexbuf }
and annot_singleline = parse
- | newline { incr_line lexbuf; make_annot lexbuf (Buffer.contents buf) }
- | _ as c { Buffer.add_char buf c; annot_singleline lexbuf }
+ | newline { incr_line lexbuf; make_annot lexbuf (Buffer.contents buf) }
+ | _ as c { Buffer.add_char buf c; annot_singleline lexbuf }
and annot_multiline n = parse
- | "*)" as s {
- if n > 0 then
- (Buffer.add_string buf s; annot_multiline (n-1) lexbuf)
- else
- make_annot lexbuf (Buffer.contents buf) }
- | "(*" as s { Buffer.add_string buf s; annot_multiline (n+1) lexbuf }
- | newline as s { incr_line lexbuf; Buffer.add_string buf s; annot_multiline n lexbuf }
- | _ as c { Buffer.add_char buf c; annot_multiline n lexbuf }
+ | "*)" as s {
+ if n > 0 then
+ (Buffer.add_string buf s; annot_multiline (n-1) lexbuf)
+ else
+ make_annot lexbuf (Buffer.contents buf) }
+ | "(*" as s { Buffer.add_string buf s; annot_multiline (n+1) lexbuf }
+ | newline as s { incr_line lexbuf; Buffer.add_string buf s; annot_multiline n lexbuf }
+ | _ as c { Buffer.add_char buf c; annot_multiline n lexbuf }
and spec_singleline = parse
- | newline { incr_line lexbuf; make_spec lexbuf (Buffer.contents buf) }
- | _ as c { Buffer.add_char buf c; spec_singleline lexbuf }
+ | newline { incr_line lexbuf; make_spec lexbuf (Buffer.contents buf) }
+ | _ as c { Buffer.add_char buf c; spec_singleline lexbuf }
and spec_multiline n = parse
- | "*)" as s { if n > 0 then
- (Buffer.add_string buf s; spec_multiline (n-1) lexbuf)
- else
- make_spec lexbuf (Buffer.contents buf) }
- | "(*" as s { Buffer.add_string buf s; spec_multiline (n+1) lexbuf }
- | newline as s { incr_line lexbuf; Buffer.add_string buf s; spec_multiline n lexbuf }
- | _ as c { Buffer.add_char buf c; spec_multiline n lexbuf }
+ | "*)" as s { if n > 0 then
+ (Buffer.add_string buf s; spec_multiline (n-1) lexbuf)
+ else
+ make_spec lexbuf (Buffer.contents buf) }
+ | "(*" as s { Buffer.add_string buf s; spec_multiline (n+1) lexbuf }
+ | newline as s { incr_line lexbuf; Buffer.add_string buf s; spec_multiline n lexbuf }
+ | _ as c { Buffer.add_char buf c; spec_multiline n lexbuf }
diff --git a/src/liveness.ml b/src/liveness.ml
index 21b716df..f754b4cc 100755
--- a/src/liveness.ml
+++ b/src/liveness.ml
@@ -115,7 +115,7 @@ let remove_roots ctx =
(* checks whether a variable is aliasable,
depending on its (address) type *)
let is_aliasable var =
- Types.is_address_type var.var_type
+ (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,
@@ -127,11 +127,7 @@ let is_aliasable_input node var =
| 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
-(*
- let res =
-is_aliasable v && List.mem v.var_id inputs_var
- in (Format.eprintf "aliasable %s by %s = %B@." var v.var_id res; res)
-*)
+
(* replace variable [v] by [v'] in graph [g].
[v'] is a dead variable
*)
@@ -207,10 +203,8 @@ let compute_reuse node ctx heads var =
let disjoint_live = Disjunction.CISet.inter disjoint live in
Log.report ~level:7 (fun fmt -> Format.fprintf fmt "disjoint live:%a@." Disjunction.pp_ciset disjoint_live);
let reuse = Disjunction.CISet.max_elt disjoint_live in
- (*let reuse' = Hashtbl.find ctx.policy reuse.var_id in*)
begin
IdentDepGraph.add_edge ctx.dep_graph var.var_id reuse.var_id;
- (*if reuse != reuse' then IdentDepGraph.add_edge ctx.dep_graph reuse.var_id reuse'.var_id;*)
Hashtbl.add ctx.policy var.var_id reuse;
ctx.evaluated <- Disjunction.CISet.add var ctx.evaluated;
(*Format.eprintf "%s reused by live@." var.var_id;*)
@@ -220,13 +214,11 @@ let compute_reuse node ctx heads var =
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 "dead:%a@." Disjunction.pp_ciset dead);
let reuse = Disjunction.CISet.choose dead in
- (*let reuse' = Hashtbl.find ctx.policy reuse.var_id in*)
begin
IdentDepGraph.add_edge ctx.dep_graph var.var_id reuse.var_id;
- (*if reuse != reuse' then IdentDepGraph.add_edge ctx.dep_graph reuse.var_id reuse'.var_id;*)
Hashtbl.add ctx.policy var.var_id reuse;
ctx.evaluated <- Disjunction.CISet.add var ctx.evaluated;
- (*Format.eprintf "%s reused by dead %a@." var.var_id Disjunction.pp_ciset dead;*)
+ (*Format.eprintf "%s reused by dead %s@." var.var_id reuse.var_id;*)
end
with Not_found ->
begin
diff --git a/src/lustreSpec.ml b/src/lustreSpec.ml
index 4202fe41..ae2524cd 100644
--- a/src/lustreSpec.ml
+++ b/src/lustreSpec.ml
@@ -24,7 +24,7 @@ and type_dec_desc =
| Tydec_any
| Tydec_int
| Tydec_real
- | Tydec_float
+ (* | Tydec_float *)
| Tydec_bool
| Tydec_clock of type_dec_desc
| Tydec_const of ident
@@ -50,8 +50,8 @@ and clock_dec_desc =
type constant =
| Const_int of int
- | Const_real of string
- | Const_float of float
+ | Const_real of Num.num * int * string (* (a,b, c) means a * 10^-b. c is the original string *)
+ (* | Const_float of float *)
| Const_array of constant list
| Const_tag of label
| Const_string of string (* used only for annotations *)
@@ -75,8 +75,6 @@ type var_decl =
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 =
@@ -188,7 +186,7 @@ type imported_node_desc =
nodei_stateless: bool;
nodei_spec: node_annot option;
nodei_prototype: string option;
- nodei_in_lib: string option;
+ nodei_in_lib: string list;
}
type const_desc =
@@ -220,6 +218,33 @@ type dep_t = Dep of
* (top_decl list)
* bool (* is stateful *)
+
+(************ Machine code types *************)
+
+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
+ | LocalVar of var_decl
+ | StateVar of var_decl
+ | Fun of ident * value_t list
+ | Array of value_t list
+ | Access of value_t * value_t
+ | Power of value_t * value_t
+
+type instr_t =
+ | MLocalAssign of var_decl * value_t
+ | MStateAssign of var_decl * value_t
+ | MReset of ident
+ | MStep of var_decl list * ident * value_t list
+ | MBranch of value_t * (label * instr_t list) list
+ | MComment of string
+
+
type error =
Main_not_found
| Main_wrong_kind
diff --git a/src/machine_code.ml b/src/machine_code.ml
index cd1fc9d7..e969e160 100644
--- a/src/machine_code.ml
+++ b/src/machine_code.ml
@@ -19,27 +19,13 @@ exception NormalizationError
module OrdVarDecl:Map.OrderedType with type t=var_decl =
struct type t = var_decl;; let compare = compare end
-module ISet = Set.Make(OrdVarDecl)
-type value_t =
- | Cst of constant
- | LocalVar of var_decl
- | StateVar of var_decl
- | Fun of ident * value_t list
- | Array of value_t list
- | Access of value_t * value_t
- | Power of value_t * value_t
-
-type instr_t =
- | MLocalAssign of var_decl * value_t
- | MStateAssign of var_decl * value_t
- | MReset of ident
- | MStep of var_decl list * ident * value_t list
- | MBranch of value_t * (label * instr_t list) list
+module ISet = Set.Make(OrdVarDecl)
+
let rec pp_val fmt v =
- match v with
- | Cst c -> Printers.pp_const fmt c
+ match v.value_desc with
+ | Cst c -> Printers.pp_const fmt c
| LocalVar v -> Format.pp_print_string fmt v.var_id
| StateVar v -> Format.pp_print_string fmt v.var_id
| Array vl -> Format.fprintf fmt "[%a]" (Utils.fprintf_list ~sep:", " pp_val) vl
@@ -48,19 +34,20 @@ let rec pp_val fmt v =
| Fun (n, vl) -> Format.fprintf fmt "%s (%a)" n (Utils.fprintf_list ~sep:", " pp_val) vl
let rec pp_instr fmt i =
- match i with
+ match i with
| MLocalAssign (i,v) -> Format.fprintf fmt "%s<-l- %a" i.var_id pp_val v
| MStateAssign (i,v) -> Format.fprintf fmt "%s<-s- %a" i.var_id pp_val v
| MReset i -> Format.fprintf fmt "reset %s" i
| MStep (il, i, vl) ->
Format.fprintf fmt "%a = %s (%a)"
(Utils.fprintf_list ~sep:", " (fun fmt v -> Format.pp_print_string fmt v.var_id)) il
- i
+ i
(Utils.fprintf_list ~sep:", " pp_val) vl
| MBranch (g,hl) ->
Format.fprintf fmt "@[<v 2>case(%a) {@,%a@,}@]"
pp_val g
(Utils.fprintf_list ~sep:"@," pp_branch) hl
+ | MComment s -> Format.pp_print_string fmt s
and pp_branch fmt (t, h) =
Format.fprintf fmt "@[<v 2>%s:@,%a@]" t (Utils.fprintf_list ~sep:"@," pp_instr) h
@@ -92,6 +79,7 @@ type machine_t = {
mannot: expr_annot list;
}
+let machine_vars m = m.mstep.step_inputs @ m.mstep.step_locals @ m.mstep.step_outputs @ m.mmemory
let pp_step fmt s =
Format.fprintf fmt "@[<v>inputs : %a@ outputs: %a@ locals : %a@ checks : %a@ instrs : @[%a@]@ asserts : @[%a@]@]@ "
(Utils.fprintf_list ~sep:", " Printers.pp_var) s.step_inputs
@@ -119,6 +107,12 @@ let pp_machine fmt m =
(fun fmt -> match m.mspec with | None -> () | Some spec -> Printers.pp_spec fmt spec)
(Utils.fprintf_list ~sep:"@ " Printers.pp_expr_annot) m.mannot
+let rec is_const_value v =
+ match v.value_desc with
+ | Cst _ -> true
+ | Fun (id, 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 m =
(m.mname.node_dec_stateless, Utils.desome m.mname.node_stateless)
@@ -177,18 +171,24 @@ let arrow_top_decl =
top_decl_loc = Location.dummy_loc
}
+let mk_val v t = { value_desc = v;
+ value_type = t;
+ value_annot = None }
+
let arrow_machine =
let state = "_first" in
let var_state = dummy_var_decl state (Types.new_ty Types.Tbool) in
let var_input1 = List.nth arrow_desc.node_inputs 0 in
let var_input2 = List.nth arrow_desc.node_inputs 1 in
let var_output = List.nth arrow_desc.node_outputs 0 in
+ let cst b = mk_val (Cst (const_of_bool b)) Type_predef.type_bool in
+ let t_arg = Types.new_univar () in (* TODO Xavier: c'est bien la bonne def ? *)
{
mname = arrow_desc;
mmemory = [var_state];
mcalls = [];
minstances = [];
- minit = [MStateAssign(var_state, Cst (const_of_bool true))];
+ minit = [MStateAssign(var_state, cst true)];
mconst = [];
mstatic = [];
mstep = {
@@ -196,10 +196,10 @@ let arrow_machine =
step_outputs = arrow_desc.node_outputs;
step_locals = [];
step_checks = [];
- step_instrs = [conditional (StateVar var_state)
- [MStateAssign(var_state, Cst (const_of_bool false));
- MLocalAssign(var_output, LocalVar var_input1)]
- [MLocalAssign(var_output, LocalVar var_input2)] ];
+ step_instrs = [conditional (mk_val (StateVar var_state) Type_predef.type_bool)
+ [MStateAssign(var_state, cst false);
+ MLocalAssign(var_output, mk_val (LocalVar var_input1) t_arg)]
+ [MLocalAssign(var_output, mk_val (LocalVar var_input2) t_arg)] ];
step_asserts = [];
};
mspec = None;
@@ -222,7 +222,6 @@ let new_instance =
o
end
-
(* translate_<foo> : node -> context -> <foo> -> machine code/expression *)
(* the context contains m : state aka memory variables *)
(* si : initialization instructions *)
@@ -233,15 +232,19 @@ let translate_ident node (m, si, j, d, s) id =
try (* id is a node var *)
let var_id = get_node_var id node in
if ISet.exists (fun v -> v.var_id = id) m
- then StateVar var_id
- else LocalVar var_id
+ then mk_val (StateVar var_id) var_id.var_type
+ else mk_val (LocalVar var_id) var_id.var_type
with Not_found ->
try (* id is a constant *)
- LocalVar (Corelang.var_decl_of_const (const_of_top (Hashtbl.find Corelang.consts_table id)))
+ let vdecl = (Corelang.var_decl_of_const (const_of_top (Hashtbl.find Corelang.consts_table id))) in
+ mk_val (LocalVar vdecl) vdecl.var_type
with Not_found ->
(* id is a tag *)
- Cst (Const_tag id)
-
+ (* TODO construire une liste des enum declarés et alors chercher dedans la liste
+ qui contient id *)
+ let cst = Const_tag id in
+ mk_val (Cst cst) (Typing.type_const Location.dummy_loc cst)
+
let rec control_on_clock node ((m, si, j, d, s) as args) ck inst =
match (Clocks.repr ck).cdesc with
| Con (ck1, cr, l) ->
@@ -272,7 +275,7 @@ let join_guards_list insts =
List.fold_right join_guards insts []
(* specialize predefined (polymorphic) operators
- wrt their instances, so that the C semantics
+ wrt their instances, so that the C semantics
is preserved *)
let specialize_to_c expr =
match expr.expr_desc with
@@ -292,36 +295,36 @@ let specialize_op expr =
| "C" -> specialize_to_c expr
| _ -> expr
-let rec translate_expr ?(ite=false) node ((m, si, j, d, s) as args) expr =
+let rec translate_expr node ((m, si, j, d, s) as args) expr =
let expr = specialize_op expr in
- match expr.expr_desc with
- | Expr_const v -> Cst v
- | Expr_ident x -> translate_ident node args x
- | Expr_array el -> Array (List.map (translate_expr node args) el)
- | Expr_access (t, i) -> Access (translate_expr node args t, translate_expr node args (expr_of_dimension i))
- | Expr_power (e, n) -> Power (translate_expr node args e, translate_expr node args (expr_of_dimension n))
- | Expr_tuple _
- | Expr_arrow _
- | Expr_fby _
- | Expr_pre _ -> (Printers.pp_expr Format.err_formatter expr; Format.pp_print_flush Format.err_formatter (); raise NormalizationError)
- | Expr_when (e1, _, _) -> translate_expr node args e1
- | Expr_merge (x, _) -> raise NormalizationError
- | Expr_appl (id, e, _) when Basic_library.is_internal_fun id ->
- let nd = node_from_name id in
- Fun (node_name nd, List.map (translate_expr node args) (expr_list_of_expr e))
- | Expr_ite (g,t,e) -> (
- (* special treatment depending on the active backend. For horn backend, ite
- are preserved in expression. While they are removed for C or Java
- backends. *)
- match !Options.output with
- | "horn" ->
- Fun ("ite", [translate_expr node args g; translate_expr node args t; translate_expr node args e])
- | ("C" | "java") when ite ->
- Fun ("ite", [translate_expr node args g; translate_expr node args t; translate_expr node args e])
- | _ ->
- (Format.eprintf "option:%s@." !Options.output; Printers.pp_expr Format.err_formatter expr; Format.pp_print_flush Format.err_formatter (); raise NormalizationError)
- )
- | _ -> raise NormalizationError
+ let value_desc =
+ match expr.expr_desc with
+ | Expr_const v -> Cst v
+ | Expr_ident x -> (translate_ident node args x).value_desc
+ | Expr_array el -> Array (List.map (translate_expr node args) el)
+ | Expr_access (t, i) -> Access (translate_expr node args t, translate_expr node args (expr_of_dimension i))
+ | Expr_power (e, n) -> Power (translate_expr node args e, translate_expr node args (expr_of_dimension n))
+ | Expr_tuple _
+ | Expr_arrow _
+ | Expr_fby _
+ | Expr_pre _ -> (Printers.pp_expr Format.err_formatter expr; Format.pp_print_flush Format.err_formatter (); raise NormalizationError)
+ | Expr_when (e1, _, _) -> (translate_expr node args e1).value_desc
+ | Expr_merge (x, _) -> raise NormalizationError
+ | 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 node args) (expr_list_of_expr e))
+ | Expr_ite (g,t,e) -> (
+ (* special treatment depending on the active backend. For horn backend, ite
+ are preserved in expression. While they are removed for C or Java
+ backends. *)
+ match !Options.output with | "horn" ->
+ Fun ("ite", [translate_expr node args g; translate_expr node args t; translate_expr node args e])
+ | "C" | "java" | _ ->
+ (Printers.pp_expr Format.err_formatter expr; Format.pp_print_flush Format.err_formatter (); raise NormalizationError)
+ )
+ | _ -> raise NormalizationError
+ in
+ mk_val value_desc expr.expr_type
let translate_guard node args expr =
match expr.expr_desc with
@@ -334,8 +337,7 @@ let rec translate_act node ((m, si, j, d, s) as args) (y, expr) =
conditional g [translate_act node args (y, t)]
[translate_act node args (y, e)]
| Expr_merge (x, hl) -> MBranch (translate_ident node args x, List.map (fun (t, h) -> t, [translate_act node args (y, h)]) hl)
- | _ ->
- MLocalAssign (y, translate_expr node args expr)
+ | _ -> MLocalAssign (y, translate_expr node args expr)
let reset_instance node args i r c =
match r with
@@ -344,7 +346,7 @@ let reset_instance node args i r c =
[control_on_clock node args c (conditional g [MReset i] [])]
let translate_eq node ((m, si, j, d, s) as args) eq =
- (* 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) ->
let var_x = get_node_var x node in
@@ -371,14 +373,14 @@ let translate_eq node ((m, si, j, d, s) as args) eq =
d,
control_on_clock node args eq.eq_rhs.expr_clock (MStateAssign (var_x, translate_expr node args e2)) :: s)
- | p , Expr_appl (f, arg, r) when not (Basic_library.is_internal_fun f) ->
+ | p , Expr_appl (f, arg, r) when not (Basic_library.is_expr_internal_fun eq.eq_rhs) ->
let var_p = List.map (fun v -> get_node_var v node) p in
let el = expr_list_of_expr arg in
let vl = List.map (translate_expr node args) el in
let node_f = node_from_name f in
let call_f =
node_f,
- NodeDep.filter_static_inputs (node_inputs node_f) el in
+ NodeDep.filter_static_inputs (node_inputs node_f) el in
let o = new_instance node 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
@@ -397,22 +399,22 @@ let translate_eq node ((m, si, j, d, s) as args) eq =
(* special treatment depending on the active backend. For horn backend, x = ite (g,t,e)
are preserved. While they are replaced as if g then x = t else x = e in C or Java
backends. *)
- | [x], Expr_ite (c, t, e)
+ | [x], Expr_ite (c, t, e)
when (match !Options.output with | "horn" -> true | "C" | "java" | _ -> false)
- ->
+ ->
let var_x = get_node_var x node in
- (m,
- si,
- j,
- d,
- (control_on_clock node args eq.eq_rhs.expr_clock
+ (m,
+ si,
+ j,
+ d,
+ (control_on_clock node args eq.eq_rhs.expr_clock
(MLocalAssign (var_x, translate_expr node args eq.eq_rhs))::s)
)
-
+
| [x], _ -> (
let var_x = get_node_var x node in
- (m, si, j, d,
- control_on_clock
+ (m, si, j, d,
+ control_on_clock
node
args
eq.eq_rhs.expr_clock
@@ -421,7 +423,7 @@ let translate_eq node ((m, si, j, d, s) as args) eq =
)
| _ ->
begin
- Format.eprintf "unsupported equation: %a@?" Printers.pp_node_eq eq;
+ Format.eprintf "internal error: Machine_code.translate_eq %a@?" Printers.pp_node_eq eq;
assert false
end
@@ -436,22 +438,30 @@ let find_eq xl 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
+ if List.exists (fun x -> List.mem x hd.eq_lhs) xl then
+ hd, accu@tl
+ else
+ aux (hd::accu) tl
in
aux [] eqs
-(* Sort the set of equations of node [nd] according
+(* Sort the set of equations of node [nd] according
to the computed schedule [sch]
*)
let sort_equations_from_schedule nd sch =
-(*Format.eprintf "%s schedule: %a@."
- nd.node_id
- (Utils.fprintf_list ~sep:" ; " Scheduling.pp_eq_schedule) sch;*)
+ (* Format.eprintf "%s schedule: %a@." *)
+ (* nd.node_id *)
+ (* (Utils.fprintf_list ~sep:" ; " Scheduling.pp_eq_schedule) sch; *)
let split_eqs = Splitting.tuple_split_eq_list (get_node_eqs nd) in
let eqs_rev, remainder =
List.fold_left
(fun (accu, node_eqs_remainder) vl ->
- if List.exists (fun eq -> List.exists (fun v -> List.mem v eq.eq_lhs) vl) accu
+ if List.exists
+ (fun eq -> (* This could be also evaluated with a forall.
+ But, by construction, each vl should be
+ associated to a single equation *)
+ List.exists (fun v -> List.mem v eq.eq_lhs) vl)
+ accu
then
(accu, node_eqs_remainder)
else
@@ -467,7 +477,10 @@ let sort_equations_from_schedule nd sch =
Printers.pp_node_eqs remainder
Printers.pp_node_eqs (get_node_eqs nd);
assert false);
- List.rev eqs_rev
+ let res = List.rev eqs_rev in
+ (* (\* Debug code, to be removed *\) *)
+ (* List.iteri (fun cpt eq -> Format.eprintf "Eq %i: %a@." cpt (Utils.fprintf_list ~sep:", " Format.pp_print_string) eq.eq_lhs) res; *)
+ res
end
let constant_equations nd =
@@ -519,7 +532,7 @@ let translate_decl nd sch =
| "horn" -> s
| "C" | "java" | _ -> join_guards_list s
);
- step_asserts =
+ step_asserts =
let exprl = List.map (fun assert_ -> assert_.assert_expr ) nd.node_asserts in
List.map (translate_expr nd init_args) exprl
;
@@ -530,19 +543,19 @@ let translate_decl nd sch =
(** takes the global declarations and the scheduling associated to each node *)
let translate_prog decls node_schs =
- let nodes = get_nodes decls in
- List.map
- (fun decl ->
+ let nodes = get_nodes decls in
+ List.map
+ (fun decl ->
let node = node_of_top decl in
let sch = (Utils.IMap.find node.node_id node_schs).Scheduling.schedule in
- translate_decl node sch
+ translate_decl node sch
) nodes
-let get_machine_opt name machines =
- List.fold_left
- (fun res m ->
- match res with
- | Some _ -> res
+let get_machine_opt name machines =
+ List.fold_left
+ (fun res m ->
+ match res with
+ | Some _ -> res
| None -> if m.mname.node_id = name then Some m else None)
None machines
@@ -557,29 +570,35 @@ let get_const_assign m id =
let value_of_ident m id =
(* is is a state var *)
try
- StateVar (List.find (fun v -> v.var_id = id) m.mmemory)
+ let mem = List.find (fun v -> v.var_id = id) m.mmemory in
+ mk_val (StateVar mem) mem.var_type
with Not_found ->
try (* id is a node var *)
- LocalVar (get_node_var id m.mname)
+ let var = get_node_var id m.mname in
+ mk_val (LocalVar var) var.var_type
with Not_found ->
try (* id is a constant *)
- LocalVar (Corelang.var_decl_of_const (const_of_top (Hashtbl.find Corelang.consts_table id)))
+ let cst = Corelang.var_decl_of_const (const_of_top (Hashtbl.find Corelang.consts_table id)) in
+ mk_val (LocalVar cst) cst.var_type
with Not_found ->
(* id is a tag *)
- Cst (Const_tag id)
+ let tag = Const_tag id in
+ mk_val (Cst tag) (Typing.type_const Location.dummy_loc tag)
let rec value_of_dimension m dim =
match dim.Dimension.dim_desc with
- | Dimension.Dbool b -> Cst (Const_tag (if b then Corelang.tag_true else Corelang.tag_false))
- | Dimension.Dint i -> Cst (Const_int i)
+ | Dimension.Dbool b -> mk_val (Cst (Const_tag (if b then Corelang.tag_true else Corelang.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 m v
- | Dimension.Dappl (f, args) -> Fun (f, List.map (value_of_dimension m) args)
- | Dimension.Dite (i, t, e) -> Fun ("ite", List.map (value_of_dimension m) [i; t; e])
+ | Dimension.Dappl (f, args) -> let typ = if Basic_library.is_numeric_operator f then Type_predef.type_int else Type_predef.type_bool
+ in mk_val (Fun (f, List.map (value_of_dimension m) args)) typ
+ | Dimension.Dite (i, t, e) -> let [vi; vt; ve] = List.map (value_of_dimension m) [i; t; e] in
+ mk_val (Fun ("ite", [vi; vt; ve])) vt.value_type
| Dimension.Dlink dim' -> value_of_dimension m dim'
| _ -> assert false
let rec dimension_of_value value =
- match value with
+ match value.value_desc with
| Cst (Const_tag t) when t = Corelang.tag_true -> Dimension.mkdim_bool Location.dummy_loc true
| Cst (Const_tag t) when t = Corelang.tag_false -> Dimension.mkdim_bool Location.dummy_loc false
| Cst (Const_int i) -> Dimension.mkdim_int Location.dummy_loc i
diff --git a/src/main_lustre_compiler.ml b/src/main_lustre_compiler.ml
index 5e84c33e..5bc03a73 100644
--- a/src/main_lustre_compiler.ml
+++ b/src/main_lustre_compiler.ml
@@ -1,371 +1,465 @@
-(********************************************************************)
-(* *)
-(* 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 Format
-open Log
-
-open Utils
-open LustreSpec
-open Compiler_common
-
-let usage = "Usage: lustrec [options] <source-file>"
-
-let extensions = [".ec"; ".lus"; ".lusi"]
-
-(* print a .lusi header file from a source prog *)
-let print_lusi prog dirname basename extension =
- let header = Lusic.extract_header dirname basename prog in
- 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
-
-(* compile a .lusi header file *)
-let compile_header dirname basename extension =
- let destname = !Options.dest_dir ^ "/" ^ basename in
- let header_name = basename ^ extension in
- let lusic_ext = extension ^ "c" in
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v>");
- let header = parse_header true (dirname ^ "/" ^ header_name) in
- ignore (Modules.load_header ISet.empty header);
- ignore (check_top_decls header);
- create_dest_dir ();
- Log.report ~level:1
- (fun fmt -> fprintf fmt ".. generating compiled header file %sc@," (destname ^ extension));
- Lusic.write_lusic true header destname lusic_ext;
- Lusic.print_lusic_to_h destname lusic_ext;
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.")
- end
-
-(* 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 destname = !Options.dest_dir ^ "/" ^ basename in
- let lusic_ext = extension ^ "c" in
- let header_name = destname ^ lusic_ext in
- begin
- if not (Sys.file_exists header_name) then
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating compiled header file %s@," header_name);
- Lusic.write_lusic false (Lusic.extract_header dirname basename prog) destname lusic_ext;
- Lusic.print_lusic_to_h destname lusic_ext
- end
- else
- let lusic = Lusic.read_lusic destname lusic_ext in
- if 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 false (Lusic.extract_header dirname basename prog) destname lusic_ext;
- (*List.iter (fun top_decl -> Format.eprintf "lusic: %a@." Printers.pp_decl top_decl) lusic.Lusic.contents;*)
- Lusic.print_lusic_to_h destname lusic_ext
- end
- else
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. loading compiled header file %s@," header_name);
- Modules.check_dependency lusic destname;
- let header = lusic.Lusic.contents in
- let (declared_types_env, declared_clocks_env) = 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
-
-
-
-(* compile a .lus source file *)
-let rec compile_source dirname basename extension =
-
- Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v>");
-
- (* Parsing source *)
- let prog = parse_source (dirname ^ "/" ^ basename ^ extension) in
-
- (* Removing automata *)
- let prog = Automata.expand_decls prog in
-
- (* Importing source *)
- let _ = Modules.load_program ISet.empty prog in
-
- (* Extracting dependencies *)
- let dependencies, type_env, clock_env = import_dependencies prog in
-
- (* Sorting nodes *)
- let prog = SortProg.sort prog in
-
- (* Perform inlining before any analysis *)
- let orig, prog =
- if !Options.global_inline && !Options.main_node <> "" then
- (if !Options.witnesses then prog else []),
- Inliner.global_inline basename prog type_env clock_env
- else (* if !Option.has_local_inline *)
- [],
- Inliner.local_inline basename prog type_env clock_env
- in
-
- (* Checking stateless/stateful status *)
- check_stateless_decls prog;
-
- (* Typing *)
- let computed_types_env = type_decls type_env prog in
-
- (* Clock calculus *)
- let computed_clocks_env = clock_decls clock_env prog in
-
- (* Generating a .lusi header file only *)
- if !Options.lusi then
- begin
- let lusi_ext = extension ^ "i" in
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating interface file %s@," (dirname ^ "/" ^ basename ^ lusi_ext));
- print_lusi prog dirname basename lusi_ext;
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");
- exit 0
- end;
-
- (* 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;
- *)
-
- (* Creating destination directory if needed *)
- create_dest_dir ();
-
- (* Compatibility with Lusi *)
- (* Checking the existence of a lusi (Lustre Interface file) *)
- (match !Options.output with
- "C" ->
- begin
- let extension = ".lusi" in
- compile_source_to_header prog computed_types_env computed_clocks_env dirname basename extension;
- end
- |_ -> ());
-
- Typing.uneval_prog_generics prog;
- Clock_calculus.uneval_prog_generics prog;
-
- 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;
-
-(*Format.eprintf "Inliner.global_inline<<@.%a@.>>@." Printers.pp_prog prog;*)
- (* 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;*)
-
- (* Normalization phase *)
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. normalization@,");
- (* Special treatment of arrows in lustre backend. We want to keep them *)
- if !Options.output = "lustre" then
- Normalization.unfold_arrow_active := false;
- let prog = Normalization.normalize_prog prog in
-
- Log.report ~level:2 (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 ".. array access checks@,");
- Access.check_prog prog;
- end;
-
- (* 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 ".. scheduling@,");
- let prog, node_schs = Scheduling.schedule_prog prog in
- Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_warning_unused node_schs);
- Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_schedule node_schs);
- Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_fanin_table node_schs);
- Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Printers.pp_prog prog);
-
- (* Optimization of prog:
- - Unfold consts
- - eliminate trivial expressions
- *)
- let prog =
- if !Options.optimization >= 5 then
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. constants elimination@,");
- Optimize_prog.prog_unfold_consts prog
- end
- else
- prog
- in
- (* DFS with modular code generation *)
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@,");
- let machine_code = Machine_code.translate_prog prog node_schs in
-
- Log.report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,"
- (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
- machine_code);
-
- (* Optimize machine code *)
- let machine_code =
- if !Options.optimization >= 4 && !Options.output <> "horn" then
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines optimization (phase 3)@,");
- Optimize_machine.machines_cse machine_code
- end
- else
- machine_code
- in
-
- (* Optimize machine code *)
- let machine_code =
- if !Options.optimization >= 2 && !Options.output <> "horn" then
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines optimization (phase 1)@,");
- Optimize_machine.machines_unfold (Corelang.get_consts prog) node_schs machine_code
- end
- else
- machine_code
- in
- (* Optimize machine code *)
- let machine_code =
- if !Options.optimization >= 3 && !Options.output <> "horn" then
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines optimization (phase 2)@,");
- Optimize_machine.machines_fusion (Optimize_machine.machines_reuse_variables machine_code node_schs)
- end
- else
- machine_code
- in
-
- if !Options.optimization >= 2 then
- begin
- Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,"
- (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
- machine_code);
- end;
-
- (* Printing code *)
- let basename = Filename.basename basename in
- let destname = !Options.dest_dir ^ "/" ^ basename in
- let _ = match !Options.output with
- | "C" ->
- begin
- let alloc_header_file = destname ^ "_alloc.h" in (* Could be changed *)
- let source_lib_file = destname ^ ".c" in (* Could be changed *)
- let source_main_file = destname ^ "_main.c" in (* Could be changed *)
- let makefile_file = destname ^ ".makefile" in (* Could be changed *)
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,");
- C_backend.translate_to_c
- alloc_header_file source_lib_file source_main_file makefile_file
- basename prog machine_code dependencies
- end
- | "java" ->
- begin
- failwith "Sorry, but not yet supported !"
- (*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
- | "horn" ->
- begin
- 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 basename prog 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_file fmt basename prog machine_code;
- )
- end
- | "lustre" ->
- begin
- let source_file = destname ^ ".lustrec.lus" in (* Could be changed *)
- let source_out = open_out source_file in
- let fmt = formatter_of_out_channel source_out in
- Printers.pp_prog fmt prog;
-(* Lustre_backend.translate fmt basename normalized_prog machine_code *)
- ()
- end
-
- | _ -> assert false
- in
- begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. done @ @]@.");
- (* We stop the process here *)
- exit 0
- end
-
-let compile dirname basename extension =
- match extension with
- | ".lusi" -> compile_header dirname basename extension
- | ".lus" -> compile_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
- if ok_ext then
- let dirname = Filename.dirname filename in
- let basename = Filename.chop_suffix (Filename.basename filename) ext in
- compile dirname basename ext
- else
- raise (Arg.Bad ("Can only compile *.lusi, *.lus or *.ec files"))
-
-let _ =
- Corelang.add_internal_funs ();
- try
- Printexc.record_backtrace true;
- Arg.parse Options.options anonymous usage
- with
- | Parse.Syntax_err _ | Lexer_lustre.Error _
- | Types.Error (_,_) | Clocks.Error (_,_)
- | Corelang.Error _ (*| Task_set.Error _*)
- | Causality.Cycle _ -> exit 1
- | Sys_error msg -> (eprintf "Failure: %s@." msg)
- | exc -> (Utils.track_exception (); raise exc)
-
-(* 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 Format
+open Log
+
+open Utils
+open LustreSpec
+open Compiler_common
+
+exception StopPhase1 of program
+
+let usage = "Usage: lustrec [options] \x1b[4msource file\x1b[0m"
+
+let extensions = [".ec"; ".lus"; ".lusi"]
+
+(* print a .lusi header file from a source prog *)
+let print_lusi prog dirname basename extension =
+ let header = Lusic.extract_header dirname basename prog in
+ 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
+
+(* compile a .lusi header file *)
+let compile_header dirname basename extension =
+ let destname = !Options.dest_dir ^ "/" ^ basename in
+ let header_name = basename ^ extension in
+ let lusic_ext = extension ^ "c" in
+ begin
+ Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v>");
+ let header = parse_header true (dirname ^ "/" ^ header_name) in
+ ignore (Modules.load_header ISet.empty header);
+ ignore (check_top_decls header);
+ create_dest_dir ();
+ Log.report ~level:1
+ (fun fmt -> fprintf fmt ".. generating compiled header file %sc@," (destname ^ extension));
+ Lusic.write_lusic true header destname lusic_ext;
+ Lusic.print_lusic_to_h destname lusic_ext;
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.")
+ end
+
+(* 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 destname = !Options.dest_dir ^ "/" ^ basename in
+ let lusic_ext = extension ^ "c" in
+ let header_name = destname ^ lusic_ext in
+ begin
+ if not (Sys.file_exists header_name) then
+ begin
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating compiled header file %s@," header_name);
+ Lusic.write_lusic false (Lusic.extract_header dirname basename prog) destname lusic_ext;
+ Lusic.print_lusic_to_h destname lusic_ext
+ end
+ else
+ let lusic = Lusic.read_lusic destname lusic_ext in
+ if 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 false (Lusic.extract_header dirname basename prog) destname lusic_ext;
+(*List.iter (fun top_decl -> Format.eprintf "lusic: %a@." Printers.pp_decl top_decl) lusic.Lusic.contents;*)
+ Lusic.print_lusic_to_h destname lusic_ext
+ end
+ else
+ begin
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. loading compiled header file %s@," header_name);
+ Modules.check_dependency lusic destname;
+ let header = lusic.Lusic.contents in
+ let (declared_types_env, declared_clocks_env) = 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
+
+(* From prog to prog *)
+let stage1 prog dirname basename =
+ (* Removing automata *)
+ let prog = Automata.expand_decls prog in
+
+ (* Importing source *)
+ let _ = Modules.load_program ISet.empty prog in
+
+ (* Extracting dependencies *)
+ let dependencies, type_env, clock_env = import_dependencies prog in
+
+ (* Sorting nodes *)
+ let prog = SortProg.sort prog in
+
+ (* Perform inlining before any analysis *)
+ let orig, prog =
+ if !Options.global_inline && !Options.main_node <> "" then
+ (if !Options.witnesses then prog else []),
+ Inliner.global_inline basename prog type_env clock_env
+ else (* if !Option.has_local_inline *)
+ [],
+ Inliner.local_inline basename prog type_env clock_env
+ in
+
+ (* Checking stateless/stateful status *)
+ if Scopes.Plugin.is_active () then
+ force_stateful_decls prog
+ else
+ check_stateless_decls prog;
+
+ (* Typing *)
+ let computed_types_env = type_decls type_env prog in
+
+ (* Clock calculus *)
+ let computed_clocks_env = clock_decls clock_env prog in
+
+ (* Generating a .lusi header file only *)
+ if !Options.lusi then
+ (* We stop here the processing and produce the current prog. It will be
+ exported as a lusi *)
+ raise (StopPhase1 prog);
+
+ (* 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;
+ *)
+
+ (* Creating destination directory if needed *)
+ create_dest_dir ();
+
+ (* Compatibility with Lusi *)
+ (* Checking the existence of a lusi (Lustre Interface file) *)
+ let extension = ".lusi" in
+ compile_source_to_header prog computed_types_env computed_clocks_env dirname basename extension;
+
+ Typing.uneval_prog_generics prog;
+ Clock_calculus.uneval_prog_generics prog;
+
+ 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;*)
+
+ (* Optimization of prog:
+ - Unfold consts
+ - eliminate trivial expressions
+ *)
+ let prog =
+ if !Options.const_unfold || !Options.optimization >= 4 then
+ Optimize_prog.prog_unfold_consts prog
+ else
+ prog
+ in
+
+ (* Normalization phase *)
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. normalization@,");
+ (* Special treatment of arrows in lustre backend. We want to keep them *)
+ if !Options.output = "lustre" then
+ Normalization.unfold_arrow_active := false;
+ let prog = Normalization.normalize_prog prog in
+ Log.report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Printers.pp_prog prog);
+
+ 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 FP numbers@,");
+ prog
+ end in
+ Log.report ~level:2 (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 ".. array access checks@,");
+ Access.check_prog prog;
+ end;
+
+ prog, dependencies
+
+(* prog -> machine *)
+
+let stage2 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 ".. scheduling@,");
+ let prog, node_schs = Scheduling.schedule_prog prog in
+ Log.report ~level:1 (fun fmt -> fprintf fmt "%a" Scheduling.pp_warning_unused node_schs);
+ Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_schedule node_schs);
+ Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_fanin_table node_schs);
+ Log.report ~level:5 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_dep_graph node_schs);
+ Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Printers.pp_prog prog);
+
+
+ (* 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
+ *)
+ (* let prog = *)
+ (* if true then *)
+ (* Salsa.Prog.normalize prog *)
+ (* else *)
+ (* prog *)
+ (* in *)
+
+ (* DFS with modular code generation *)
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@ ");
+ let machine_code = Machine_code.translate_prog prog node_schs in
+
+ (* Optimize machine code *)
+ let machine_code, removed_table =
+ if !Options.optimization >= 2 && !Options.output <> "horn" then
+ begin
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines optimization (phase 1)@ ");
+ Optimize_machine.machines_unfold (Corelang.get_consts prog) node_schs machine_code
+ end
+ else
+ machine_code, IMap.empty
+ in
+ (* Optimize machine code *)
+ let machine_code =
+ if !Options.optimization >= 3 && !Options.output <> "horn" then
+ begin
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines optimization (phase 2)@ ");
+ let node_schs = Scheduling.remove_prog_inlined_locals removed_table node_schs in
+ let reuse_tables = Scheduling.compute_prog_reuse_table node_schs in
+ Optimize_machine.machines_fusion (Optimize_machine.machines_reuse_variables machine_code reuse_tables)
+ end
+ else
+ machine_code
+ in
+
+ (* Salsa optimize machine code *)
+ let machine_code =
+ if !Options.salsa_enabled then
+ begin
+ check_main ();
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. salsa machines optimization (phase 3)@ ");
+ (* Selecting float constants for Salsa *)
+ let constEnv = List.fold_left (
+ fun accu c_topdecl ->
+ match c_topdecl.top_decl_desc with
+ | Const c when Types.is_real_type c.const_type ->
+ (c.const_id, c.const_value) :: accu
+ | _ -> accu
+ ) [] (Corelang.get_consts prog)
+ in
+ List.map
+ (Machine_salsa_opt.machine_t2machine_t_optimized_by_salsa constEnv)
+ machine_code
+ end
+ else
+ machine_code
+ in
+ Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@ "
+ (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
+ machine_code);
+
+ machine_code
+
+
+let stage3 prog machine_code dependencies basename =
+ (* Printing code *)
+ let basename = Filename.basename basename in
+ let destname = !Options.dest_dir ^ "/" ^ basename in
+ match !Options.output with
+ "C" ->
+ begin
+ let alloc_header_file = destname ^ "_alloc.h" in (* Could be changed *)
+ let source_lib_file = destname ^ ".c" in (* Could be changed *)
+ let source_main_file = destname ^ "_main.c" in (* Could be changed *)
+ let makefile_file = destname ^ ".makefile" in (* Could be changed *)
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,");
+ C_backend.translate_to_c
+ alloc_header_file source_lib_file source_main_file makefile_file
+ basename prog machine_code dependencies
+ end
+ | "java" ->
+ begin
+ failwith "Sorry, but not yet supported !"
+ (*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
+ | "horn" ->
+ begin
+ 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 basename prog machine_code;
+ (* Tracability file if option is activated *)
+ if !Options.horntraces then (
+ let traces_file = destname ^ ".traces" 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_file fmt basename prog machine_code;
+ )
+ end
+ | "lustre" ->
+ begin
+ let source_file = destname ^ ".lustrec.lus" in (* Could be changed *)
+ let source_out = open_out source_file in
+ let fmt = formatter_of_out_channel source_out in
+ Printers.pp_prog fmt prog;
+(* Lustre_backend.translate fmt basename normalized_prog machine_code *)
+ ()
+ end
+
+ | _ -> assert false
+
+(* compile a .lus source file *)
+let compile_source dirname basename extension =
+
+ Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v>");
+
+ (* Parsing source *)
+ let prog = parse_source (dirname ^ "/" ^ basename ^ extension) in
+
+ let prog =
+ if !Options.mpfr then
+ Mpfr.mpfr_module::prog
+ else
+ prog
+ in
+ let prog, dependencies =
+ try
+ stage1 prog dirname basename
+ with StopPhase1 prog -> (
+ if !Options.lusi then
+ begin
+ let lusi_ext = "lusi" (* extension ^ "i" *) in
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating interface file %s@," (dirname ^ "/" ^ basename ^ lusi_ext));
+ print_lusi prog dirname basename lusi_ext;
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");
+ exit 0
+ end
+ else
+ assert false
+ )
+ in
+
+ let machine_code =
+ stage2 prog
+ in
+ 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;
+
+ let machine_code =
+ if Scopes.Plugin.is_active () then
+ Scopes.Plugin.process_scopes !Options.main_node prog machine_code
+ else
+ machine_code
+ in
+
+ stage3 prog machine_code dependencies basename;
+ begin
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");
+ (* We stop the process here *)
+ exit 0
+ end
+
+let compile dirname basename extension =
+ match extension with
+ | ".lusi" -> compile_header dirname basename extension
+ | ".lus" -> compile_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
+ if ok_ext then
+ let dirname = Filename.dirname filename in
+ let basename = Filename.chop_suffix (Filename.basename filename) ext in
+ compile dirname basename ext
+ else
+ raise (Arg.Bad ("Can only compile *.lusi, *.lus or *.ec files"))
+
+let _ =
+ Global.initialize ();
+ Corelang.add_internal_funs ();
+ try
+ Printexc.record_backtrace true;
+
+ let options = Options.options @
+ List.flatten (
+ List.map Options.plugin_opt [
+ Scopes.Plugin.name, Scopes.Plugin.activate, Scopes.Plugin.options
+ ]
+ )
+ in
+
+ Arg.parse options anonymous usage
+ with
+ | Parse.Syntax_err _ | Lexer_lustre.Error _
+ | Types.Error (_,_) | Clocks.Error (_,_)
+ | Corelang.Error _ (*| Task_set.Error _*)
+ | Causality.Cycle _ -> exit 1
+ | Sys_error msg -> (eprintf "Failure: %s@." msg)
+ | exc -> (Utils.track_exception (); raise exc)
+
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
diff --git a/src/normalization.ml b/src/normalization.ml
index 30e4066f..ea8027fb 100644
--- a/src/normalization.ml
+++ b/src/normalization.ml
@@ -95,15 +95,12 @@ let replace_expr locals expr =
let unfold_offsets e offsets =
let add_offset e d =
-(*Format.eprintf "add_offset %a(%a) %a @." Printers.pp_expr e Types.print_ty e.expr_type Dimension.pp_dimension d;
- let res = *)
+(*Format.eprintf "add_offset %a %a@." Dimension.pp_dimension (Types.array_type_dimension e.expr_type) Dimension.pp_dimension d;*)
{ 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) }
-(*in (Format.eprintf "= %a @." Printers.pp_expr res; res) *)
- in
+ expr_desc = Expr_access (e, d) } in
List.fold_left add_offset e offsets
(* Create an alias for [expr], if none exists yet *)
@@ -121,22 +118,33 @@ let mk_expr_alias node (defs, vars) expr =
(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
- (* 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
+ in (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 *)
-let mk_expr_alias_opt opt node defvars expr =
+let mk_expr_alias_opt opt node (defs, vars) expr =
+(*Format.eprintf "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 alias ->
- defvars, expr
+ (defs, vars), expr
| _ ->
- if opt
- then
- mk_expr_alias node defvars expr
- else
- defvars, expr
+ match get_expr_alias defs expr with
+ | Some eq ->
+ 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 ->
+ if opt
+ then
+ let new_aliases =
+ List.map2
+ (mk_fresh_var node 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 (new_def::defs, new_aliases@vars), replace_expr new_aliases expr
+ else
+ (defs, vars), expr
(* Create a (normalized) expression from [ref_e],
replacing description with [norm_d],
@@ -159,7 +167,7 @@ let rec normalize_list alias node offsets norm_element defvars elist =
) elist (defvars, [])
let rec normalize_expr ?(alias=true) node offsets defvars expr =
-(* Format.eprintf "normalize %B %a [%a]@." alias Printers.pp_expr expr (Utils.fprintf_list ~sep:"," Dimension.pp_dimension) offsets;*)
+(*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 _ -> defvars, unfold_offsets expr offsets
@@ -179,8 +187,8 @@ let rec normalize_expr ?(alias=true) node offsets defvars expr =
let defvars, norm_elist =
normalize_list alias node offsets (fun alias -> normalize_expr ~alias:alias) defvars elist in
defvars, mk_norm_expr offsets expr (Expr_tuple norm_elist)
- | Expr_appl (id, args, None)
- when Basic_library.is_internal_fun id
+ | 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
@@ -192,7 +200,7 @@ let rec normalize_expr ?(alias=true) node offsets defvars expr =
(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_internal_fun id ->
+ | Expr_appl (id, args, None) when Basic_library.is_expr_internal_fun expr ->
let defvars, norm_args = normalize_expr ~alias:true node offsets defvars args in
defvars, mk_norm_expr offsets expr (Expr_appl (id, norm_args, None))
| Expr_appl (id, args, r) ->
@@ -203,7 +211,7 @@ let rec normalize_expr ?(alias=true) node offsets defvars expr =
let defvars, norm_expr = normalize_expr node [] defvars norm_expr in
normalize_expr ~alias:alias node offsets defvars norm_expr
else
- mk_expr_alias_opt (alias && not (Basic_library.is_internal_fun id)) node defvars norm_expr
+ mk_expr_alias_opt (alias && not (Basic_library.is_expr_internal_fun expr)) node defvars norm_expr
| Expr_arrow (e1,e2) when !unfold_arrow_active && not (is_expr_once expr) -> (* Here we differ from Colaco paper: arrows are pushed to the top *)
normalize_expr ~alias:alias node offsets defvars (unfold_arrow expr)
| Expr_arrow (e1,e2) ->
@@ -251,7 +259,7 @@ and normalize_branches node offsets defvars hl =
hl (defvars, [])
and normalize_array_expr ?(alias=true) node offsets defvars expr =
-(* Format.eprintf "normalize_array %B %a [%a]@." alias Printers.pp_expr expr (Utils.fprintf_list ~sep:"," Dimension.pp_dimension) offsets;*)
+ (*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 node offsets defvars e1 in
@@ -262,7 +270,7 @@ and normalize_array_expr ?(alias=true) node offsets defvars expr =
| Expr_array elist when offsets = [] ->
let defvars, norm_elist = normalize_list alias node 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_internal_fun id ->
+ | Expr_appl (id, args, None) when Basic_library.is_expr_internal_fun expr ->
let defvars, norm_args = normalize_list alias node 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 node offsets defvars expr
@@ -310,6 +318,7 @@ let decouple_outputs node defvars eq =
defvars', {eq with eq_lhs = lhs' }
let rec normalize_eq node defvars eq =
+(*Format.eprintf "normalize_eq %a@." Types.print_ty eq.eq_rhs.expr_type;*)
match eq.eq_rhs.expr_desc with
| Expr_pre _
| Expr_fby _ ->
@@ -321,7 +330,7 @@ let rec normalize_eq node defvars eq =
let (defs', vars'), norm_rhs = normalize_array_expr ~alias:false node [] 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_internal_fun id && Types.is_array_type eq.eq_rhs.expr_type ->
+ | 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 node [] defvars eq.eq_rhs in
let norm_eq = { eq with eq_rhs = norm_rhs } in
(norm_eq::defs', vars')
@@ -353,10 +362,10 @@ let normalize_node node =
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
- node
+ let (defs, vars'), expr =
+ normalize_expr
+ ~alias:false
+ node
[] (* empty offset for arrays *)
([], vars) (* defvar only contains vars *)
assert_expr
@@ -368,7 +377,7 @@ let normalize_node node =
(*Format.eprintf "New locals: %a@.@?" (fprintf_list ~sep:", " Printers.pp_var) new_locals;*)
let new_annots =
- if !Options.traces then
+ if !Options.horntraces then
begin
(* Compute traceability info:
- gather newly bound variables
@@ -401,10 +410,7 @@ let normalize_node node =
node_asserts = asserts;
node_annot = new_annots;
}
- in ((*Printers.pp_node Format.err_formatter node;*)
- node
-)
-
+ in ((*Printers.pp_node Format.err_formatter node;*) node)
let normalize_decl decl =
match decl.top_decl_desc with
diff --git a/src/optimize_machine.ml b/src/optimize_machine.ml
index 48a36f96..6d932a1d 100644
--- a/src/optimize_machine.ml
+++ b/src/optimize_machine.ml
@@ -26,7 +26,8 @@ let pp_elim fmt elim =
let rec eliminate elim instr =
let e_expr = eliminate_expr elim in
- match instr with
+ match instr with
+ | MComment _ -> instr
| MLocalAssign (i,v) -> MLocalAssign (i, e_expr v)
| MStateAssign (i,v) -> MStateAssign (i, e_expr v)
| MReset i -> instr
@@ -41,126 +42,44 @@ let rec eliminate elim instr =
)
and eliminate_expr elim expr =
- match expr with
- | StateVar v
+ match expr.value_desc with
| LocalVar v -> (try IMap.find v.var_id elim with Not_found -> expr)
- | Fun (id, vl) -> Fun (id, List.map (eliminate_expr elim) vl)
- | Array(vl) -> Array(List.map (eliminate_expr elim) vl)
- | Access(v1, v2) -> Access(eliminate_expr elim v1, eliminate_expr elim v2)
- | Power(v1, v2) -> Power(eliminate_expr elim v1, eliminate_expr elim v2)
- | Cst _ -> 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) dim
-
-let unfold_expr_offset m offset expr =
- List.fold_left (fun res -> (function Index i -> Access(res, value_of_dimension m i) | Field f -> failwith "not yet implemented")) expr offset
-
-let rec simplify_cst_expr m offset cst =
- match offset, cst with
- | [] , _
- -> Cst cst
- | Index i :: q, Const_array cl when Dimension.is_dimension_const i
- -> simplify_cst_expr m q (List.nth cl (Dimension.size_const_dimension i))
- | Index i :: q, Const_array cl
- -> unfold_expr_offset m [Index i] (Array (List.map (simplify_cst_expr m q) cl))
- | Field f :: q, Const_struct fl
- -> simplify_cst_expr m q (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 with
- | Field f ::q , _ -> failwith "not yet implemented"
- | _ , Fun (id, vl) when Basic_library.is_internal_fun id
- -> Fun (id, List.map (simplify offset) vl)
- | _ , Fun _
- | _ , StateVar _
- | _ , LocalVar _ -> unfold_expr_offset m offset expr
- | _ , Cst cst -> simplify_cst_expr m offset cst
- | _ , Access (expr, i) -> simplify (Index (dimension_of_value i) :: offset) 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] (Array (List.map (simplify q) vl))
- | _ -> (Format.eprintf "internal error: Optimize_machine.simplify_expr_offset %a@." pp_val expr; assert false)
- (*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 instr with
- | MLocalAssign (v, expr) -> MLocalAssign (v, simplify_expr_offset m expr)
- | MStateAssign (v, expr) -> MStateAssign (v, simplify_expr_offset m expr)
- | MReset id -> instr
- | MStep (outputs, id, inputs) -> MStep (outputs, id, List.map (simplify_expr_offset m) inputs)
- | MBranch (cond, brl)
- -> 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
+ | 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 _ | StateVar _ -> expr
let is_scalar_const c =
match c with
- | Const_int _
| Const_real _
- | Const_float _
+ | 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_float _
- | _ , 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 with
- | _ , Cst cst -> unfold_const offset cst
- | _ , LocalVar _
- | _ , StateVar _ -> true
- | [] , Power _
- | [] , Array _ -> false
- | Index i :: 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 (id, vl) when fanin < 2 && Basic_library.is_internal_fun id
- -> List.for_all (unfold offset) vl
- | _ , Fun _ -> false
- | _ -> assert false
- in unfold [] expr
+let basic_unfoldable_expr expr =
+ match expr.value_desc with
+ | Cst c when is_scalar_const c -> true
+ | LocalVar _
+ | StateVar _ -> true
+ | _ -> false
-let unfoldable_assign fanin v expr =
+let rec basic_unfoldable_assign fanin v expr =
try
let d = Hashtbl.find fanin v.var_id
- in is_unfoldable_expr d expr
- with Not_found -> false
-(*
-let unfoldable_assign fanin v expr =
- try
- let d = Hashtbl.find fanin v.var_id
- in is_basic_expr expr ||
- match expr with
- | Cst c when d < 2 -> true
- | Fun (id, _) when d < 2 && Basic_library.is_internal_fun id -> true
+ in match expr.value_desc with
+ | Cst c when is_scalar_const c -> true
+ | Cst c when d < 2 -> true
+ | LocalVar _
+ | StateVar _ -> true
+ | Fun (id, [a]) when d < 2 && Basic_library.is_value_internal_fun expr -> basic_unfoldable_assign fanin v a
| _ -> false
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
+
let merge_elim elim1 elim2 =
let merge k e1 e2 =
match e1, e2 with
@@ -189,8 +108,8 @@ and instr_unfold fanin instrs elim instr =
(* Format.eprintf "SHOULD WE STORE THE EXPRESSION IN INSTR %a TO ELIMINATE IT@." pp_instr instr;*)
match instr with
(* Simple cases*)
- | MStep([v], id, vl) when Basic_library.is_internal_fun id
- -> instr_unfold fanin instrs elim (MLocalAssign (v, Fun (id, vl)))
+ | MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type)
+ -> instr_unfold fanin instrs elim (MLocalAssign (v, mk_val (Fun (id, vl)) v.var_type))
| MLocalAssign(v, expr) when unfoldable_assign fanin v expr
-> (IMap.add v.var_id expr elim, instrs)
| MBranch(g, hl) when false
@@ -225,7 +144,7 @@ let machine_unfold fanin elim machine =
(*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*)
let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in
let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in
- let instrs = simplify_instrs_offset machine instrs in
+ (*let instrs = simplify_instrs_offset machine instrs in*)
let checks = List.map (fun (loc, check) -> loc, eliminate_expr 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 minstances = List.map (static_call_unfold elim_consts) machine.minstances in
@@ -242,26 +161,29 @@ let machine_unfold fanin elim machine =
mconst = mconst;
minstances = minstances;
mcalls = mcalls;
- }
+ },
+ elim_vars
let instr_of_const top_const =
let const = const_of_top top_const in
let vdecl = mkvar_decl Location.dummy_loc (const.const_id, mktyp Location.dummy_loc Tydec_any, mkclock Location.dummy_loc Ckdec_any, true, None) in
let vdecl = { vdecl with var_type = const.const_type }
- in MLocalAssign (vdecl, Cst const.const_value)
+ in MLocalAssign (vdecl, mk_val (Cst const.const_value) vdecl.var_type)
let machines_unfold consts node_schs machines =
- List.map
- (fun m ->
- let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in
- let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts)
- in machine_unfold fanin elim_consts m)
+ List.fold_right (fun m (machines, removed) ->
+ let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in
+ let elim_consts, _ = instrs_unfold 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 instr with
- | MLocalAssign(v, _) -> LocalVar v
- | MStateAssign(v, _) -> StateVar v
+ | MLocalAssign(v, e) -> mk_val (LocalVar v) e.value_type
+ | MStateAssign(v, e) -> mk_val (StateVar v) e.value_type
| _ -> assert false
let get_assign_rhs instr =
@@ -277,7 +199,7 @@ let is_assign instr =
| _ -> false
let mk_assign v e =
- match v with
+ match v.value_desc with
| LocalVar v -> MLocalAssign(v, e)
| StateVar v -> MStateAssign(v, e)
| _ -> assert false
@@ -315,18 +237,20 @@ let subst_instr subst instrs instr =
let e = get_assign_rhs instr in
try
let instr' = List.find (fun instr' -> is_assign instr' && get_assign_rhs instr' = e) instrs in
- match v with
+ match v.value_desc with
| LocalVar v ->
IMap.add v.var_id (get_assign_lhs instr') subst, instrs
| StateVar v ->
- (match get_assign_lhs instr' with
+ let lhs' = get_assign_lhs instr' in
+ let typ' = lhs'.value_type in
+ (match lhs'.value_desc with
| LocalVar v' ->
- let instr = eliminate subst (mk_assign (StateVar v) (LocalVar v')) in
+ let instr = eliminate subst (mk_assign (mk_val (StateVar v) typ') (mk_val (LocalVar v') typ')) in
subst, instr :: instrs
| StateVar v' ->
- let subst_v' = IMap.add v'.var_id (StateVar 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 subst_v' instr :: instrs)) instrs (false, [])) in
- IMap.add v'.var_id (StateVar v) subst, instr :: instrs'
+ let subst_v' = IMap.add v'.var_id (mk_val (StateVar v) typ') 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 subst_v' instr :: instrs)) instrs (false, [])) in
+ IMap.add v'.var_id (mk_val (StateVar v) typ') subst, instr :: instrs'
| _ -> assert false)
| _ -> assert false
with Not_found -> subst, instr :: instrs
@@ -341,9 +265,9 @@ let subst_instr subst instrs instr =
let rec instr_cse (subst, instrs) instr =
match instr with
(* Simple cases*)
- | MStep([v], id, vl) when Basic_library.is_internal_fun id
- -> instr_cse (subst, instrs) (MLocalAssign (v, Fun (id, vl)))
- | MLocalAssign(v, expr) when is_unfoldable_expr 2 expr
+ | MStep([v], id, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (id, vl)) v.var_type)
+ -> instr_cse (subst, instrs) (MLocalAssign (v, (mk_val (Fun (id, vl)) v.var_type)))
+ | MLocalAssign(v, expr) when basic_unfoldable_expr expr
-> (IMap.add v.var_id expr subst, instr :: instrs)
| _ when is_assign instr
-> subst_instr subst instrs instr
@@ -384,8 +308,8 @@ let machines_cse machines =
(* checks whether an [instr] is skip and can be removed from program *)
let rec instr_is_skip instr =
match instr with
- | MLocalAssign (i, LocalVar v) when i = v -> true
- | MStateAssign (i, StateVar v) when i = v -> true
+ | MLocalAssign (i, { value_desc = (LocalVar v) ; _}) when i = v -> true
+ | MStateAssign (i, { value_desc = StateVar v; _}) when i = v -> true
| MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl
| _ -> false
and instrs_are_skip instrs =
@@ -396,8 +320,8 @@ let instr_cons instr cont =
let rec instr_remove_skip instr cont =
match instr with
- | MLocalAssign (i, LocalVar v) when i = v -> cont
- | MStateAssign (i, StateVar v) when i = v -> cont
+ | MLocalAssign (i, { value_desc = LocalVar v; _ }) when i = v -> cont
+ | MStateAssign (i, { value_desc = StateVar v; _ }) when i = v -> cont
| MBranch (g, hl) -> MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl) :: cont
| _ -> instr::cont
@@ -405,17 +329,18 @@ and instrs_remove_skip instrs cont =
List.fold_right instr_remove_skip instrs cont
let rec value_replace_var fvar value =
- match value with
+ match value.value_desc with
| Cst c -> value
- | LocalVar v -> LocalVar (fvar v)
+ | LocalVar v -> { value with value_desc = LocalVar (fvar v) }
| StateVar v -> value
- | Fun (id, args) -> Fun (id, List.map (value_replace_var fvar) args)
- | Array vl -> Array (List.map (value_replace_var fvar) vl)
- | Access (t, i) -> Access(value_replace_var fvar t, i)
- | Power (v, n) -> Power(value_replace_var fvar v, n)
+ | 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 instr with
+ | MComment _ -> instr_cons instr cont
| MLocalAssign (i, v) -> instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont
| MStateAssign (i, v) -> instr_cons (MStateAssign (i, value_replace_var fvar v)) cont
| MReset i -> instr_cons instr cont
@@ -457,10 +382,10 @@ let machine_reuse_variables m reuse =
with Not_found -> v in
machine_replace_variables fvar m
-let machines_reuse_variables prog node_schs =
+let machines_reuse_variables prog reuse_tables =
List.map
(fun m ->
- machine_reuse_variables m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table
+ machine_reuse_variables m (Utils.IMap.find m.mname.node_id reuse_tables)
) prog
let rec instr_assign res instr =
@@ -476,8 +401,8 @@ and instrs_assign res instrs =
let rec instr_constant_assign var instr =
match instr with
- | MLocalAssign (i, Cst (Const_tag _))
- | MStateAssign (i, Cst (Const_tag _)) -> i = var
+ | MLocalAssign (i, { value_desc = Cst (Const_tag _); _ })
+ | MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) -> i = var
| MBranch (g, hl) -> List.for_all (fun (h, b) -> instrs_constant_assign var b) hl
| _ -> false
@@ -486,8 +411,8 @@ and instrs_constant_assign var instrs =
let rec instr_reduce branches instr1 cont =
match instr1 with
- | MLocalAssign (_, Cst (Const_tag c)) -> instr1 :: (List.assoc c branches @ cont)
- | MStateAssign (_, Cst (Const_tag c)) -> instr1 :: (List.assoc c branches @ 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) -> MBranch (g, List.map (fun (h, b) -> (h, instrs_reduce branches b [])) hl) :: cont
| _ -> instr1 :: cont
@@ -502,9 +427,9 @@ let rec instrs_fusion instrs =
| []
| [_] ->
instrs
- | i1::(MBranch (LocalVar v, hl))::q when instr_constant_assign v i1 ->
+ | i1::(MBranch ({ value_desc = LocalVar v; _}, hl))::q when instr_constant_assign v i1 ->
instr_reduce (List.map (fun (h, b) -> h, instrs_fusion b) hl) i1 (instrs_fusion q)
- | i1::(MBranch (StateVar v, hl))::q when instr_constant_assign v i1 ->
+ | i1::(MBranch ({ value_desc = StateVar v; _}, hl))::q 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)
diff --git a/src/options.ml b/src/options.ml
index 16ada24b..99744c53 100755
--- a/src/options.ml
+++ b/src/options.ml
@@ -33,41 +33,60 @@ let witnesses = ref false
let optimization = ref 2
let lusi = ref false
let print_reuse = ref false
-let traces = ref false
+let const_unfold = ref false
+let mpfr = ref false
+let mpfr_prec = ref 0
let horntraces = ref false
let horn_cex = ref false
-let horn_query = ref true
+let horn_queries = ref false
+let salsa_enabled = ref false
+let set_mpfr prec =
+ if prec > 0 then (
+ mpfr := true;
+ mpfr_prec := prec;
+ salsa_enabled := false; (* We deactivate salsa *)
+ )
+ else
+ failwith "mpfr requires a positive integer"
+
let options =
[ "-d", Arg.Set_string dest_dir,
- "uses the specified directory as root for generated/imported object and C files (default: .)";
- "-node", Arg.Set_string main_node, "specifies the main node";
+ "uses the specified directory \x1b[4mdir\x1b[0m as root for generated/imported object and C files <default: .>";
+ "-node", Arg.Set_string main_node, "specifies the \x1b[4mmain\x1b[0m node";
"-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>";
- "-ansi", Arg.Set ansi, "specifies that generated C code is ansi C90 compliant <default: C99>";
"-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)";
+ "-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";
"-horn", Arg.Unit (fun () -> output := "horn"), "generates Horn clauses encoding output instead of C";
- "-horn-traces", Arg.Unit (fun () -> output := "horn"; traces:=true), "produce traceability file for Horn backend. Enable the horn backend.";
+ "-horn-traces", Arg.Unit (fun () -> output := "horn"; horntraces:=true), "produce traceability file for Horn backend. Enable the horn backend.";
"-horn-cex", Arg.Unit (fun () -> output := "horn"; horn_cex:=true), "generate cex enumeration. Enable the horn backend (work in progress)";
- "-horn-query", Arg.Unit (fun () -> output := "horn"; horn_query:=true), "generate queries in generated Horn file. Enable the horn backend (work in progress)";
+ "-horn-queries", Arg.Unit (fun () -> output := "horn"; horn_queries:=true), "generate queries in generated Horn file. Enable the horn backend (work in progress)";
+ "-salsa", Arg.Set salsa_enabled, "activate Salsa optimization <default>";
+ "-no-salsa", Arg.Clear salsa_enabled, "deactivate Salsa optimization";
"-print_reuse", Arg.Set print_reuse, "prints variable reuse policy";
"-lustre", Arg.Unit (fun () -> output := "lustre"), "generates Lustre output, performing all active optimizations";
- "-inline", Arg.Set global_inline, "inline all node calls (require a main node)";
+ "-inline", Arg.Unit (fun () -> global_inline := true; const_unfold := true), "inline all node calls (require a main node). Implies constant unfolding";
"-witnesses", Arg.Set witnesses, "enable production of witnesses during compilation";
"-print_types", Arg.Set print_types, "prints node types";
"-print_clocks", Arg.Set print_clocks, "prints node clocks";
- "-O", Arg.Set_int optimization, " changes optimization level <default: 2>";
- "-verbose", Arg.Set_int verbose_level, " changes verbose level <default: 1>";
+ "-O", Arg.Set_int optimization, "changes optimization \x1b[4mlevel\x1b[0m <default: 2>";
+ "-verbose", Arg.Set_int verbose_level, "changes verbose \x1b[4mlevel\x1b[0m <default: 1>";
"-version", Arg.Unit print_version, " displays the version";]
+let plugin_opt (name, activate, options) =
+ ( "-" ^ name , Arg.Unit activate, "activate plugin " ^ 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
diff --git a/src/parser_lustre.mly b/src/parser_lustre.mly
index ab4b1766..40f02458 100755
--- a/src/parser_lustre.mly
+++ b/src/parser_lustre.mly
@@ -18,9 +18,10 @@ open Parse
let get_loc () = Location.symbol_rloc ()
+let mkident x = x, get_loc ()
let mktyp x = mktyp (get_loc ()) x
let mkclock x = mkclock (get_loc ()) x
-let mkvar_decl x = mkvar_decl (get_loc ()) ~orig:true x
+let mkvar_decl x loc = mkvar_decl loc ~orig:true x
let mkexpr x = mkexpr (get_loc ()) x
let mkeexpr x = mkeexpr (get_loc ()) x
let mkeq x = mkeq (get_loc ()) x
@@ -52,8 +53,8 @@ let rec fby expr n init =
%}
%token <int> INT
-%token <string> REAL
-%token <float> FLOAT
+%token <Num.num * int * string> REAL
+
%token <string> STRING
%token AUTOMATON STATE UNTIL UNLESS RESTART RESUME LAST
%token STATELESS ASSERT OPEN QUOTE FUNCTION
@@ -69,7 +70,7 @@ let rec fby expr n init =
%token MERGE FBY WHEN WHENNOT EVERY
%token NODE LET TEL RETURNS VAR IMPORTED SENSOR ACTUATOR WCET TYPE CONST
%token STRUCT ENUM
-%token TINT TFLOAT TREAL TBOOL TCLOCK
+%token TINT TREAL TBOOL TCLOCK
%token RATE DUE
%token EQ LT GT LTE GTE NEQ
%token AND OR XOR IMPL
@@ -116,6 +117,9 @@ let rec fby expr n init =
%start lustre_spec
%type <LustreSpec.node_annot> lustre_spec
+%start signed_const
+%type <LustreSpec.constant> signed_const
+
%%
module_ident:
@@ -135,8 +139,8 @@ node_ident_decl:
node_ident { push_node $1; $1 }
vdecl_ident:
- UIDENT { $1 }
-| IDENT { $1 }
+ UIDENT { mkident $1 }
+| IDENT { mkident $1 }
const_ident:
UIDENT { $1 }
@@ -180,7 +184,7 @@ state_annot:
top_decl_header:
| CONST cdecl_list { List.rev ($2 true) }
-| nodespec_list state_annot node_ident LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR prototype_opt in_lib_opt SCOL
+| nodespec_list state_annot node_ident LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR prototype_opt in_lib_list SCOL
{let nd = mktop_decl true (ImportedNode
{nodei_id = $3;
nodei_type = Types.new_var ();
@@ -198,9 +202,9 @@ prototype_opt:
{ None }
| PROTOTYPE node_ident { Some $2}
-in_lib_opt:
-{ None }
-| LIB module_ident {Some $2}
+in_lib_list:
+{ [] }
+| LIB module_ident in_lib_list { $2::$3 }
top_decl:
| CONST cdecl_list { List.rev ($2 false) }
@@ -232,8 +236,8 @@ top_decl:
in
pop_node ();
(*add_node $3 nd;*) [nd] }
-
- nodespec_list:
+
+nodespec_list:
{ None }
| NODESPEC nodespec_list {
(function
@@ -264,7 +268,7 @@ typeconst:
TINT array_typ_decl { $2 Tydec_int }
| TBOOL array_typ_decl { $2 Tydec_bool }
| TREAL array_typ_decl { $2 Tydec_real }
-| TFLOAT array_typ_decl { $2 Tydec_float }
+/* | TFLOAT array_typ_decl { $2 Tydec_float } */
| type_ident array_typ_decl { $2 (Tydec_const $1) }
| TBOOL TCLOCK { Tydec_clock Tydec_bool }
| IDENT TCLOCK { Tydec_clock (Tydec_const $1) }
@@ -313,8 +317,8 @@ assert_:
| ASSERT expr SCOL {mkassert ($2)}
eq:
- ident_list EQ expr SCOL {mkeq (List.rev $1,$3)}
-| LPAR ident_list RPAR EQ expr SCOL {mkeq (List.rev $2,$5)}
+ ident_list EQ expr SCOL {mkeq (List.rev (List.map fst $1), $3)}
+| LPAR ident_list RPAR EQ expr SCOL {mkeq (List.rev (List.map fst $2), $5)}
lustre_spec:
| contract EOF { $1 }
@@ -369,8 +373,8 @@ dim_list:
expr:
/* constants */
INT {mkexpr (Expr_const (Const_int $1))}
-| REAL {mkexpr (Expr_const (Const_real $1))}
-| FLOAT {mkexpr (Expr_const (Const_float $1))}
+| REAL {let c,e,s = $1 in mkexpr (Expr_const (Const_real (c,e,s)))}
+/* | FLOAT {mkexpr (Expr_const (Const_float $1))}*/
/* Idents or type enum tags */
| IDENT { mkexpr (Expr_ident $1) }
| tag_ident { mkexpr (Expr_ident $1) (*(Expr_const (Const_tag $1))*) }
@@ -395,13 +399,13 @@ expr:
{(*mkexpr (Expr_fby ($1,$3))*)
mkexpr (Expr_arrow ($1, mkexpr (Expr_pre $3)))}
| expr WHEN vdecl_ident
- {mkexpr (Expr_when ($1,$3,tag_true))}
+ {mkexpr (Expr_when ($1,fst $3,tag_true))}
| expr WHENNOT vdecl_ident
- {mkexpr (Expr_when ($1,$3,tag_false))}
+ {mkexpr (Expr_when ($1,fst $3,tag_false))}
| expr WHEN tag_ident LPAR vdecl_ident RPAR
- {mkexpr (Expr_when ($1, $5, $3))}
+ {mkexpr (Expr_when ($1, fst $5, $3))}
| MERGE vdecl_ident handler_expr_list
- {mkexpr (Expr_merge ($2,$3))}
+ {mkexpr (Expr_merge (fst $2,$3))}
/* Applications */
| node_ident LPAR expr RPAR
@@ -409,28 +413,9 @@ expr:
| node_ident LPAR expr RPAR EVERY expr
{mkexpr (Expr_appl ($1, $3, Some $6))}
| node_ident LPAR tuple_expr RPAR
- {
- let id=$1 in
- let args=List.rev $3 in
- match id, args with
- | "fbyn", [expr;n;init] ->
- let n = match n.expr_desc with
- | Expr_const (Const_int n) -> n
- | _ -> assert false
- in
- fby expr n init
- | _ -> mkexpr (Expr_appl ($1, mkexpr (Expr_tuple args), None))
- }
+ {mkexpr (Expr_appl ($1, mkexpr (Expr_tuple (List.rev $3)), None))}
| node_ident LPAR tuple_expr RPAR EVERY expr
- {
- let id=$1 in
- let args=List.rev $3 in
- let clock=$6 in
- if id="fby" then
- assert false (* TODO Ca veut dire quoi fby (e,n,init) every c *)
- else
- mkexpr (Expr_appl (id, mkexpr (Expr_tuple args), Some clock))
- }
+ {mkexpr (Expr_appl ($1, mkexpr (Expr_tuple (List.rev $3)), Some $6)) }
/* Boolean expr */
| expr AND expr
@@ -497,12 +482,12 @@ signed_const_struct:
signed_const:
INT {Const_int $1}
-| REAL {Const_real $1}
-| FLOAT {Const_float $1}
+| REAL {let c,e,s =$1 in Const_real (c,e,s)}
+/* | FLOAT {Const_float $1} */
| tag_ident {Const_tag $1}
| MINUS INT {Const_int (-1 * $2)}
-| MINUS REAL {Const_real ("-" ^ $2)}
-| MINUS FLOAT {Const_float (-1. *. $2)}
+| MINUS REAL {let c,e,s = $2 in Const_real (Num.minus_num c, e, "-" ^ s)}
+/* | MINUS FLOAT {Const_float (-1. *. $2)} */
| LCUR signed_const_struct RCUR { Const_struct $2 }
| LBRACKET signed_const_array RBRACKET { Const_array $2 }
@@ -567,11 +552,11 @@ vdecl_list:
vdecl:
ident_list COL typeconst clock
- { List.map (fun id -> mkvar_decl (id, mktyp $3, $4, false, None)) $1 }
+ { List.map (fun (id, loc) -> mkvar_decl (id, mktyp $3, $4, false, None) loc) $1 }
| CONST ident_list /* static parameters don't have clocks */
- { List.map (fun id -> mkvar_decl (id, mktyp Tydec_any, mkclock Ckdec_any, true, None)) $2 }
+ { List.map (fun (id, loc) -> mkvar_decl (id, mktyp Tydec_any, mkclock Ckdec_any, true, None) loc) $2 }
| CONST ident_list COL typeconst /* static parameters don't have clocks */
- { List.map (fun id -> mkvar_decl (id, mktyp $4, mkclock Ckdec_any, true, None)) $2 }
+ { List.map (fun (id, loc) -> mkvar_decl (id, mktyp $4, mkclock Ckdec_any, true, None) loc) $2 }
local_vdecl_list:
local_vdecl {$1}
@@ -579,13 +564,13 @@ local_vdecl_list:
local_vdecl:
/* Useless no ?*/ ident_list
- { List.map (fun id -> mkvar_decl (id, mktyp Tydec_any, mkclock Ckdec_any, false, None)) $1 }
+ { List.map (fun (id, loc) -> mkvar_decl (id, mktyp Tydec_any, mkclock Ckdec_any, false, None) loc) $1 }
| ident_list COL typeconst clock
- { List.map (fun id -> mkvar_decl (id, mktyp $3, $4, false, None)) $1 }
+ { List.map (fun (id, loc) -> mkvar_decl (id, mktyp $3, $4, false, None) loc) $1 }
| CONST vdecl_ident EQ expr /* static parameters don't have clocks */
- { [ mkvar_decl ($2, mktyp Tydec_any, mkclock Ckdec_any, true, Some $4) ] }
+ { let (id, loc) = $2 in [ mkvar_decl (id, mktyp Tydec_any, mkclock Ckdec_any, true, Some $4) loc ] }
| CONST vdecl_ident COL typeconst EQ expr /* static parameters don't have clocks */
- { [ mkvar_decl ($2, mktyp $4, mkclock Ckdec_any, true, Some $6) ] }
+ { let (id, loc) = $2 in [ mkvar_decl (id, mktyp $4, mkclock Ckdec_any, true, Some $6) loc ] }
cdecl_list:
cdecl SCOL { (fun itf -> [$1 itf]) }
diff --git a/src/plugins/salsa/machine_salsa_opt.ml b/src/plugins/salsa/machine_salsa_opt.ml
new file mode 100644
index 00000000..6900a332
--- /dev/null
+++ b/src/plugins/salsa/machine_salsa_opt.ml
@@ -0,0 +1,572 @@
+
+(* We try to avoid opening modules here *)
+module ST = Salsa.SalsaTypes
+module SDT = SalsaDatatypes
+module LT = LustreSpec
+module MC = Machine_code
+
+(* Datatype for Salsa: FormalEnv, Ranges, Var set ... *)
+open SalsaDatatypes
+(******************************************************************)
+(* TODO Xavier: should those functions be declared more globally? *)
+
+let fun_types node =
+ try
+ 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 =
+ let td, _ =
+ try
+ List.assoc id m.MC.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 =
+ match e.LT.value_desc with
+ | LT.LocalVar v | LT.StateVar v when Types.is_real_type v.LT.var_type -> Vars.singleton v
+ | LT.LocalVar _| LT.StateVar _
+ | LT.Cst _ -> Vars.empty
+ | LT.Fun (_, args) ->
+ List.fold_left
+ (fun acc e -> Vars.union acc (get_expr_real_vars e))
+ Vars.empty args
+ | LT.Array _
+ | LT.Access _
+ | LT.Power _ -> assert false
+
+(* Extract the variables to appear as free variables in expressions (lhs) *)
+let rec get_read_vars instrs =
+ match instrs with
+ [] -> Vars.empty
+ | i::tl -> (
+ let vars_tl = get_read_vars tl in
+ match i with
+ | LT.MLocalAssign(_,e)
+ | LT.MStateAssign(_,e) -> Vars.union (get_expr_real_vars e) vars_tl
+ | LT.MStep(_, _, el) -> List.fold_left (fun accu e -> Vars.union (get_expr_real_vars e) accu) vars_tl el
+ | LT.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
+ )
+ | LT.MReset _
+ | LT.MComment _ -> Vars.empty
+ )
+
+let rec get_written_vars instrs =
+ match instrs with
+ [] -> Vars.empty
+ | i::tl -> (
+ let vars_tl = get_written_vars tl in
+ match i with
+ | LT.MLocalAssign(v,_)
+ | LT.MStateAssign(v,_) -> Vars.add v vars_tl
+ | LT.MStep(vdl, _, _) -> List.fold_left (fun accu v -> Vars.add v accu) vars_tl vdl
+ | LT.MBranch(_, branches) -> (
+ List.fold_left (fun vars (_, b) -> Vars.union vars (get_written_vars b) ) vars_tl branches
+ )
+ | LT.MReset _
+ | LT.MComment _ -> Vars.empty
+ )
+
+
+(* Optimize a given expression. It returns another expression and a computed range. *)
+let optimize_expr nodename constEnv printed_vars vars_env ranges formalEnv e : LT.value_t * RangesInt.t option =
+ let rec opt_expr ranges formalEnv e =
+ match e.LT.value_desc with
+ | LT.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 ranges formalEnv e
+ else e, None
+ | LT.LocalVar v
+ | LT.StateVar 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.LT.value_type || Types.is_real_type v.LT.var_type)
+ then
+ opt_num_expr ranges formalEnv e
+ else
+ e, None (* 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 *)
+ (* else e, None *)
+ | LT.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.LT.value_type then
+ opt_num_expr ranges formalEnv e
+ else (
+ (* We do not care for computed local ranges. *)
+ let args' = List.map (fun arg -> let arg', _ = opt_expr ranges formalEnv arg in arg') args in
+ { e with LT.value_desc = LT.Fun(fun_id, args')}, None
+ )
+ )
+ | LT.Array _
+ | LT.Access _
+ | LT.Power _ -> assert false
+ and opt_num_expr ranges formalEnv e =
+ if debug then Format.eprintf "Optimizing expression %a@ " MC.pp_val e;
+ let fresh_id = "toto" in (* TODO more meaningful name *)
+ (* Convert expression *)
+ List.iter (fun (l,c) -> Format.eprintf "%s -> %a@ " l Printers.pp_const c) constEnv;
+ let e_salsa : Salsa.SalsaTypes.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) ;
+
+ (* Convert formalEnv *)
+ if debug then Format.eprintf "Formal env is [%a]@ " FormalEnv.pp formalEnv;
+ let formalEnv_salsa =
+ FormalEnv.fold (fun id expr accu ->
+ (id, value_t2salsa_expr constEnv expr)::accu
+ ) formalEnv [] in
+ if debug then Format.eprintf "Formal env converted to salsa@ ";
+ (* Substitute all occurences of variables by their definition in env *)
+ let (e_salsa: Salsa.SalsaTypes.expression), _ =
+ Salsa.Rewrite.substVars
+ e_salsa
+ formalEnv_salsa
+ 0 (* TODO: Nasrine, what is this integer value for ? *)
+ in
+ if debug then Format.eprintf "Substituted def in expr@ ";
+ let abstractEnv = Hashtbl.fold
+ (fun id value accu -> (id,value)::accu)
+ ranges
+ []
+ in
+ (* List.iter (fun (id, _) -> Format.eprintf "absenv: %s@." id) abstractEnv; *)
+ (* The expression is partially evaluated by the available ranges
+ valEnv2ExprEnv remplce les paires id, abstractVal par id, Cst itv - on
+ 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.Float.evalPartExpr
+ e_salsa
+ (Salsa.Float.valEnv2ExprEnv abstractEnv)
+ ([] (* no blacklisted variables *))
+ in
+ 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 (
+ Format.eprintf "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 ^ "." ^ v.LT.var_id } in Vars.add v' accu) free_vars Vars.empty)
+ MC.pp_val (salsa_expr2value_t vars_env constEnv e_salsa);
+ if debug then Format.eprintf "Some free vars, not optimizing@.";
+ let new_e = try salsa_expr2value_t vars_env constEnv e_salsa with Not_found -> assert false in
+ new_e, None
+ )
+ else (
+ try
+ if debug then
+ Format.eprintf "Analyzing expression %a with env: @[<v>%a@ @]@ "
+ MC.pp_val (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
+ ;
+
+ let new_e_salsa, e_val =
+ Salsa.MainEPEG.transformExpression fresh_id e_salsa abstractEnv
+ in
+ let new_e = try salsa_expr2value_t vars_env constEnv new_e_salsa with Not_found -> assert false in
+ if debug then Format.eprintf "@ @[<v>old: %a@ new: %a@ range: %a@]" MC.pp_val e MC.pp_val new_e RangesInt.pp_val e_val;
+ new_e, Some e_val
+ with Not_found -> assert false
+ | Salsa.Epeg_types.EPEGError _ -> (
+ Format.eprintf "BECAUSE OF AN ERROR, Expression %a was not optimized@ " MC.pp_val e;
+ e, None
+ )
+ )
+
+
+
+ in
+ if debug then
+ Format.eprintf "@[<v 2>Optimizing expression %a in environment %a and ranges %a@ "
+ MC.pp_val e
+ FormalEnv.pp formalEnv
+ RangesInt.pp ranges;
+ let res = opt_expr ranges formalEnv e in
+ Format.eprintf "@]@ ";
+ res
+
+
+
+(* 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 constEnv vars_env printed_vars ranges formalEnv vars_to_print =
+ (* We print thhe expression in the order of definition *)
+
+ let ordered_vars =
+ List.stable_sort
+ (FormalEnv.get_sort_fun formalEnv)
+ (Vars.elements vars_to_print)
+ in
+ Format.eprintf "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) ->
+ if debug then Format.eprintf "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 = optimize_expr nodename constEnv printed_vars vars_env ranges formalEnv v_def in
+ let instr =
+ if try (get_var vars_env v.LT.var_id).is_local with Not_found -> assert false then
+ LT.MLocalAssign(v, e)
+ else
+ LT.MStateAssign(v, e)
+ in
+ instr::accu_instr,
+ (match r with
+ | None -> ranges
+ | Some v_r -> RangesInt.add_def ranges v.LT.var_id v_r)
+ with FormalEnv.NoDefinition _ -> (
+ (* It should not happen with C backend, but may happen with Lustre backend *)
+ if !Options.output = "lustre" then accu_instr, ranges else (Format.eprintf "@?"; assert false)
+ )
+ ) ordered_vars ([], ranges)
+
+(* 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 constEnv vars_env m instrs ranges formalEnv printed_vars vars_to_print =
+ let assign_vars = assign_vars nodename constEnv vars_env in
+ if debug then (
+ Format.eprintf "------------@ ";
+ Format.eprintf "Current printed_vars: [%a]@ " Vars.pp printed_vars;
+ Format.eprintf "Formal env is [%a]@ " 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' = 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 *)
+
+ | 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 =
+ match hd_instr with
+ | LT.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;
+ let formalEnv' = FormalEnv.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 *)
+
+ | LT.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;
+ let formalEnv' = FormalEnv.def formalEnv vd vt in (* formelEnv updated with vd = vt *)
+ let instrs', ranges' = (* 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 *)
+
+ | LT.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;
+ let formalEnv' = FormalEnv.def formalEnv vd vt in (* formelEnv updated with vd = vt *)
+ let instrs', ranges' = (* 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 *)
+
+ | (LT.MLocalAssign(vd,vt) | LT.MStateAssign(vd,vt)) ->
+ (* 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 *)
+ let prefix_instr, ranges =
+ assign_vars printed_vars ranges formalEnv required_vars in
+ let vt', _ = optimize_expr nodename constEnv (Vars.union required_vars printed_vars) vars_env ranges formalEnv vt in
+ let new_instr =
+ match hd_instr with
+ | LT.MLocalAssign _ -> LT.MLocalAssign(vd,vt')
+ | _ -> LT.MStateAssign(vd,vt')
+ in
+ let written_vars = Vars.add vd required_vars in
+ prefix_instr@[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 *)
+
+ | LT.MStep(vdl,id,vtl) ->
+ 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 = List.fold_right2 (
+ fun e typ_e (exprl, range_l)->
+ if Types.is_real_type typ_e then
+ let e', r' = optimize_expr nodename constEnv printed_vars vars_env ranges formalEnv e in
+ e'::exprl, r'::range_l
+ else
+ e::exprl, None::range_l
+ ) vtl tin ([], [])
+ 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' @ [LT.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
+
+ | LT.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 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 vt', _ = optimize_expr nodename constEnv printed_vars vars_env ranges formalEnv vt 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 = List.fold_right (
+ fun (b_l, b_instrs) (new_branches, written_vars, merged_ranges) ->
+ 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 =
+ rewrite_instrs nodename 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
+
+ ) branches ([], required_vars, ranges) in
+ if debug then Format.eprintf "dealing with branches done@ @]@ ";
+ prefix_instr@[LT.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 *)
+
+
+ | LT.MReset(_) | LT.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 *)
+
+ in
+ let tl_instrs, ranges, formalEnv, printed_vars, vars_to_print =
+ rewrite_instrs
+ nodename
+ 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
+ end
+
+
+
+
+
+
+(* 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.MC.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 (c,e,s)) ->
+ (* calculer la valeur c * 10^e *)
+ Num.float_of_num (Num.div_num c (Num.power_num (Num.num_of_int 10) (Num.num_of_int e)))
+ | _ ->
+ Format.eprintf
+ "Invalid scala range: %a. It should be a pair of constant floats.@."
+ Printers.pp_expr value.LT.eexpr_qfexpr;
+ assert false
+ in
+ let minv, maxv = get_cst minv, get_cst maxv in
+ if debug then Format.eprintf "%s in [%f, %f]@ " v minv maxv;
+ RangesInt.enlarge ranges v (Salsa.SalsaTypes.I(minv, maxv),Salsa.SalsaTypes.J(0.,0.))
+ )
+ | _ ->
+ Format.eprintf
+ "Invalid scala 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.MC.mmemory)
+ (Vars.of_list s.MC.step_outputs)
+ )
+ in
+ (* TODO: should be at least step output + may be memories *)
+ let vars_env = compute_vars_env m in
+ let new_instrs, _, _, printed_vars, _ =
+ rewrite_instrs
+ m.MC.mname.LT.node_id
+ constEnv
+ vars_env
+ m
+ s.MC.step_instrs
+ ranges
+ formal_env
+ (Vars.real_vars (Vars.of_list s.MC.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.MC.step_locals) in
+ let unused = (Vars.diff all_local_vars printed_vars) in
+ let locals =
+ if not (Vars.is_empty unused) then (
+ Format.eprintf "Unused local vars: [%a]. Removing them.@.@?"
+ Vars.pp unused;
+ List.filter (fun v -> not (Vars.mem v unused)) s.MC.step_locals
+ )
+ else
+ s.MC.step_locals
+ in
+ { s with MC.step_instrs = new_instrs; MC.step_locals = locals } (* we have also to modify local variables to declare new vars *)
+
+
+let machine_t2machine_t_optimized_by_salsa constEnv mt =
+ try
+ if debug then Format.eprintf "@[<v 2>------------------ Optimizing machine %s@ " mt.MC.mname.LT.node_id;
+ let new_step = salsaStep constEnv mt mt.MC.mstep in
+ if debug then Format.eprintf "@]@.";
+ { mt with MC.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
new file mode 100644
index 00000000..e169354e
--- /dev/null
+++ b/src/plugins/salsa/salsaDatatypes.ml
@@ -0,0 +1,337 @@
+module LT = LustreSpec
+module MC = Machine_code
+module ST = Salsa.SalsaTypes
+module Float = Salsa.Float
+
+let debug = true
+
+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 "]@]";
+
+module FormalEnv =
+struct
+ type fe_t = (LT.ident, (int * LT.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)
+ with Not_found -> raise (NoDefinition v)
+
+ let def (env: fe_t) d expr =
+ incr cpt;
+ let fresh = Hashtbl.copy env in
+ Hashtbl.add fresh d.LT.var_id (!cpt, expr); fresh
+
+ let empty (): fe_t = Hashtbl.create 13
+
+ let pp fmt env = pp_hash ~sep:";" (fun k (_,v) fmt -> Format.fprintf fmt "%s -> %a" k MC.pp_val v) fmt env
+
+ let fold f = Hashtbl.fold (fun k (_,v) accu -> f k v accu)
+
+ 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
+
+end
+
+module Ranges =
+ functor (Value: sig type t val union: t -> t -> t val pp: Format.formatter -> t -> unit end) ->
+struct
+ 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 = pp_hash ~sep:";" (fun k v fmt -> Format.fprintf fmt "%s -> %a" k Value.pp v)
+ 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
+
+end
+
+module FloatIntSalsa =
+struct
+ type t = ST.abstractValue
+
+ let pp fmt (f,r) =
+ match f, r with
+ | ST.I(a,b), ST.J(c,d) ->
+ Format.fprintf fmt "[%f, %f] + [%f, %f]" a b c 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 =
+ 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 (ST.I(float_of_int i,float_of_int i),ST.J(0.0,0.0))
+ | LT.Const_real (c,e,s) -> (* TODO: this is incorrect. We should rather
+ compute the error associated to the float *)
+ let r = float_of_string s in
+ if r = 0. then
+ Salsa.Builder.mk_cst (ST.I(-. min_float, min_float),Float.ulp (ST.I(-. 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
+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 *)
+(*************************************************************************************)
+
+let rec value_t2salsa_expr constEnv vt =
+ let value_t2salsa_expr = value_t2salsa_expr constEnv in
+ let res =
+ match vt.LT.value_desc with
+ (* | LT.Cst(LT.Const_tag(t) as c) -> *)
+ (* Format.eprintf "v2s: cst tag@."; *)
+ (* if List.mem_assoc t constEnv then ( *)
+ (* Format.eprintf "trouvé la constante %s: %a@ " t Printers.pp_const c; *)
+ (* FloatIntSalsa.inject (List.assoc t constEnv) *)
+ (* ) *)
+ (* else ( *)
+ (* Format.eprintf "Const tag %s unhandled@.@?" t ; *)
+ (* raise (Salsa.Prelude.Error ("Entschuldigung6, constant tag not yet implemented")) *)
+ (* ) *)
+ | LT.Cst(cst) -> Format.eprintf "v2s: cst tag 2: %a@." Printers.pp_const cst; FloatIntSalsa.inject cst
+ | LT.LocalVar(v)
+ | LT.StateVar(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
+ else
+ let id = v.LT.var_id in
+ Salsa.Builder.mk_id id
+ | LT.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
+ | LT.Fun(unop, [x]) -> let salsaX = value_t2salsa_expr x in
+ Salsa.Builder.mk_uminus salsaX
+
+ | LT.Fun(f,_) -> raise (Salsa.Prelude.Error
+ ("Unhandled function "^f^" in conversion to salsa expression"))
+
+ | LT.Array(_)
+ | LT.Access(_)
+ | LT.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; *)
+ res
+
+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 *)
+
+let get_var vars_env v =
+try
+ VarEnv.find v vars_env
+ with Not_found -> Format.eprintf "Impossible to find var %s@.@?" v; 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.MC.mmemory
+ in
+ let env =
+ List.fold_left (
+ fun accu v -> VarEnv.add v.LT.var_id {vdecl = v; is_local = true; } accu
+ )
+ env
+ MC.(m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals)
+ in
+env
+
+let rec salsa_expr2value_t vars_env cst_env e =
+ let salsa_expr2value_t = salsa_expr2value_t vars_env cst_env in
+ let binop op e1 e2 t =
+ let x = salsa_expr2value_t e1 in
+ let y = salsa_expr2value_t e2 in
+ MC.mk_val (LT.Fun (op, [x;y])) t
+ in
+ match e with
+ ST.Cst((ST.I(f1,f2),_),_) -> (* We project ranges into constants. We
+ forget about errors and provide the
+ mean/middle value of the interval
+ *)
+ let new_float =
+ if f1 = f2 then
+ f1
+ else
+ (f1 +. f2) /. 2.0
+ in
+ Format.eprintf "Converting [%.45f, %.45f] in %.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 *)
+ let _ = Format.flush_str_formatter () in
+ Format.fprintf Format.str_formatter "%.50f" new_float;
+ Format.flush_str_formatter ()
+ in
+ Parser_lustre.signed_const Lexer_lustre.token (Lexing.from_string s)
+ in
+ MC.mk_val (LT.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
+ Format.eprintf "Found cst = %a@.@?" Printers.pp_const cst;
+ MC.mk_val (LT.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
+ if var_id.is_local then
+ MC.mk_val (LT.LocalVar(var_id.vdecl)) var_id.vdecl.LT.var_type
+ else
+ MC.mk_val (LT.StateVar(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 (LT.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
+
+(* Local Variables: *)
+(* compile-command:"make -C ../../.." *)
+(* End: *)
diff --git a/src/plugins/scopes/scopes.ml b/src/plugins/scopes/scopes.ml
new file mode 100644
index 00000000..1f1920bd
--- /dev/null
+++ b/src/plugins/scopes/scopes.ml
@@ -0,0 +1,319 @@
+open LustreSpec
+open Corelang
+open Machine_code
+
+(* (variable, node name, node instance) *)
+type scope_t = (var_decl * string * string option) list * var_decl
+
+
+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 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
+ in
+ try
+ Utils.desome node_opt
+ with Utils.DeSome -> raise Not_found
+
+let get_machine name machines =
+ try
+ List.find (fun m -> m.mname.node_id = name) machines
+ with Not_found -> raise Not_found
+
+let rec compute_scopes prog main_node : scope_t list =
+
+ (* Format.eprintf "Compute scope of %s@." main_node; *)
+ try
+ let node = get_node main_node prog in
+ let all_vars = node.node_inputs @ node.node_locals @ node.node_outputs in
+ let local_vars = 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
+ 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
+ in
+ 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)
+
+
+
+
+(* 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 ->
+ Format.eprintf "Cannot find variable %s in node %s@." name node.node_id;
+ assert false
+
+let scope_path main_node_name prog machines all_scopes sl : scope_t =
+ let rec get_path node id_list accu =
+ match id_list, accu with
+ | [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
+ | varid::nodename::id_list_tl, _ -> (
+ let e_machine = get_machine node.node_id machines 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 i with
+ | MStep(p, o, _) -> List.exists find_var p
+ | _ -> false
+ )
+ e_machine.mstep.step_instrs
+ in
+ try
+ let variable, instance_node, instance_id =
+ match 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
+ (* 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
+ in
+ let all_scopes_as_sl = List.map scope_to_sl all_scopes in
+ 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 = (* Special treatment of first level flow *)
+ match sl with
+ | [flow] -> let flow_var = get_node_vdecl_of_name flow main_node in
+ [], flow_var
+ | _ -> get_path main_node sl []
+
+ in
+ (* Format.eprintf "computed path: %a.%s@." print_path path flow.var_id; *)
+ path, flow
+
+ )
+
+let check_scopes main_node_name prog machines all_scopes scopes =
+ List.map
+ (fun sl ->
+ sl, scope_path main_node_name prog machines all_scopes sl
+ ) scopes
+
+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 true
+let option_mem_scopes = ref false
+let option_input_scopes = ref false
+
+let scopes_map : (LustreSpec.ident list * scope_t) list ref = ref []
+
+let register_scopes s =
+ 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
+ scopes_def := scope_list
+
+let register_inputs s =
+ 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
+ inputs := input_list
+
+
+(* 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 pp_scopes fmt scopes =
+ let rec scope_path (path, flow) accu =
+ match path with
+ | [] -> accu ^ "_reg." ^ flow.var_id, flow.var_type
+ | (_, _, Some instance_id)::tl -> scope_path (tl, flow) ( accu ^ instance_id ^ "->" )
+ | _ -> assert false
+ in
+ let scopes_vars =
+ List.map
+ (fun (sl, scope) ->
+ String.concat "." sl, scope_path scope "main_mem.")
+ scopes
+ in
+ List.iter (fun (id, (var, typ)) ->
+ match (Types.repr typ).Types.tdesc with
+ | Types.Tint -> Format.fprintf fmt "_put_int(\"%s\", %s);@ " id var
+ | Types.Tbool -> Format.fprintf fmt "_put_bool(\"%s\", %s);@ " id var
+ | Types.Treal when !Options.mpfr ->
+ Format.fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s));@ " id var (Mpfr.mpfr_rnd ())
+ | Types.Treal -> Format.fprintf fmt "_put_double(\"%s\", %s);@ " id var
+ | _ -> Format.eprintf "Impossible to print the _put_xx for type %a@.@?" Types.print_ty typ; assert false
+ ) scopes_vars
+
+let update_machine machine =
+ let stateassign vdecl =
+ MStateAssign (vdecl, mk_val (LocalVar vdecl) vdecl.var_type)
+ in
+ let local_decls = machine.mstep.step_inputs
+ (* @ machine.mstep.step_outputs *)
+ @ machine.mstep.step_locals
+ in
+ { machine with
+ mmemory = machine.mmemory @ local_decls;
+ mstep = {
+ machine.mstep with
+ step_instrs = machine.mstep.step_instrs
+ @ (MComment "Registering all flows")::(List.map stateassign local_decls)
+
+ }
+ }
+
+
+module Plugin =
+struct
+ let name = "scopes"
+ let is_active () =
+ !option_scopes
+
+ let show_scopes () =
+ !option_show_scopes && (
+ Compiler_common.check_main ();
+ true)
+
+ 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.Set option_all_scopes, "select all possible variables to log";
+ "-select-mem", Arg.Set option_mem_scopes, "select all memory variables to log";
+ "-select-inputs", Arg.Set option_input_scopes, "select all input variables to log";
+ ]
+
+ let activate () =
+ option_scopes := true;
+ Options.optimization := 0; (* no optimization *)
+ Options.salsa_enabled := false; (* No salsa *)
+ ()
+
+ let rec is_valid_path path nodename prog machines =
+ let nodescopes = compute_scopes prog nodename in
+ let m = get_machine nodename machines 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
+
+ | inst::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 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
+ 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
+ in
+ scopes_map := check_scopes main_node prog machines all_scopes selected_scopes;
+ (* Each machine is updated with fresh memories and declared as stateful *)
+ let machines = List.map update_machine machines in
+ machines
+
+ let pp fmt = pp_scopes fmt !scopes_map
+
+end
+
+(* Local Variables: *)
+(* compile-command:"make -C ../.." *)
+(* End: *)
diff --git a/src/printers.ml b/src/printers.ml
index f2cb78de..2dbe35ed 100644
--- a/src/printers.ml
+++ b/src/printers.ml
@@ -29,9 +29,8 @@ let rec print_dec_struct_ty_field fmt (label, cty) =
and print_dec_ty fmt cty =
match (*get_repr_type*) cty with
| Tydec_any -> fprintf fmt "Any"
- | Tydec_int -> fprintf fmt "int"
- | Tydec_real
- | Tydec_float -> fprintf fmt "real"
+ | Tydec_int -> fprintf fmt "int"
+ | Tydec_real -> fprintf fmt "real"
| Tydec_bool -> fprintf fmt "bool"
| Tydec_clock cty' -> fprintf fmt "%a clock" print_dec_ty cty'
| Tydec_const c -> fprintf fmt "%s" c
@@ -57,8 +56,8 @@ let rec pp_struct_const_field fmt (label, c) =
and 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_real (c,e,s) -> pp_print_string fmt s (*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 -> Format.fprintf fmt "[%a]" (Utils.fprintf_list ~sep:"," pp_const) ca
| Const_struct fl -> Format.fprintf fmt "{%a }" (Utils.fprintf_list ~sep:" " pp_struct_const_field) fl
@@ -131,7 +130,7 @@ and pp_eexpr fmt e =
and pp_expr_annot fmt expr_ann =
let pp_annot fmt (kwds, ee) =
- Format.fprintf fmt "(*! %t: %a *)"
+ Format.fprintf fmt "(*! %t: %a; *)"
(fun fmt -> match kwds with | [] -> assert false | [x] -> Format.pp_print_string fmt x | _ -> Format.fprintf fmt "/%a/" (fprintf_list ~sep:"/" Format.pp_print_string) kwds)
pp_eexpr ee
in
@@ -205,7 +204,7 @@ and pp_var_type_dec_desc fmt tdesc =
| Tydec_any -> fprintf fmt "<any>"
| Tydec_int -> fprintf fmt "int"
| Tydec_real -> fprintf fmt "real"
- | Tydec_float -> fprintf fmt "float"
+ (* | 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
diff --git a/src/scheduling.ml b/src/scheduling.ml
index 8238aa7c..e73540c2 100644
--- a/src/scheduling.ml
+++ b/src/scheduling.ml
@@ -17,14 +17,18 @@ open Causality
type schedule_report =
{
+ (* the scheduled node *)
+ node : node_desc;
(* a schedule computed wrt the dependency graph *)
schedule : ident list list;
(* the set of unused variables (no output or mem depends on them) *)
unused_vars : ISet.t;
(* 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
+ (*reuse_table : (ident, var_decl) Hashtbl.t*)
}
(* Topological sort with a priority for variables belonging in the same equation lhs.
@@ -125,7 +129,7 @@ let filter_original n vl =
if vdecl.var_orig then v :: res else res) vl []
let schedule_node n =
- let node_vars = get_node_vars n in
+ (* let node_vars = get_node_vars n in *)
try
let eq_equiv = ExprDep.node_eq_equiv n in
let eq_equiv v1 v2 =
@@ -134,13 +138,6 @@ let schedule_node n =
with Not_found -> false in
let n', g = global_dependency n in
- Log.report ~level:5
- (fun fmt ->
- Format.fprintf fmt
- "dependency graph for node %s: %a"
- n'.node_id
- pp_dep_graph g
- );
(* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs
compute: coi predecessors of outputs
@@ -152,17 +149,17 @@ let schedule_node n =
let sort = topological_sort eq_equiv g in
let unused = Liveness.compute_unused_variables n gg in
let fanin = Liveness.compute_fanin n gg in
+ { node = n'; schedule = sort; unused_vars = unused; fanin_table = fanin; dep_graph = gg; }
- let (disjoint, reuse) =
- if !Options.optimization >= 3
- then
- let disjoint = Disjunction.clock_disjoint_map node_vars in
- (disjoint,
- Liveness.compute_reuse_policy n sort disjoint gg)
- else
- (Hashtbl.create 1,
- Hashtbl.create 1) in
+ with (Causality.Cycle vl) as exc ->
+ let vl = filter_original n vl in
+ pp_error Format.err_formatter vl;
+ raise exc
+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
@@ -186,24 +183,44 @@ let schedule_node n =
Liveness.pp_reuse_policy reuse
);
end;
- n', { schedule = sort; unused_vars = unused; fanin_table = fanin; reuse_table = reuse }
- with (Causality.Cycle vl) as exc ->
- let vl = filter_original n vl in
- pp_error Format.err_formatter vl;
- raise exc
+*)
+ reuse
+
let schedule_prog prog =
List.fold_right (
fun top_decl (accu_prog, sch_map) ->
match top_decl.top_decl_desc with
| Node nd ->
- let nd', report = schedule_node nd in
- {top_decl with top_decl_desc = Node nd'}::accu_prog,
+ 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)
+
+
+let compute_prog_reuse_table report =
+ IMap.map compute_node_reuse_table report
+
+(* 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
+
+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
@@ -222,7 +239,13 @@ let pp_schedule fmt node_schs =
let pp_fanin_table fmt node_schs =
IMap.iter
(fun nd report ->
- Format.fprintf fmt "%s : %a" nd Liveness.pp_fanin report.fanin_table)
+ Format.fprintf fmt "%s: %a" nd Liveness.pp_fanin report.fanin_table)
+ 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)
node_schs
let pp_warning_unused fmt node_schs =
@@ -241,6 +264,7 @@ let pp_warning_unused fmt node_schs =
)
node_schs
+
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/splitting.ml b/src/splitting.ml
index e830b614..a41001d3 100644
--- a/src/splitting.ml
+++ b/src/splitting.ml
@@ -21,7 +21,7 @@ let rec tuple_split_expr expr =
| Expr_ident _ -> [expr]
| Expr_tuple elist -> elist
| Expr_appl (id, args, r) ->
- if Basic_library.is_internal_fun id
+ if Basic_library.is_homomorphic_fun id
then
let args_list = List.map tuple_split_expr (expr_list_of_expr args) in
List.map
diff --git a/src/stateless.ml b/src/stateless.ml
index 3148e032..5ec30d4f 100755
--- a/src/stateless.ml
+++ b/src/stateless.ml
@@ -34,7 +34,7 @@ let rec check_expr expr =
| Expr_merge (i, hl) -> List.for_all (fun (t, h) -> check_expr h) hl
| Expr_appl (i, e', i') ->
check_expr e' &&
- (Basic_library.is_internal_fun i || check_node (node_from_name i))
+ (Basic_library.is_stateless_fun i || check_node (node_from_name i))
and compute_node nd =
List.for_all (fun eq -> check_expr eq.eq_rhs) (get_node_eqs nd)
and check_node td =
@@ -56,6 +56,17 @@ and check_node td =
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 -> (
+ nd.node_dec_stateless <- 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 ->
diff --git a/src/type_predef.ml b/src/type_predef.ml
index 0690be22..e9c1cfb2 100755
--- a/src/type_predef.ml
+++ b/src/type_predef.ml
@@ -26,7 +26,6 @@ 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))
diff --git a/src/types.ml b/src/types.ml
index 299131ff..efa4aaa0 100755
--- a/src/types.ml
+++ b/src/types.ml
@@ -198,14 +198,30 @@ let get_field_type ty label =
| Tstruct fl -> (try Some (List.assoc label fl) with Not_found -> None)
| _ -> None
-let is_numeric_type ty =
+let rec is_scalar_type ty =
+ match (repr ty).tdesc with
+ | Tstatic (_, ty) -> is_scalar_type ty
+ | Tbool
+ | Tint
+ | Treal -> true
+ | _ -> false
+
+let rec is_numeric_type ty =
match (repr ty).tdesc with
+ | Tstatic (_, ty) -> is_numeric_type ty
| Tint
| Treal -> true
| _ -> false
-let is_bool_type ty =
+let rec is_real_type ty =
+ match (repr ty).tdesc with
+ | Tstatic (_, ty) -> is_real_type ty
+ | Treal -> true
+ | _ -> false
+
+let rec is_bool_type ty =
match (repr ty).tdesc with
+ | Tstatic (_, ty) -> is_bool_type ty
| Tbool -> true
| _ -> false
@@ -288,7 +304,7 @@ let rec array_base_type ty =
| _ -> ty
let is_address_type ty =
- is_array_type ty || is_struct_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
@@ -313,10 +329,11 @@ let type_of_type_list tyl =
else
List.hd tyl
-let type_list_of_type ty =
+let rec type_list_of_type ty =
match (repr ty).tdesc with
- | Ttuple tl -> tl
- | _ -> [ty]
+ | 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 =
diff --git a/src/typing.ml b/src/typing.ml
index 747240ee..a1cc9fe3 100755
--- a/src/typing.ml
+++ b/src/typing.ml
@@ -103,7 +103,7 @@ let rec type_coretype type_dim cty =
| Tydec_any -> new_var ()
| Tydec_int -> Type_predef.type_int
| Tydec_real -> Type_predef.type_real
- | Tydec_float -> 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
@@ -261,7 +261,7 @@ and type_const loc c =
match c with
| Const_int _ -> Type_predef.type_int
| Const_real _ -> Type_predef.type_real
- | Const_float _ -> Type_predef.type_real
+ (* | Const_float _ -> 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 loc e) loc) ca;
@@ -344,7 +344,7 @@ and type_subtyping_arg env in_main ?(sub=true) const real_arg formal_type =
*)
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_internal_fun f && List.exists is_tuple_type targs
+ 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
@@ -367,10 +367,8 @@ and type_dependent_call env in_main loc const f targs =
begin
List.iter2 (fun (a,t) ti ->
let t' = type_add_const env (const || Types.get_static_value ti <> None) a t
- in try_unify ~sub:true ti t' a.expr_loc;
- ) targs tins;
-(*Format.eprintf "Typing.type_dependent_call END@.";*)
- touts;
+ in try_unify ~sub:true ti t' a.expr_loc) targs tins;
+ touts
end
(* type a simple call without dependent types
@@ -575,14 +573,13 @@ let type_var_decl vd_env env vdecl =
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_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
+ then Type_predef.type_static (Dimension.mkdim_var ()) ty
else ty in
(match vdecl.var_dec_value with
| None -> ()
@@ -680,19 +677,19 @@ let type_top_consts 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 (loc, err) as exc -> (
- (*if !Options.global_inline then
- Format.eprintf "Type error: failing node@.%a@.@?"
- Printers.pp_node nd
- ;*)
- raise exc)
+ try
+ type_node env nd decl.top_decl_loc
+ with Error (loc, err) 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
+ type_imported_node env nd decl.top_decl_loc
| Const c ->
- type_top_const env c
+ type_top_const env c
| TypeDef _ -> List.fold_left type_top_decl env (consts_of_enum_type decl)
| Open _ -> env
diff --git a/src/utils.ml b/src/utils.ml
index 7be8bb14..ee8d9dd6 100755
--- a/src/utils.ml
+++ b/src/utils.ml
@@ -36,7 +36,8 @@ module IMap = Map.Make(IdentModule)
module ISet = Set.Make(IdentModule)
-let desome x = match x with Some x -> x | None -> failwith "desome"
+exception DeSome
+let desome x = match x with Some x -> x | None -> raise DeSome
let option_map f o =
match o with
diff --git a/test/tests_ok_dev.list b/test/tests_ok_dev.list
deleted file mode 100644
index 527cdab1..00000000
--- a/test/tests_ok_dev.list
+++ /dev/null
@@ -1,32 +0,0 @@
-./tests/tuples/tuples1.lus
-./tests/tuples/tuples2.lus
-./tests/arrays_arnaud/dummy_lib.lusi
-./tests/arrays_arnaud/arrays.lus,,-check-access
-./tests/arrays_arnaud/RelOpMatrix.lus
-./tests/arrays_arnaud/access1.lus,,-check-access
-./tests/arrays_arnaud/generic1.lus,,-lusi
-./tests/arrays_arnaud/generic1.lusi
-./tests/arrays_arnaud/generic1.lus
-./tests/arrays_arnaud/generic2.lus
-./tests/arrays_arnaud/generic3.lus,top,-dynamic -check-access
-./tests/clocks/clocks1.lus,,-lusi
-./tests/clocks/clocks1.lusi
-./tests/clocks/clocks1.lus
-./tests/clocks/clocks2.lus
-./tests/clocks/clocks6.lus
-./tests/clocks/clocks7.lus
-./tests/clocks/clocks8.lus
-./tests/clocks/clocks9.lus
-./tests/clocks/oversampling0.lus,,-lusi
-./tests/clocks/oversampling0.lusi
-./tests/clocks/oversampling0.lus
-./tests/lusic/test2.lusi
-./tests/lusic/test1.lusi
-./tests/lusic/test1.lus,as_soon_as
-./tests/lusic/test2.lus
-./tests/automata/aut1.lus
-./tests/automata/heater3.lus
-./tests/automata/heater4.lus
-./tests/linear_ctl/libarrays.lusi
-./tests/linear_ctl/ex1_mat.lus
-./tests/linear_ctl/ex1_mat_xt.lus
--
GitLab