From c4a6b83fdc88a70c98d22f87d6fdcd8416b473f6 Mon Sep 17 00:00:00 2001 From: Adrien Guatto Date: Tue, 15 Jun 2010 10:49:03 +0200 Subject: [PATCH] Initial commit --- Makefile | 228 ++++++ _tags | 4 + global/global.ml | 68 ++ global/ident.ml | 71 ++ global/ident.mli | 35 + global/initial.ml | 31 + global/location.ml | 157 ++++ global/modules.ml | 155 ++++ global/names.ml | 41 + global/static.ml | 176 +++++ heptagon/analysis/automata_mem.ml | 43 + heptagon/analysis/causal.ml | 280 +++++++ heptagon/analysis/causality.ml | 214 +++++ heptagon/analysis/initialization.ml | 374 +++++++++ heptagon/analysis/interface.ml | 131 +++ heptagon/analysis/typing.ml | 932 ++++++++++++++++++++++ heptagon/heptagon.ml | 370 +++++++++ heptagon/main/compiler.ml | 0 heptagon/main/hepcheck.ml | 0 heptagon/parsing/lexer.mll | 315 ++++++++ heptagon/parsing/parser.mly | 607 ++++++++++++++ heptagon/parsing/parsetree.ml | 195 +++++ heptagon/parsing/scoping.ml | 334 ++++++++ heptagon/printer.ml | 459 +++++++++++ heptagon/transformations/automata.ml | 204 +++++ heptagon/transformations/completion.ml | 86 ++ heptagon/transformations/every.ml | 175 ++++ heptagon/transformations/last.ml | 111 +++ heptagon/transformations/present.ml | 73 ++ heptagon/transformations/reset.ml | 266 +++++++ main/compiler.ml | 345 ++++++++ main/hept2mls.ml | 468 +++++++++++ main/main.ml | 100 +++ minils/minils.ml | 753 ++++++++++++++++++ minils/sequential/c.ml | 337 ++++++++ minils/sequential/c.mli | 131 +++ minils/sequential/cgen.ml | 1008 ++++++++++++++++++++++++ minils/sequential/control.ml | 81 ++ minils/sequential/csubst.ml | 65 ++ minils/sequential/java.ml | 596 ++++++++++++++ minils/sequential/mls2obc.ml | 414 ++++++++++ minils/sequential/obc.ml | 433 ++++++++++ minils/transformations/callgraph.ml | 127 +++ minils/transformations/clocking.ml | 295 +++++++ minils/transformations/init.ml | 314 ++++++++ minils/transformations/normalize.ml | 261 ++++++ minils/transformations/schedule.ml | 86 ++ myocamlbuild.ml | 26 + utilities/dep.ml | 80 ++ utilities/graph.ml | 143 ++++ utilities/misc.ml | 204 +++++ utilities/misc.mli | 158 ++++ 52 files changed, 12560 insertions(+) create mode 100644 Makefile create mode 100644 _tags create mode 100644 global/global.ml create mode 100644 global/ident.ml create mode 100644 global/ident.mli create mode 100644 global/initial.ml create mode 100644 global/location.ml create mode 100644 global/modules.ml create mode 100644 global/names.ml create mode 100644 global/static.ml create mode 100644 heptagon/analysis/automata_mem.ml create mode 100644 heptagon/analysis/causal.ml create mode 100644 heptagon/analysis/causality.ml create mode 100644 heptagon/analysis/initialization.ml create mode 100644 heptagon/analysis/interface.ml create mode 100644 heptagon/analysis/typing.ml create mode 100644 heptagon/heptagon.ml create mode 100644 heptagon/main/compiler.ml create mode 100644 heptagon/main/hepcheck.ml create mode 100644 heptagon/parsing/lexer.mll create mode 100644 heptagon/parsing/parser.mly create mode 100644 heptagon/parsing/parsetree.ml create mode 100644 heptagon/parsing/scoping.ml create mode 100644 heptagon/printer.ml create mode 100644 heptagon/transformations/automata.ml create mode 100644 heptagon/transformations/completion.ml create mode 100644 heptagon/transformations/every.ml create mode 100644 heptagon/transformations/last.ml create mode 100644 heptagon/transformations/present.ml create mode 100644 heptagon/transformations/reset.ml create mode 100644 main/compiler.ml create mode 100644 main/hept2mls.ml create mode 100644 main/main.ml create mode 100644 minils/minils.ml create mode 100644 minils/sequential/c.ml create mode 100644 minils/sequential/c.mli create mode 100644 minils/sequential/cgen.ml create mode 100644 minils/sequential/control.ml create mode 100644 minils/sequential/csubst.ml create mode 100644 minils/sequential/java.ml create mode 100644 minils/sequential/mls2obc.ml create mode 100644 minils/sequential/obc.ml create mode 100644 minils/transformations/callgraph.ml create mode 100644 minils/transformations/clocking.ml create mode 100644 minils/transformations/init.ml create mode 100644 minils/transformations/normalize.ml create mode 100644 minils/transformations/schedule.ml create mode 100644 myocamlbuild.ml create mode 100644 utilities/dep.ml create mode 100644 utilities/graph.ml create mode 100644 utilities/misc.ml create mode 100644 utilities/misc.mli diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..cd9d19b --- /dev/null +++ b/Makefile @@ -0,0 +1,228 @@ +# $Id$ + +DATE = \`eval date\` +LIBDIR = \`eval pwd\`/../lib +BIN = hec +TARGET = opt + +OCAMLFLAGS = -dtypes -g +OCAMLOPTFLAGS = -dtypes -g +CPP = cpp +#gcc -E +CPPFLAGS = -P +SED=sed + +# lablgtk +LABLGTKPREFIX = /usr/lib/ocaml +LABLGTKFLAGS = -I $(LABLGTKPREFIX)/lablgtk2 -I $(LABLGTKPREFIX)/stublibs +LABLGTKLINKFLAGS = -dllpath $(LABLGTKPREFIX)/stublibs + +OCAMLC = ocamlc +OCAMLLEX = ocamllex +OCAMLYACC = ocamlyacc +OCAMLOPT = ocamlopt +OCAMLDEP = ocamldep + +UNIX = str.cma unix.cma +UNIXX = str.cmxa unix.cmxa +INCLUDES = + +DIRECTORIES = global parsing analysis translation dataflow sigali sequential \ + simulation main + +INCLUDES = $(DIRECTORIES:%=-I %) + +GENSOURCES = parsing/lexer.ml parsing/parser.mli parsing/parser.ml + +GLOBAL = global/names.cmo \ + global/ident.cmo \ + global/static.cmo \ + global/location.cmo \ + global/misc.cmo \ + global/linearity.cmo \ + global/graph.cmo \ + global/dep.cmo \ + global/parsetree.cmo \ + global/heptagon.cmo \ + global/global.cmo \ + global/modules.cmo \ + global/printer.cmo \ + global/initial.cmo \ + global/interference_graph.cmo \ + global/scoping.cmo +PARSING = parsing/lexer.cmo \ + parsing/parser.cmo +ANALYSIS = analysis/typing.cmo \ + analysis/causal.cmo \ + analysis/causality.cmo \ + analysis/interface.cmo \ + analysis/initialization.cmo \ + analysis/linear_typing.cmo \ + analysis/automata_mem.cmo +TRANSLATION = translation/completion.cmo \ + translation/automata.cmo \ + translation/present.cmo \ + translation/last.cmo \ + translation/reset.cmo \ + translation/reset_new.cmo \ + translation/every.cmo +# translation/inline.cmo +DATAFLOW = dataflow/minils.cmo \ + dataflow/merge.cmo \ + dataflow/dfcausality.cmo \ + dataflow/normalize.cmo \ + dataflow/schedule.cmo \ + dataflow/clocking.cmo \ + dataflow/intermediate.cmo \ + dataflow/cse.cmo \ + dataflow/cmse.cmo \ + dataflow/tomato.cmo \ + dataflow/tommls.cmo \ + dataflow/deadcode.cmo \ + dataflow/mls2dot.cmo \ + dataflow/interference2dot.cmo \ + dataflow/interference.cmo \ + dataflow/memalloc.cmo \ + dataflow/splitting.cmo \ + dataflow/schedule_interf.cmo \ + dataflow/callgraph.cmo +# dataflow/init.cmo +SIGALI = sigali/boolean.cmo \ + sigali/sigali.cmo \ + sigali/dynamic_system.cmo +SEQUENTIAL = sequential/obc.cmo \ + sequential/control.cmo \ + sequential/translate.cmo \ + sequential/c_old.cmo \ + sequential/caml.cmo \ + sequential/java.cmo \ + sequential/c.cmo \ + sequential/csubst.cmo \ + sequential/rename.cmo \ + sequential/cgen.cmo \ + sequential/vhdl.cmo \ + sequential/mls2vhdl.cmo +# sequential/lustre.cmo +MAIN = main/compiler.cmo \ + main/main.cmo + +OBJ = $(GLOBAL) $(MODULES) $(PARSING) $(ANALYSIS) $(TRANSLATION) \ + $(DATAFLOW) $(SEQUENTIAL) $(MAIN) \ + $(SIMULATION) + +OBJ_OPT = $(OBJ:.cmo=.cmx) + +SRC = $(OBJ:.cmo=.ml) + +INTERFACES = $(SRC:.ml=.mli) + +SIM_BIN = hes + +# Objs needed for compiling simulator +SIM_OBJ = global/misc.cmo \ + global/heptagon.cmo \ + global/global.cmo \ + global/modules.cmo \ + simulation/simulator.cmo +SIM_LIBS = lablgtk.cma unix.cma + +SIM_OBJ_OPT = $(SIM_OBJ:.cmo=.cmx) + +SIM_LIBS_OPT = $(SIM_LIBS:.cma=.cmxa) + +world: all + +all: $(TARGET) + +opt: $(BIN).opt +byte: $(BIN).byte + +$(BIN).opt: $(OBJ_OPT) + $(OCAMLOPT) $(UNIXX) $(OCAMLOPTFLAGS) $(INCLUDES) $(OBJ_OPT) -o $(BIN).opt + +$(BIN).byte: $(OBJ) + $(OCAMLC) -custom $(UNIX) $(OCAMLFLAGS) $(INCLUDES) $(OBJ) -o $(BIN).byte + +sim: $(SIM_BIN).byte +simopt:$(SIM_BIN).opt + +$(SIM_BIN).opt: $(SIM_OBJ_OPT) + $(OCAMLOPT) $(OCAMLOPTFLAGS) \ + $(LABLGTKFLAGS) \ + $(INCLUDES) $(SIM_LIBS_OPT) $(SIM_OBJ_OPT) -o $(SIM_BIN).opt +$(SIM_BIN).byte: $(SIM_OBJ) + $(OCAMLC) -custom $(UNIX) $(OCAMLFLAGS) \ + $(LABLGTKFLAGS) $(LABLGTKLINKFLAGS) \ + $(INCLUDES) $(SIM_LIBS) $(SIM_OBJ) -o $(SIM_BIN).byte + + +debug: OCAMLFLAGS += -g +debug: byte + +profile: OCAMLOPTFLAGS += -p +profile: opt + +depend .depend: $(GENSOURCES) + (for d in $(DIRECTORIES); \ + do $(OCAMLDEP) $(INCLUDES) $$d/*.mli $$d/*.ml; \ + done) > .depend + +interfaces: $(INTERFACES) + +# Extra dependences +parsing/parser.mli parsing/parser.ml: parsing/parser.mly + $(OCAMLYACC) -v parsing/parser.mly + +parsing/lexer.cmi: parsing/parser.mli + +parsing/lexer.ml: parsing/lexer.mll + $(OCAMLLEX) parsing/lexer.mll + +global/misc.cmo: OCAMLFLAGS := \ + -pp "$(SED) -e \"s|DATE|`date`|\" -e \"s|STDLIB|$(LIBDIR)|\"" +# -pp "$(CPP) $(CPPFLAGS) -DSTDLIB=\\\"$(LIBDIR)\\\" \ +# -DDATE=\\\"\"`date`\"\\\"" + +global/misc.cmx: OCAMLOPTFLAGS := \ + -pp "$(SED) -e \"s|DATE|`date`|\" -e \"s|STDLIB|$(LIBDIR)|\"" +# -pp "$(CPP) $(CPPFLAGS) -DSTDLIB=\\\"$(LIBDIR)\\\" \ +# -DDATE=\\\"\"`date`\"\\\"" + +simulation/simulator.cmo: OCAMLFLAGS += $(LABLGTKFLAGS) + +simulation/simulator.cmx: OCAMLOPTFLAGS += $(LABLGTKFLAGS) + +# Common rules +.SUFFIXES : .mli .ml .cmi .cmo .cmx + +%.cmo: %.ml + $(OCAMLC) $(OCAMLFLAGS) -c $(INCLUDES) $< + +%.cmi: %.mli + $(OCAMLC) $(OCAMLFLAGS) -c $(INCLUDES) $< + +%.cmx: %.ml + $(OCAMLOPT) $(OCAMLOPTFLAGS) -c $(INCLUDES) $< + +# %.mli: %.ml +# $(OCAMLC) $(OCAMLFLAGS) -i -c $(INCLUDES) $< > $@ + + + +# Clean up +clean: + rm -f $(GENSOURCES) parsing/parser.output + # to avoid the make warnings: + rm -f parsing/parser.ml + rm -f parsing/lexer.ml + (for d in $(DIRECTORIES); \ + do rm -f $$d/*.annot $$d/*.cm[iox] $$d/*.o; \ + done) + rm -f $(BIN).byte $(BIN).opt + +ML = $(OBJ:.cmo=.ml) + +wc: + wc $(ML) + +include .depend diff --git a/_tags b/_tags new file mode 100644 index 0000000..16cdbb4 --- /dev/null +++ b/_tags @@ -0,0 +1,4 @@ +<**/*.ml>: debug, dtypes +: camlp4o, use_preproc +: camlp4of, use_camlp4 +<**/*.{byte,native}>: use_unix, use_str, debug diff --git a/global/global.ml b/global/global.ml new file mode 100644 index 0000000..b6b9645 --- /dev/null +++ b/global/global.ml @@ -0,0 +1,68 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* global data in the symbol tables *) +(* $Id$ *) +open Names +open Ident +open Linearity +open Heptagon +open Static + +(** Warning: Whenever these types are modified, + interface_format_version in misc.ml should be incremented. *) +type arg_dec = + { a_type : ty; + a_name : name option; + a_linearity : linearity; + a_pass_by_ref: bool; } + +type sig_desc = + { inputs : arg_dec list; + outputs : arg_dec list; + contract : contract option; + node : bool; + safe : bool; + targeting : (int*int) list; + params: name list; + params_constraints : size_constr list; } + +and field_desc = + { arg: base_ty; (* if x:arg then x.m: res *) + res: base_ty; + } + +and struct_desc = + { fields : (name * base_ty) list; } + +and typ_desc = + | Tabstract + | Tenum of name list + | Tstruct of (name * base_ty) list + +type 'a info = { qualid : qualident; info : 'a } + +type ivar = + | IVar of ident + | IField of ident * longname + +(** [filter_vars l] returns a list of variables identifiers from + a list of ivar.*) +let rec filter_vars = function + | [] -> [] + | (IVar id)::l -> id::(filter_vars l) + | _::l -> filter_vars l + +let names l = + List.map (fun ad -> ad.a_name) l + +let types l = + List.map (fun ad -> ad.a_type) l + +let linearities l = + List.map (fun ad -> ad.a_linearity) l diff --git a/global/ident.ml b/global/ident.ml new file mode 100644 index 0000000..43c5f6d --- /dev/null +++ b/global/ident.ml @@ -0,0 +1,71 @@ +(* naming and local environment *) + +type ident = { + num : int; (* a unique index *) + source : string; (* the original name in the source *) + is_generated : bool; +} + +let compare id1 id2 = compare id1.num id2.num +let sourcename id = id.source +let name id = + if id.is_generated then + id.source ^ "_" ^ (string_of_int id.num) + else + id.source + +let set_sourcename id v = + { id with source = v } + +let num = ref 0 +let fresh s = + num := !num + 1; + { num = !num; source = s; is_generated = true } + +let ident_of_var s = + num := !num + 1; + { num = !num; source = s; is_generated = false } + +let fprint_t ff id = Format.fprintf ff "%s" (name id) + +module M = struct + type t = ident + let compare = compare + let fprint = fprint_t +end + +module Env = +struct + include (Map.Make(M)) + + let append env0 env = + fold (fun key v env -> add key v env) env0 env + + (* Environments union *) + let union env1 env2 = + fold (fun name elt env -> add name elt env) env2 env1 + + (* Environments difference : env1 - env2 *) + let diff env1 env2 = + fold (fun name _ env -> remove name env) env2 env1 + + (* Environments partition *) + let partition p env = + fold + (fun key elt (env1,env2) -> + if p(key) + then ((add key elt env1),env2) + else (env1,(add key elt env2))) + env + (empty, empty) +end + +module IdentSet = struct + include (Set.Make(M)) + + let fprint_t ff s = + Format.fprintf ff "@[{@ "; + iter (fun e -> Format.fprintf ff "%a@ " M.fprint e) s; + Format.fprintf ff "}@]"; +end + diff --git a/global/ident.mli b/global/ident.mli new file mode 100644 index 0000000..b609d1f --- /dev/null +++ b/global/ident.mli @@ -0,0 +1,35 @@ +(** The (abstract) type of identifiers*) +type ident + +(** Get the source name from an identifier*) +val sourcename : ident -> string +(** Get the full name of an identifier (it is + guaranteed to be unique)*) +val name : ident -> string +(** [set_sourcename id v] returns id with its + source name changed to v. *) +val set_sourcename : ident -> string -> ident + +(** [fresh n] returns a fresh identifier with source name n *) +val fresh : string -> ident +(** [ident_of_var n] returns an identifier corresponding + to a _source_ variable (do not use it for generated variables). *) +val ident_of_var : string -> ident + +(** Maps taking an identifier as a key. *) +module Env : + sig + include (Map.S with type key = ident) + + val append : 'a t -> 'a t -> 'a t + val union : 'a t -> 'a t -> 'a t + val diff : 'a t -> 'b t -> 'a t + val partition : (key -> bool) -> 'a t -> 'a t * 'a t + end + +(** A set of identifiers. *) +module IdentSet : + sig + include (Set.S with type elt = ident) + val fprint_t : Format.formatter -> t -> unit + end diff --git a/global/initial.ml b/global/initial.ml new file mode 100644 index 0000000..203ea3b --- /dev/null +++ b/global/initial.ml @@ -0,0 +1,31 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* initialization of the typing environment *) + +(* $Id$ *) + +open Misc +open Names +open Global +open Modules + +let tglobal = [] +let cglobal = [] + +let pbool = Modname({ qual = "Pervasives"; id = "bool" }) +let ptrue = Modname({ qual = "Pervasives"; id = "true" }) +let pfalse = Modname({ qual = "Pervasives"; id = "false" }) +let por = Modname({ qual = "Pervasives"; id = "or" }) +let pint = Modname({ qual = "Pervasives"; id = "int" }) +let pfloat = Modname({ qual = "Pervasives"; id = "float" }) + +(* build the initial environment *) +let initialize () = + List.iter (fun (f, ty) -> add_type f ty) tglobal; + List.iter (fun (f, ty) -> add_constr f ty) cglobal diff --git a/global/location.ml b/global/location.ml new file mode 100644 index 0000000..0056108 --- /dev/null +++ b/global/location.ml @@ -0,0 +1,157 @@ +(* Printing a location in the source program *) +(* taken from the source of the Caml Light 0.73 compiler *) + +(* $Id$ *) + +open Lexing +open Parsing + +(* two important global variables: [input_name] and [input_chan] *) +type location = + Loc of int (* Position of the first character *) + * int (* Position of the next character following the last one *) + + + +let input_name = ref "" (* Input file name. *) + +let input_chan = ref stdin (* The channel opened on the input. *) + +let initialize iname ic = + input_name := iname; + input_chan := ic + + +let no_location = Loc(0,0) + + +let error_prompt = ">" + +let get_current_location () = + Loc(symbol_start(), symbol_end()) + + +let output_lines oc char1 char2 charline1 line1 line2 = + let n1 = char1 - charline1 + and n2 = char2 - charline1 in + if line2 > line1 then + Printf.fprintf oc + ", line %d-%d, characters %d-%d:\n" line1 line2 n1 n2 + else + Printf.fprintf oc ", line %d, characters %d-%d:\n" line1 n1 n2; + () + + +let output_loc oc input seek line_flag (Loc(pos1, pos2)) = + let pr_chars n c = + for i = 1 to n do output_char oc c done in + let skip_line () = + try + while input() != '\n' do () done + with End_of_file -> () in + let copy_line () = + let c = ref ' ' in + begin try + while c := input(); !c != '\n' do output_char oc !c done + with End_of_file -> + output_string oc "" + end; + output_char oc '\n' in + let pr_line first len ch = + let c = ref ' ' + and f = ref first + and l = ref len in + try + while c := input (); !c != '\n' do + if !f > 0 then begin + f := !f - 1; + output_char oc (if !c == '\t' then !c else ' ') + end + else if !l > 0 then begin + l := !l - 1; + output_char oc (if !c == '\t' then !c else ch) + end + else () + done + with End_of_file -> + if !f = 0 && !l > 0 then pr_chars 5 ch in + let pos = ref 0 + and line1 = ref 1 + and line1_pos = ref 0 + and line2 = ref 1 + and line2_pos = ref 0 in + seek 0; + begin try + while !pos < pos1 do + incr pos; + if input() == '\n' then begin incr line1; line1_pos := !pos; () end + done + with End_of_file -> () + end; + line2 := !line1; + line2_pos := !line1_pos; + begin try + while !pos < pos2 do + incr pos; + if input() == '\n' then + begin incr line2; line2_pos := !pos; () end + done + with End_of_file -> () + end; + if line_flag then output_lines oc pos1 pos2 !line1_pos !line1 !line2; + if !line1 == !line2 then begin + seek !line1_pos; + output_string oc error_prompt; + copy_line (); + seek !line1_pos; + output_string oc error_prompt; + pr_line (pos1 - !line1_pos) (pos2 - pos1) '^'; + output_char oc '\n' + end else begin + seek !line1_pos; + output_string oc error_prompt; + pr_line 0 (pos1 - !line1_pos) '.'; + seek pos1; + copy_line(); + if !line2 - !line1 <= 8 then + for i = !line1 + 1 to !line2 - 1 do + output_string oc error_prompt; + copy_line() + done + else + begin + for i = !line1 + 1 to !line1 + 3 do + output_string oc error_prompt; + copy_line() + done; + output_string oc error_prompt; output_string oc "..........\n"; + for i = !line1 + 4 to !line2 - 4 do skip_line() done; + for i = !line2 - 3 to !line2 - 1 do + output_string oc error_prompt; + copy_line() + done + end; + begin try + output_string oc error_prompt; + for i = !line2_pos to pos2 - 1 do + output_char oc (input()) + done; + pr_line 0 100 '.' + with End_of_file -> output_string oc "" + end; + output_char oc '\n' + end + + +let output_location oc loc = + let p = pos_in !input_chan in + Printf.fprintf oc "File \"%s\"" !input_name; + output_loc + oc (fun () -> input_char !input_chan) (seek_in !input_chan) true + loc; + seek_in !input_chan p + + +let output_input_name oc = + Printf.fprintf oc "File \"%s\", line 1:\n" !input_name + diff --git a/global/modules.ml b/global/modules.ml new file mode 100644 index 0000000..ba3915b --- /dev/null +++ b/global/modules.ml @@ -0,0 +1,155 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* global symbol tables *) + +(* $Id$ *) + +open Misc +open Heptagon +open Global +open Names + +exception Already_defined + +exception Cannot_find_file of string + +(** Warning: Whenever this type is modified, + interface_format_version in misc.ml should be incremented. *) +type env = + { mutable name: string; + mutable values: sig_desc NamesEnv.t; + mutable types: typ_desc NamesEnv.t; + mutable constr: base_ty NamesEnv.t; + mutable field: field_desc NamesEnv.t; + mutable structs : struct_desc NamesEnv.t; + format_version : string; + } + +type modules = + { current: env; (* associated symbol table *) + mutable opened: env list; (* opened tables *) + mutable modules: env NamesEnv.t; (* tables loaded in memory *) + } + +let current = + { name = ""; values = NamesEnv.empty; types = NamesEnv.empty; + constr = NamesEnv.empty; field = NamesEnv.empty; structs = NamesEnv.empty; + format_version = interface_format_version } + +let modules = + { current = current; opened = []; modules = NamesEnv.empty } + +let findfile filename = + if Sys.file_exists filename then + filename + else if not(Filename.is_implicit filename) then + raise(Cannot_find_file filename) + else + let rec find = function + [] -> + raise(Cannot_find_file filename) + | a::rest -> + let b = Filename.concat a filename in + if Sys.file_exists b then b else find rest + in find !load_path + +let load_module modname = + let name = String.uncapitalize modname in + try + let filename = findfile (name ^ ".epci") in + let ic = open_in_bin filename in + try + let m:env = input_value ic in + if m.format_version <> interface_format_version then ( + Printf.eprintf "The file %s was compiled with \ + an older version of the compiler.\n \ + Please recompile %s.ept first.\n" filename name; + raise Error + ); + close_in ic; + m + with + | End_of_file | Failure _ -> + close_in ic; + Printf.eprintf "Corrupted compiled interface file %s.\n\ + Please recompile %s.ept first.\n" filename name; + raise Error + with + | Cannot_find_file(filename) -> + Printf.eprintf "Cannot find the compiled interface file %s.\n" + filename; + raise Error + +let find_module modname = + try + NamesEnv.find modname modules.modules + with + Not_found -> + let m = load_module modname in + modules.modules <- NamesEnv.add modname m modules.modules; + m + +let find where qualname = + let rec findrec ident = function + | [] -> raise Not_found + | m :: l -> + try { qualid = { qual = m.name; id = ident }; + info = where ident m } + with Not_found -> findrec ident l in + + match qualname with + | Modname({ qual = m; id = ident } as q) -> + let current = if current.name = m then current else find_module m in + { qualid = q; info = where ident current } + | Name(ident) -> findrec ident (current :: modules.opened) + +(* exported functions *) +let open_module modname = + let m = find_module modname in + modules.opened <- m :: modules.opened + +let initialize modname = + current.name <- modname; + List.iter open_module !default_used_modules + +let add_value f signature = + if NamesEnv.mem f current.values then raise Already_defined; + current.values <- NamesEnv.add f signature current.values +let add_type f typ_desc = + if NamesEnv.mem f current.types then raise Already_defined; + current.types <- NamesEnv.add f typ_desc current.types +let add_constr f ty_res = + if NamesEnv.mem f current.constr then raise Already_defined; + current.constr <- NamesEnv.add f ty_res current.constr +let add_field f ty_arg ty_res = + if NamesEnv.mem f current.field then raise Already_defined; + current.field <- NamesEnv.add f { arg = ty_arg; res = ty_res } current.field +let add_struct f fields = + if NamesEnv.mem f current.structs then raise Already_defined; + current.structs <- NamesEnv.add f { fields = fields } current.structs + +let find_value = find (fun ident m -> NamesEnv.find ident m.values) +let find_type = find (fun ident m -> NamesEnv.find ident m.types) +let find_constr = find (fun ident m -> NamesEnv.find ident m.constr) +let find_field = find (fun ident m -> NamesEnv.find ident m.field) +let find_struct = find (fun ident m -> NamesEnv.find ident m.structs) + +let replace_value f signature = + current.values <- NamesEnv.remove f current.values; + current.values <- NamesEnv.add f signature current.values + +let write oc = output_value oc current + +let longname n = Modname({ qual = current.name; id = n }) +let currentname longname = + match longname with + | Name(n) -> longname + | Modname{ qual = q; id = id} -> + if current.name = q then Name(id) else longname + diff --git a/global/names.ml b/global/names.ml new file mode 100644 index 0000000..e125d6d --- /dev/null +++ b/global/names.ml @@ -0,0 +1,41 @@ +(* long identifiers *) + +type name = string + +type longname = + | Name of name + | Modname of qualident + +and qualident = { qual: string; id: string } + +module NamesM = struct + type t = name + let compare = compare +end + +module NamesEnv = +struct + include (Map.Make(NamesM)) + + let append env0 env = + fold (fun key v env -> add key v env) env0 env +end + +module S = Set.Make (struct type t = string let compare = compare end) + +let shortname = function + | Name s -> s + | Modname { id = id; } -> id + +let fullname = function + | Name s -> s + | Modname { qual = qual; id = id; } -> qual ^ "." ^ id + +let mk_longname s = + try + let ind = String.index s '.' in + let id = String.sub s (ind + 1) (String.length s - ind - 1) in + Modname { qual = String.sub s 0 ind; id = id; } + with Not_found -> Name s + +let fprint_t ff id = Format.fprintf ff "%s" (fullname id) diff --git a/global/static.ml b/global/static.ml new file mode 100644 index 0000000..31d021f --- /dev/null +++ b/global/static.ml @@ -0,0 +1,176 @@ +(** This module defines static expressions, used in arrays definition and anywhere + a static value is expected. For instance: + const n:int = 3; + var x : int^n; var y : int^(n+2); + x[n-1], x[1+3],... +*) +open Names +open Format + +type op = SPlus | SMinus | STimes | SDiv + +type size_exp = + | SConst of int + | SVar of name + | SOp of op * size_exp * size_exp + +(** Constraints on size expressions. *) +type size_constr = + | Equal of size_exp * size_exp (* e1 = e2*) + | LEqual of size_exp * size_exp (* e1 <= e2 *) + | False (* unsatisfiable constraint *) + +exception Instanciation_failed +exception Not_static + +(** Returns the op from an operator full name. *) +let op_from_app_name n = + match n with + | Modname({ qual = "Pervasives"; id = "+" }) | Name "+" -> SPlus + | Modname({ qual = "Pervasives"; id = "-" }) | Name "-" -> SMinus + | Modname({ qual = "Pervasives"; id = "*" }) | Name "*" -> STimes + | Modname({ qual = "Pervasives"; id = "/" }) | Name "/" -> SDiv + | _ -> raise Not_static + +(** [simplify env e] returns e simplified with the + variables values taken from env (mapping vars to integers). + Variables are replaced with their values and every operator + that can be computed is replaced with the value of the result. *) +let rec simplify env = function + | SConst n -> SConst n + | SVar id -> + (try + simplify env (NamesEnv.find id env) + with + _ -> SVar id + ) + | SOp(op, e1, e2) -> + let e1 = simplify env e1 in + let e2 = simplify env e2 in + (match e1, e2 with + | SConst n1, SConst n2 -> + let n = (match op with + | SPlus -> n1 + n2 + | SMinus -> n1 - n2 + | STimes -> n1 * n2 + | SDiv -> + if n2 = 0 then + raise Instanciation_failed + else + n1 / n2 + ) in + SConst n + | _, _ -> SOp(op, e1, e2) + ) + +(** [int_of_size_exp env e] returns the value of the expression + [e] in the environment [env], mapping vars to integers. Raises + Instanciation_failed if it cannot be computed (if a var has no value).*) +let int_of_size_exp env e = + match simplify env e with + | SConst n -> n + | _ -> raise Instanciation_failed + +(** [is_true env constr] returns whether the constraint is satisfied + in the environment (or None if this can be decided) + and a simplified constraint. *) +let is_true env = function + | Equal (e1,e2) when e1 = e2 -> + Some true, Equal (simplify env e1, simplify env e2) + | Equal (e1, e2) -> + let e1 = simplify env e1 in + let e2 = simplify env e2 in + (match e1, e2 with + | SConst n1, SConst n2 -> + Some (n1 = n2), Equal (e1,e2) + | _, _ -> None, Equal (e1,e2) + ) + | LEqual (e1, e2) -> + let e1 = simplify env e1 in + let e2 = simplify env e2 in + (match e1, e2 with + | SConst n1, SConst n2 -> + Some (n1 <= n2), LEqual (e1,e2) + | _, _ -> None, LEqual (e1,e2) + ) + | False -> None, False + +exception Solve_failed of size_constr +(** [solve env constr_list solves a list of constraints. It + removes equations that can be decided and simplify others. + If one equation cannot be satisfied, it raises Solve_failed. ]*) +let rec solve const_env = function + | [] -> [] + | c::l -> + let l = solve const_env l in + let res, c = is_true const_env c in + (match res with + | None -> c::l + | Some v -> if not v then raise (Solve_failed c) else l + ) + +(** Substitutes variables in the size exp with their value + in the map (mapping vars to size exps). *) +let rec size_exp_subst m = function + | SVar n -> + (try + List.assoc n m + with + Not_found -> SVar n + ) + | SOp(op,e1,e2) -> SOp(op, size_exp_subst m e1, size_exp_subst m e2) + | s -> s + +(** Substitutes variables in the constraint list with their value + in the map (mapping vars to size exps). *) +let instanciate_constr m constr = + let replace_one m = function + | Equal(e1,e2) -> Equal(size_exp_subst m e1, size_exp_subst m e2) + | LEqual(e1,e2) -> LEqual(size_exp_subst m e1, size_exp_subst m e2) + in + List.map (replace_one m) constr + +let op_to_string = function + | SPlus -> "+" + | SMinus -> "-" + | STimes -> "*" + | SDiv -> "/" + +let rec print_size_exp ff = function + | SConst i -> fprintf ff "%d" i + | SVar id -> fprintf ff "%s" id + | SOp (op, e1, e2) -> + fprintf ff "@[("; + print_size_exp ff e1; + fprintf ff " %s " (op_to_string op); + print_size_exp ff e2; + fprintf ff ")@]" + +let rec print_list ff print sep l = + match l with + | [] -> () + | [x] -> print ff x + | x :: l -> + print ff x; + fprintf ff "%s@ " sep; + print_list ff print sep l + +let print_size_constr ff = function + | Equal (e1, e2) -> + fprintf ff "@["; + print_size_exp ff e1; + fprintf ff " = "; + print_size_exp ff e2; + fprintf ff "@]" + | LEqual (e1, e2) -> + fprintf ff "@["; + print_size_exp ff e1; + fprintf ff " <= "; + print_size_exp ff e2; + fprintf ff "@]" + | False -> + fprintf ff "False" + +let psize_constr oc c = + let ff = formatter_of_out_channel oc in + print_size_constr ff c; fprintf ff "@?" diff --git a/heptagon/analysis/automata_mem.ml b/heptagon/analysis/automata_mem.ml new file mode 100644 index 0000000..57c61f5 --- /dev/null +++ b/heptagon/analysis/automata_mem.ml @@ -0,0 +1,43 @@ +open Ident +open Names +open Heptagon +open Interference_graph + +let node_for_name s g = + try + node_for_value g s + with + Not_found -> + let n = mk_node s in + add_node g n; + n + +let find_reset_jumps g sh = + let reset_escape state esc = + if esc.e_reset = true then + ( Format.printf "Jump from %s to %s with reset\n" state esc.e_next_state; + let n1 = node_for_name state g in + let n2 = node_for_name esc.e_next_state g in + add_interference_link n1 n2 + ) else + (Format.printf "Jump from %s to %s is not resetted\n" state esc.e_next_state; + let n1 = node_for_name state g in + let n2 = node_for_name esc.e_next_state g in + add_affinity_link n1 n2 + ) + in + List.iter (reset_escape sh.s_state) sh.s_until + +let share_eq g eq = + match eq.eq_desc with + | Eautomaton sh_list -> + List.iter (find_reset_jumps g) sh_list + | _ -> Format.printf "Ignoring unsupported eq\n" + +let node f = + let g = mk_graph [] f.n_name in + List.iter (share_eq g) f.n_equs; + { f with n_states_graph = g; } + +let program p = + { p with p_nodes = List.map node p.p_nodes } diff --git a/heptagon/analysis/causal.ml b/heptagon/analysis/causal.ml new file mode 100644 index 0000000..234d9fd --- /dev/null +++ b/heptagon/analysis/causal.ml @@ -0,0 +1,280 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* causality check of scheduling constraints *) + +(* $Id: causal.ml 615 2009-11-20 17:43:14Z pouzet $ *) + +open Misc +open Names +open Ident +open Heptagon +open Location +open Graph +open Format + +(* x = x + 1 is rejected because read(x) < write(x) is not causal *) +(* build a dependency graph an checks for cycles *) +(* for the moment, the # constructor is distributed which leads to a *) +(* sub-optimal algorithm. *) + +(* constraints [c] are normalised into [a1 # ... # an] st: *) +(* a ::= write(x) | read(x) | last(x) | a < a | a || a *) +(* c ::= a # ... # a *) +(* a constraint [a] is causal if its dependence graph is acyclic *) + +(* scheduling constraints *) +type sc = + | Cor of sc * sc + | Cand of sc * sc + | Cseq of sc * sc + | Ctuple of sc list + | Cwrite of ident + | Cread of ident + | Clinread of ident + | Clastread of ident + | Cempty + +(* normalized constraints *) +type ac = + | Awrite of ident + | Alinread of ident + | Aread of ident + | Alastread of ident + | Aseq of ac * ac + | Aand of ac * ac + | Atuple of ac list + +and nc = + | Aor of nc * nc + | Aac of ac + | Aempty + +let rec print_list ff print sep l = + match l with + | [] -> () + | [x] -> print ff x + | x :: l -> + print ff x; + fprintf ff "%s@ " sep; + print_list ff print sep l + +let output_ac ff ac = + let rec print priority ff ac = + fprintf ff "@["; + begin match ac with + | Aseq(ac1, ac2) -> + (if priority > 1 + then fprintf ff "(%a@ < %a)" + else fprintf ff "%a@ < %a") + (print 1) ac1 (print 1) ac2 + | Aand(ac1, ac2) -> + (if priority > 0 + then fprintf ff "(%a || %a)" + else fprintf ff "%a || %a") + (print 0) ac1 (print 0) ac2 + | Atuple(acs) -> + fprintf ff "("; + print_list ff (print 1) ", " acs ; + fprintf ff ")" + | Awrite(m) -> fprintf ff "%s" (sourcename m) + | Aread(m) -> fprintf ff "^%s" (sourcename m) + | Alinread(m) -> fprintf ff "*%s" (sourcename m) + | Alastread(m) -> fprintf ff "last %s" (sourcename m) + end; + fprintf ff "@]" in + fprintf ff "@[%a@]@?" (print 0) ac + + +type error = Ecausality_cycle of ac + +exception Error of error + +let error kind = raise (Error(kind)) + +let message loc kind = + let output_ac oc ac = + let ff = formatter_of_out_channel oc in output_ac ff ac in + begin match kind with + | Ecausality_cycle(ac) -> + Printf.eprintf + "%aCausality error: the following constraint is not causal.\n%a\n." + output_location loc + output_ac ac + end; + raise Misc.Error + +let cor nc1 nc2 = + match nc1, nc2 with + | Aempty, Aempty -> Aempty + | _ -> Aor(nc1, nc2) + +let rec cseq nc1 nc2 = + match nc1, nc2 with + | Aempty, _ -> nc2 + | _, Aempty -> nc1 + | Aor(nc1, nc11), nc2 -> Aor(cseq nc1 nc2, cseq nc11 nc2) + | nc1, Aor(nc2, nc22) -> Aor(cseq nc1 nc2, cseq nc1 nc22) + | Aac(ac1), Aac(ac2) -> Aac(Aseq(ac1, ac2)) + +let rec cand nc1 nc2 = + match nc1, nc2 with + | Aempty, _ -> nc2 | _, Aempty -> nc1 + | Aor(nc1, nc11), nc2 -> Aor(cand nc1 nc2, cand nc11 nc2) + | nc1, Aor(nc2, nc22) -> Aor(cand nc1 nc2, cand nc1 nc22) + | Aac(ac1), Aac(ac2) -> Aac(Aand(ac1, ac2)) + +let rec ctuple l = + let conv = function + | Cwrite(n) -> Awrite(n) + | Cread(n) -> Aread(n) + | Clinread(n) -> Alinread(n) + | Clastread(n) -> Alastread(n) + | Ctuple(l) -> Atuple (ctuple l) + | Cand _ -> Format.printf "Unexpected and\n"; assert false + | Cseq _ -> Format.printf "Unexpected seq\n"; assert false + | Cor _ -> Format.printf "Unexpected or\n"; assert false + | _ -> assert false + in + match l with + | [] -> [] + | Cempty::l -> ctuple l + | v::l -> (conv v)::(ctuple l) + +let rec norm = function + | Cor(c1, c2) -> cor (norm c1) (norm c2) + | Cand(c1, c2) -> cand (norm c1) (norm c2) + | Cseq(c1, c2) -> cseq (norm c1) (norm c2) + | Ctuple l -> Aac(Atuple (ctuple l)) + | Cwrite(n) -> Aac(Awrite(n)) + | Cread(n) -> Aac(Aread(n)) + | Clinread(n) -> Aac(Alinread(n)) + | Clastread(n) -> Aac(Alastread(n)) + | _ -> Aempty + +(* building a dependence graph from a scheduling constraint *) +let build ac = + (* associate a graph node for each name declaration *) + let nametograph n g n_to_graph = Env.add n g n_to_graph in + + let rec associate_node g (n_to_graph,lin_map) = function + | Awrite(n) -> + nametograph n g n_to_graph, lin_map + | Alinread(n) -> + n_to_graph, nametograph n g lin_map + | Atuple l -> + List.fold_left (associate_node g) (n_to_graph, lin_map) l + | _ -> + n_to_graph, lin_map + in + + (* first build the association [n -> node] *) + (* for every defined variable *) + let rec initialize ac n_to_graph lin_map = + match ac with + | Aand(ac1, ac2) -> + let n_to_graph, lin_map = initialize ac1 n_to_graph lin_map in + initialize ac2 n_to_graph lin_map + | Aseq(ac1, ac2) -> + let n_to_graph, lin_map = initialize ac1 n_to_graph lin_map in + initialize ac2 n_to_graph lin_map + | _ -> + let g = make ac in + associate_node g (n_to_graph, lin_map) ac + in + + let make_graph ac n_to_graph lin_map = + let attach node n = + try + let g = Env.find n n_to_graph in add_depends node g + with + | Not_found -> () in + + let attach_lin node n = + try + let g = Env.find n lin_map in add_depends g node + with + | Not_found -> () in + + let rec add_dependence g = function + | Aread(n) -> attach g n; attach_lin g n + | Alinread(n) -> let g = Env.find n lin_map in attach g n + | Atuple l -> List.iter (add_dependence g) l + | _ -> () + in + + let rec node_for_ac ac = + let rec node_for_tuple = function + | [] -> raise Not_found + | v::l -> + (try + node_for_ac v + with + Not_found -> node_for_tuple l + ) + in + match ac with + | Alinread n -> Env.find n lin_map + | Awrite n -> Env.find n n_to_graph + | Atuple l -> + begin try + node_for_tuple l + with Not_found + _ -> make ac + end + | _ -> make ac + in + + let rec make_graph ac = + match ac with + | Aand(ac1, ac2) -> + let top1, bot1 = make_graph ac1 in + let top2, bot2 = make_graph ac2 in + top1 @ top2, bot1 @ bot2 + | Aseq(ac1, ac2) -> + let top1, bot1 = make_graph ac1 in + let top2, bot2 = make_graph ac2 in + (* add extra dependences *) + List.iter + (fun top -> List.iter (fun bot -> add_depends top bot) bot1) + top2; + top1 @ top2, bot1 @ bot2 + | Awrite(n) -> let g = Env.find n n_to_graph in [g], [g] + | Aread(n) -> let g = make ac in attach g n; attach_lin g n; [g], [g] + | Alinread(n) -> let g = Env.find n lin_map in attach g n; [g], [g] + | Atuple(l) -> + let g = node_for_ac ac in + List.iter (add_dependence g) l; + [g], [g] + | _ -> [], [] in + let top_list, bot_list = make_graph ac in + graph top_list bot_list in + + let n_to_graph, lin_map = initialize ac Env.empty Env.empty in + let g = make_graph ac n_to_graph lin_map in + g + +(* the main entry. *) +let check loc c = + let check_ac ac = + let { g_bot = g_list } = build ac in + match cycle g_list with + | None -> () + | Some _ -> error (Ecausality_cycle ac) in + + let rec check = function + | Aempty -> () + | Aac(ac) -> check_ac ac + | Aor(nc1, nc2) -> check nc1; check nc2 in + + let nc = norm c in + try + check nc + with + | Error(kind) -> message loc kind diff --git a/heptagon/analysis/causality.ml b/heptagon/analysis/causality.ml new file mode 100644 index 0000000..bbe92bc --- /dev/null +++ b/heptagon/analysis/causality.ml @@ -0,0 +1,214 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* causality check *) + +(* $Id: causality.ml 615 2009-11-20 17:43:14Z pouzet $ *) + +open Misc +open Names +open Ident +open Heptagon +open Location +open Linearity +open Graph +open Causal + +let cempty = Cempty +let is_empty c = (c = cempty) + +let cand c1 c2 = + match c1, c2 with + | Cempty, _ -> c2 | _, Cempty -> c1 + | c1, c2 -> Cand(c1, c2) +let rec candlist l = + match l with + | [] -> Cempty + | c1 :: l -> cand c1 (candlist l) + +let ctuplelist l = + Ctuple l + +let cor c1 c2 = + match c1, c2 with + | Cempty, Cempty -> Cempty + | _ -> Cor(c1, c2) +let rec corlist l = + match l with + | [] -> Cempty + | [c1] -> c1 + | c1 :: l -> cor c1 (corlist l) + +let cseq c1 c2 = + match c1, c2 with + | Cempty, _ -> c2 + | _, Cempty -> c1 + | c1, c2 -> Cseq(c1, c2) +let rec cseqlist l = + match l with + | [] -> Cempty + | c1 :: l -> cseq c1 (cseqlist l) + +let read x = Cread(x) +let linread x = Clinread(x) +let lastread x = Clastread(x) +let cwrite x = Cwrite(x) + +(* cutting dependences with a delay operator *) +let rec pre = function + | Cor(c1, c2) -> Cor(pre c1, pre c2) + | Cand(c1, c2) -> Cand(pre c1, pre c2) + | Ctuple l -> Ctuple (List.map pre l) + | Cseq(c1, c2) -> Cseq(pre c1, pre c2) + | Cread(x) | Clinread (x) -> Cempty + | (Cwrite _ | Clastread _ | Cempty) as c -> c + +(* projection and restriction *) +let clear env c = + let rec clearec c = + match c with + | Cor(c1, c2) -> + let c1 = clearec c1 in + let c2 = clearec c2 in + cor c1 c2 + | Cand(c1, c2) -> + let c1 = clearec c1 in + let c2 = clearec c2 in + cand c1 c2 + | Cseq(c1, c2) -> + let c1 = clearec c1 in + let c2 = clearec c2 in + cseq c1 c2 + | Ctuple l -> Ctuple (List.map clearec l) + | Cwrite(id) | Cread(id) | Clinread(id) | Clastread(id) -> + if IdentSet.mem id env then Cempty else c + | Cempty -> c in + clearec c + +let build dec = + List.fold_left (fun acc { v_name = n } -> IdentSet.add n acc) IdentSet.empty dec + +(** Main typing function *) +let rec typing e = + match e.e_desc with + | Econst(c) -> cempty + | Econstvar(x) -> cempty + | Evar(x) -> + (match e.e_linearity with + | At _ -> linread x + | _ -> read x + ) + | Elast(x) -> lastread x + | Etuple(e_list) -> + candlist (List.map typing e_list) + | Eapp({a_op = op}, e_list) -> apply op e_list + | Efield(e1, _) -> typing e1 + | Estruct(l) -> + let l = List.map (fun (_, e) -> typing e) l in + candlist l + | Earray(e_list) -> + candlist (List.map typing e_list) + | Ereset_mem _ -> assert false + +(** Typing an application *) +and apply op e_list = + match op, e_list with + | Epre(_), [e] -> pre (typing e) + | Efby, [e1;e2] -> + let t1 = typing e1 in + let t2 = pre (typing e2) in + candlist [t1; t2] + | Earrow, [e1;e2] -> + let t1 = typing e1 in + let t2 = typing e2 in + candlist [t1; t2] + | Eifthenelse, [e1; e2; e3] -> + let t1 = typing e1 in + let i2 = typing e2 in + let i3 = typing e3 in + cseq t1 (cor i2 i3) + | (Enode _ | Eevery _ | Eop _ | Eiterator (_, _, _, _) + | Econcat | Eselect_slice | Emake _ | Eflatten _ + | Eselect_dyn | Eselect _ | Erepeat | Ecopy), e_list -> + ctuplelist (List.map typing e_list) + | Eupdate _, [e1;e2] | Efield_update _, [e1;e2] -> + let t1 = typing e1 in + let t2 = typing e2 in + cseq t2 t1 + +let rec typing_pat = function + | Evarpat(x) -> cwrite(x) + | Etuplepat(pat_list) -> + candlist (List.map typing_pat pat_list) + +(** Typing equations *) +let rec typing_eqs eq_list = candlist (List.map typing_eq eq_list) + +and typing_eq eq = + match eq.eq_desc with + | Eautomaton(handlers) -> typing_automaton handlers + | Eswitch(e, handlers) -> + cseq (typing e) (typing_switch handlers) + | Epresent(handlers, b) -> + typing_present handlers b + | Ereset(eq_list, e) -> + cseq (typing e) (typing_eqs eq_list) + | Eeq(pat, e) -> + cseq (typing e) (typing_pat pat) + +and typing_switch handlers = + let handler { w_block = b } = typing_block b in + corlist (List.map handler handlers) + +and typing_present handlers b = + let handler { p_cond = e; p_block = b } = + cseq (typing e) (typing_block b) in + corlist ((typing_block b) :: (List.map handler handlers)) + +and typing_automaton state_handlers = + (* typing the body of the automaton *) + let handler + { s_state = _; s_block = b; s_until = suntil; s_unless = sunless } = + let escape { e_cond = e } = typing e in + + (* typing the body *) + let tb = typing_block b in + let t1 = candlist (List.map escape suntil) in + let t2 = candlist (List.map escape sunless) in + + cseq t2 (cseq tb t1) in + corlist (List.map handler state_handlers) + +and typing_block { b_local = dec; b_equs = eq_list; b_loc = loc } = + let teq = typing_eqs eq_list in + Causal.check loc teq; + clear (build dec) teq + +let typing_contract loc contract = + match contract with + | None -> cempty + | Some { c_local = l_list; c_eq = eq_list; c_assume = e_a; + c_enforce = e_g; c_controllables = c_list } -> + let teq = typing_eqs eq_list in + let t_contract = cseq (typing e_a) (cseq teq (typing e_g)) in + Causal.check loc t_contract; + let t_contract = clear (build l_list) t_contract in + t_contract + +let typing_node { n_name = f; n_input = i_list; n_output = o_list; + n_contract = contract; + n_local = l_list; n_equs = eq_list; n_loc = loc } = + let _ = typing_contract loc contract in + let teq = typing_eqs eq_list in + Causal.check loc teq + +let program ({ p_nodes = p_node_list } as p) = + List.iter typing_node p_node_list; + p + diff --git a/heptagon/analysis/initialization.ml b/heptagon/analysis/initialization.ml new file mode 100644 index 0000000..9f9e054 --- /dev/null +++ b/heptagon/analysis/initialization.ml @@ -0,0 +1,374 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* simple initialization analysis. This is almost trivial since *) +(* input/outputs of a node are forced to be initialized *) + +(* $Id: initialization.ml 615 2009-11-20 17:43:14Z pouzet $ *) + +open Misc +open Names +open Ident +open Heptagon +open Location +open Format + +type typ = + | Iproduct of typ list + | Ileaf of init + +and init = + { mutable i_desc: init_desc; + mutable i_index: int } + +and init_desc = + | Izero + | Ione + | Ivar + | Imax of init * init + | Ilink of init + +type kind = | Last of init | Var + +type tenv = { i_kind : kind; i_typ : init } + +(* typing errors *) +exception Unify + +let index = ref 0 +let gen_index () = incr index; !index +let new_var () = { i_desc = Ivar; i_index = gen_index () } +let izero = { i_desc = Izero; i_index = gen_index () } +let ione = { i_desc = Ione; i_index = gen_index () } +let imax i1 i2 = { i_desc = Imax(i1, i2); i_index = gen_index () } +let product l = Iproduct(l) +let leaf i = Ileaf(i) + +(* basic operation on initialization values *) +let rec irepr i = + match i.i_desc with + | Ilink(i_son) -> + let i_son = irepr i_son in + i.i_desc <- Ilink(i_son); + i_son + | _ -> i + +(** Simplification rules for max. Nothing fancy here *) +let max i1 i2 = + let i1 = irepr i1 in + let i2 = irepr i2 in + match i1.i_desc, i2.i_desc with + | (Izero, Izero) -> izero + | (Izero, _) -> i2 + | (_, Izero) -> i1 + | (_, Ione) | (Ione, _) -> ione + | _ -> imax i1 i2 + +let rec itype = function + | Iproduct(ty_list) -> itype_list ty_list + | Ileaf(i) -> i + +and itype_list ty_list = + List.fold_left (fun acc ty -> max acc (itype ty)) izero ty_list + +(* saturate an initialization type. Every element must be initialized *) +let rec initialized i = + let i = irepr i in + match i.i_desc with + | Izero -> () + | Ivar -> i.i_desc <- Ilink(izero) + | Imax(i1, i2) -> initialized i1; initialized i2 + | Ilink(i) -> initialized i + | Ione -> raise Unify + +(* build an initialization type from a type *) +let rec skeleton i ty = + match ty with + | Tbase _ -> leaf i + | Tprod(ty_list) -> product (List.map (skeleton i) ty_list) + +(* sub-typing *) +let rec less left_ty right_ty = + if left_ty == right_ty then () + else + match left_ty, right_ty with + | Iproduct(l1), Iproduct(l2) -> List.iter2 less l1 l2 + | Ileaf(i1), Ileaf(i2) -> iless i1 i2 + | _ -> raise Unify + +and iless left_i right_i = + if left_i == right_i then () + else + let left_i = irepr left_i in + let right_i = irepr right_i in + if left_i == right_i then () + else + match left_i.i_desc, right_i.i_desc with + | (Izero, _) | (_, Ione) -> () + | _, Izero -> initialized left_i + | Imax(i1, i2), _ -> + iless i1 right_i; iless i2 right_i + | _, Ivar -> + let left_i = occur_check right_i.i_index left_i in + right_i.i_desc <- Ilink(left_i) + | _, Imax(i1, i2) -> + let i1 = occur_check left_i.i_index i1 in + let i2 = occur_check left_i.i_index i2 in + right_i.i_desc <- Ilink(imax left_i (imax i1 i2)) + | _ -> raise Unify + +(* an inequation [a < t[a]] becomes [a = t[0]] *) +and occur_check index i = + match i.i_desc with + | Izero | Ione -> i + | Ivar -> if i.i_index = index then izero else i + | Imax(i1, i2) -> + max (occur_check index i1) (occur_check index i2) + | Ilink(i) -> occur_check index i + +module Printer = struct + open Format + + let rec print_list_r print po sep pf ff = function + | [] -> () + | x :: l -> + fprintf ff "@[%s%a" po print x; + List.iter (fprintf ff "%s@]@ @[%a" sep print) l; + fprintf ff "%s@]" pf + + let rec fprint_init ff i = match i.i_desc with + | Izero -> fprintf ff "0" + | Ione -> fprintf ff "1" + | Ivar -> fprintf ff "0" + | Imax(i1, i2) -> fprintf ff "@[%a\\/%a@]" fprint_init i1 fprint_init i2 + | Ilink(i) -> fprint_init ff i + + let rec fprint_typ ff = function + | Ileaf(i) -> fprint_init ff i + | Iproduct(ty_list) -> + fprintf ff "@[%a@]" (print_list_r fprint_typ "("" *"")") ty_list + + let output_typ oc ty = + let ff = formatter_of_out_channel oc in + fprintf ff "@["; + fprint_typ ff ty; + fprintf ff "@?@]" +end + +module Error = struct + open Location + + type error = | Eclash of typ * typ + + exception Error of location * error + + let error loc kind = raise (Error(loc, kind)) + + let message loc kind = + begin match kind with + | Eclash(left_ty, right_ty) -> + Printf.eprintf "%aInitialization error: this expression has type \ + %a, \n\ + but is expected to have type %a\n" + output_location loc + Printer.output_typ left_ty + Printer.output_typ right_ty + end; + raise Misc.Error +end + +let less_exp e actual_ty expected_ty = + try + less actual_ty expected_ty + with | Unify -> Error.message e.e_loc (Error.Eclash(actual_ty, expected_ty)) + +(** Is-it a safe imported value? *) +let safe f = + let { Global.info = { Global.safe = s } } = Modules.find_value f in s + +(** Main typing function *) +let rec typing h e = + match e.e_desc with + | Econst _ | Econstvar _ -> leaf izero + | Evar(x) | Elast(x) -> let { i_typ = i } = Env.find x h in leaf i + | Etuple(e_list) -> + product (List.map (typing h) e_list) + | Eapp({a_op = op}, e_list) -> + let i = apply h op e_list in + skeleton i e.e_ty + | Efield(e1, _) -> + let i = itype (typing h e1) in + skeleton i e.e_ty + | Estruct(l) -> + let i = + List.fold_left + (fun acc (_, e) -> max acc (itype (typing h e))) izero l in + skeleton i e.e_ty + | Earray(e_list) -> + product (List.map (typing h) e_list) + | Ereset_mem _ -> assert false + +(** Typing an application *) +and apply h op e_list = + match op, e_list with + | Epre(None), [e] -> + initialized_exp h e; + ione + | Epre(Some _), [e] -> + initialized_exp h e; + izero + | Efby, [e1;e2] -> + initialized_exp h e2; + itype (typing h e1) + | Earrow, [e1;e2] -> + let ty1 = typing h e1 in + let _ = typing h e2 in + itype ty1 + | Eifthenelse, [e1; e2; e3] -> + let i1 = itype (typing h e1) in + let i2 = itype (typing h e2) in + let i3 = itype (typing h e3) in + max i1 (max i2 i3) + | (Enode(f,_) | Eevery(f,_)), e_list -> + List.iter (fun e -> initialized_exp h e) e_list; izero + | Eop(f,_), e_list when safe f -> + (* unsafe primitives must have an initialized argument *) + List.fold_left (fun acc e -> itype (typing h e)) izero e_list + | Eop(f,_), e_list -> + List.iter (fun e -> initialized_exp h e) e_list; izero +(*Array operators*) + | (Erepeat | Econcat | Eupdate _ | Efield_update _ + | Eselect _ | Eselect_dyn | Eselect_slice + | Eiterator _ | Ecopy | Emake _ | Eflatten _), e_list -> + List.iter (fun e -> initialized_exp h e) e_list; izero + | _ -> assert false + +and expect h e expected_ty = + let actual_ty = typing h e in + less_exp e actual_ty expected_ty + +and initialized_exp h e = expect h e (skeleton izero e.e_ty) + +let rec typing_pat h = function + | Evarpat(x) -> let { i_typ = i } = Env.find x h in leaf i + | Etuplepat(pat_list) -> + product (List.map (typing_pat h) pat_list) + +(** Typing equations *) +let rec typing_eqs h eq_list = List.iter (typing_eq h) eq_list + +and typing_eq h eq = + match eq.eq_desc with + | Eautomaton(handlers) -> typing_automaton h handlers + | Eswitch(e, handlers) -> + initialized_exp h e; + typing_switch h handlers + | Epresent(handlers, b) -> + typing_present h handlers b + | Ereset(eq_list, e) -> + initialized_exp h e; typing_eqs h eq_list + | Eeq(pat, e) -> + let ty_pat = typing_pat h pat in + expect h e ty_pat + +and typing_switch h handlers = + let handler { w_block = b } = ignore (typing_block h b) in + List.iter handler handlers + +and typing_present h handlers b = + let handler { p_cond = e; p_block = b } = + initialized_exp h e; ignore (typing_block h b) in + List.iter handler handlers; ignore (typing_block h b) + +and typing_automaton h state_handlers = + (* we make a special treatment for state variables defined in the *) + (* initial state *) + let weak { s_unless = sunless } = + match sunless with | [] -> true | _ -> false in + + (* the set of variables which do have an initial value in the other states *) + let initialized h { s_block = { b_defnames = l } } = + Env.fold + (fun elt _ h -> + let { i_kind = k; i_typ = i } = Env.find elt h in + match k with + | Last _ -> + let h = Env.remove elt h in + Env.add elt { i_kind = Last(izero); i_typ = izero } h + | _ -> h) + l h in + + (* typing the body of the automaton *) + let handler h + { s_state = _; s_block = b; s_until = suntil; s_unless = sunless } = + let escape h { e_cond = e } = + initialized_exp h e in + + (* typing the body *) + let h = typing_block h b in + List.iter (escape h) suntil; + List.iter (escape h) sunless in + + match state_handlers with + (* we do a special treatment for state variables which *) + (* are defined in the initial state if it cannot be immediately *) + (* exited *) + | initial :: other_handlers when weak initial -> + let h = initialized h initial in + handler h initial; + List.iter (handler h) other_handlers + | _ -> List.iter (handler h) state_handlers + +and typing_block h { b_local = dec; b_equs = eq_list } = + let h_extended = build h dec in + typing_eqs h_extended eq_list; + h_extended + +(* build an typing environment of initialization types *) +and build h dec = + let kind = function + | Heptagon.Var -> { i_kind = Var; i_typ = new_var () } + | Heptagon.Last(Some _) -> { i_kind = Last(izero); i_typ = izero } + | Heptagon.Last(None) -> { i_kind = Last(ione); i_typ = new_var () } in + List.fold_left + (fun h { v_name = n; v_last = last } -> Env.add n (kind last) h) h dec + +let sbuild h dec = + List.fold_left + (fun h { v_name = n } -> Env.add n { i_kind = Var; i_typ = izero } h) h dec + +let typing_contract h contract = + match contract with + | None -> h + | Some { c_local = l_list; c_eq = eq_list; c_assume = e_a; + c_enforce = e_g; c_controllables = c_list } -> + let h = sbuild h c_list in + let h' = build h l_list in + typing_eqs h' eq_list; + (* assumption *) + expect h' e_a (skeleton izero e_a.e_ty); + (* property *) + expect h' e_g (skeleton izero e_g.e_ty); + h + +let typing_node { n_name = f; n_input = i_list; n_output = o_list; + n_contract = contract; + n_local = l_list; n_equs = eq_list } = + let h = sbuild Env.empty i_list in + let h = sbuild h o_list in + let h = typing_contract h contract in + + let h = build h l_list in + typing_eqs h eq_list + +let program ({ p_nodes = p_node_list } as p) = + List.iter typing_node p_node_list; + p + + diff --git a/heptagon/analysis/interface.ml b/heptagon/analysis/interface.ml new file mode 100644 index 0000000..ffb5e7b --- /dev/null +++ b/heptagon/analysis/interface.ml @@ -0,0 +1,131 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* Read an interface *) + +(* $Id$ *) + +open Misc +open Ident +open Names +open Linearity +open Heptagon +open Global +open Modules +open Typing + +let rec split3 = function + | [] -> [], [], [] + | (a,b,c)::l -> + let a_list, b_list, c_list = split3 l in + a::a_list, b::b_list, c::c_list + +let rec combine3 l1 l2 l3 = match l1, l2, l3 with + | [], [], [] -> [] + | a::a_list, b::b_list, c::c_list -> + (a,b,c)::(combine3 a_list b_list c_list) + +module Type = + struct + let sigtype { sig_name = name; sig_inputs = i_list; sig_outputs = o_list; + sig_node = node; sig_safe = safe; sig_params = params } = + let arg_dec_of_tuple (n, ty, l) = + { a_name = n; + a_type = Tbase(check_type ty); + a_linearity = l; + a_pass_by_ref = false } in + let i_inputs, t_inputs, l_inputs = split3 i_list in + let o_outputs, t_outputs, l_outputs = split3 o_list in + name, { inputs = List.map arg_dec_of_tuple i_list; + outputs = List.map arg_dec_of_tuple o_list; + contract = None; + node = node; + safe = safe; + targeting = []; + params = params; + params_constraints = []; } + + let read { interf_desc = desc; interf_loc = loc } = + try + match desc with + | Iopen(n) -> open_module n + | Itypedef(tydesc) -> deftype NamesEnv.empty tydesc + | Isignature(s) -> + let name, s = sigtype s in + add_value name s + with + TypingError(error) -> message loc error + + let main l = + List.iter read l + end + +module Printer = +struct + open Format + open Printer + + let deftype ff name tdesc = + match tdesc with + | Tabstract -> fprintf ff "@[type %s@.@]" name + | Tenum(tag_name_list) -> + fprintf ff "@[type %s = " name; + print_list ff print_name " |" tag_name_list; + fprintf ff "@.@]" + | Tstruct(f_ty_list) -> + fprintf ff "@[type %s = " name; + fprintf ff "@[{"; + print_list ff + (fun ff (field, ty) -> print_name ff field; + fprintf ff ": "; + print_base_type ff ty) ";" f_ty_list; + fprintf ff "}@]@.@]" + + let signature ff name { inputs = inputs; + outputs = outputs; + contract = contract; node = node; + safe = safe; params = params; params_constraints = constr } = + let print ff arg = + match arg.a_name with + | None -> print_type ff arg.a_type + | Some(name) -> + print_name ff name; fprintf ff ":"; print_type ff arg.a_type; + fprintf ff " "; print_lin ff arg.a_linearity in + + let print_node_params ff = function + | [] -> () + | l -> + fprintf ff "<<"; + print_list ff print_name "," l; + fprintf ff ">>" in + + fprintf ff "@[val "; + if safe then fprintf ff "safe "; + if node then fprintf ff "node " else fprintf ff "fun "; + print_name ff name; + print_node_params ff params; + fprintf ff "(@["; + print_list ff print ";" inputs; + fprintf ff "@]) returns (@["; + print_list ff print ";" outputs; + fprintf ff "@])"; + (match constr with + | [] -> () + | constr -> + fprintf ff "\n with: @["; + print_list ff Static.print_size_constr "," constr; + fprintf ff "@]" + ); + optunit (print_contract ff) contract; + fprintf ff "@.@]" + + let print oc = + let ff = formatter_of_out_channel oc in + NamesEnv.iter (fun key typdesc -> deftype ff key typdesc) current.types; + NamesEnv.iter (fun key sigtype -> signature ff key sigtype) current.values; +end diff --git a/heptagon/analysis/typing.ml b/heptagon/analysis/typing.ml new file mode 100644 index 0000000..92face8 --- /dev/null +++ b/heptagon/analysis/typing.ml @@ -0,0 +1,932 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* type checking *) + +(* $Id$ *) + +open Misc +open Names +open Ident +open Location +open Heptagon +open Global +open Modules +open Initial +open Static + +type value = { ty: ty; mutable last: bool } + +type error = + | Emissing of name + | Emissingcase of name + | Eundefined of name + | Elast_undefined of name + | Eshould_be_last of name + | Etype_clash of ty * ty + | Earity_clash of int * int + | Ealready_defined of name + | Eshould_be_a_node of longname + | Enon_exaustive + | Estate_clash + | Epartial_switch of name + | Etwo_many_outputs + | Esome_fields_are_missing + | Esubscripted_value_not_an_array of ty + | Earray_subscript_should_be_const + | Eundefined_const of name + | Econstraint_solve_failed of size_constr + | Etype_should_be_static of ty + +exception Unify +exception TypingError of error + +let error kind = raise (TypingError(kind)) + +let message loc kind = + begin match kind with + | Emissing(s) -> + Printf.eprintf "%aNo equation is given for name %s.\n" + output_location loc + s; + | Emissingcase(s) -> + Printf.eprintf "%aCase %s not defined.\n" + output_location loc + s; + | Eundefined(s) -> + Printf.eprintf "%aThe name %s is unbound.\n" + output_location loc + s; + | Elast_undefined(s) -> + Printf.eprintf "%aThe name %s does not have a last value.\n" + output_location loc + s; + | Eshould_be_last(s) -> + Printf.eprintf "%aOnly the last value of %s can be accessed.\n" + output_location loc + s; + | Etype_clash(actual_ty, expected_ty) -> + Printf.eprintf "%aType Clash: this expression has type %a, \n\ + but is expected to have type %a.\n" + output_location loc + Printer.ptype actual_ty + Printer.ptype expected_ty + | Earity_clash(actual_arit, expected_arit) -> + Printf.eprintf "%aType Clash: this expression expects %d arguments,\n\ + but is expected to have %d.\n" + output_location loc + expected_arit actual_arit + | Ealready_defined(s) -> + Printf.eprintf "%aThe name %s is already defined.\n" + output_location loc + s + | Enon_exaustive -> + Printf.eprintf "%aSome constructors are missing in this \ + pattern/matching.\n" + output_location loc + | Eshould_be_a_node(s) -> + Printf.eprintf "%a%s should be a combinatorial function.\n" + output_location loc + (fullname s) + | Estate_clash -> + Printf.eprintf + "%aOnly stateless expressions should appear in a function.\n" + output_location loc + | Epartial_switch(s) -> + Printf.eprintf + "%aThe case %s is missing.\n" + output_location loc + s + | Etwo_many_outputs -> + Printf.eprintf + "%aA function may only returns a basic value.\n" + output_location loc + | Esome_fields_are_missing -> + Printf.eprintf + "%aSome fields are missing.\n" + output_location loc + | Esubscripted_value_not_an_array ty -> + Printf.eprintf + "%aSubscript used on a non array type : %a.\n" + output_location loc + Printer.ptype ty + | Earray_subscript_should_be_const -> + Printf.eprintf + "%aSubscript has to be a static value.\n" + output_location loc + | Eundefined_const id -> + Printf.eprintf + "%aThe const name '%s' is unbound.\n" + output_location loc + id + | Econstraint_solve_failed c -> + Printf.eprintf + "%aThe following constraint cannot be satisified:\n %a.\n" + output_location loc + psize_constr c + | Etype_should_be_static ty -> + Printf.eprintf + "%aThis type should be static : %a.\n" + output_location loc + Printer.ptype ty + end; + raise Error + +let add_value f signature = + try add_value f signature with Already_defined -> error (Ealready_defined f) +let add_type f typ_desc = + try add_type f typ_desc with Already_defined -> error (Ealready_defined f) +let add_constr f ty_res = + try add_constr f ty_res with Already_defined -> error (Ealready_defined f) +let add_field f ty_arg ty_res = + try add_field f ty_arg ty_res + with Already_defined -> error (Ealready_defined f) + +let find_value f = + try find_value f with Not_found -> error (Eundefined(fullname f)) +let find_type f = + try find_type f with Not_found -> error (Eundefined(fullname f)) +let find_constr c = + try find_constr c with Not_found -> error (Eundefined(fullname c)) +let find_field c = + try find_field c with Not_found -> error (Eundefined(fullname c)) + +let (curr_size_constr : size_constr list ref) = ref [] +let add_size_constr c = + curr_size_constr := c::(!curr_size_constr) +let get_size_constr () = + let l = !curr_size_constr in + curr_size_constr := []; + l + +let get_number_of_fields ty = + let { info = tydesc } = + match ty with + | Tid(f) -> find_type f + | _ -> assert false in + match tydesc with + | Tstruct l -> List.length l + | _ -> assert false + +let element_type ty = + match ty with + | Tbase (Tarray (ty, _)) -> Tbase ty + | _ -> error (Esubscripted_value_not_an_array ty) + +let size_exp ty = + match ty with + | Tbase (Tarray (_, e)) -> e + | _ -> error (Esubscripted_value_not_an_array ty) + +let rec unify t1 t2 = + match t1, t2 with + | Tprod(t1_list), Tprod(t2_list) -> + begin + try List.iter2 unify t1_list t2_list with _ -> raise Unify + end + | Tbase(b1), Tbase(b2) when b1 = b2 -> () + | Tbase(Tbool), Tbase(Tid name_bool) + | Tbase(Tid name_bool), Tbase(Tbool) + when name_bool = pbool -> () + | Tbase(Tint), Tbase(Tid name_int) + | Tbase(Tid name_int), Tbase(Tint) + when name_int = pint -> () + | Tbase(Tfloat), Tbase(Tid name_float) + | Tbase(Tid name_float), Tbase(Tfloat) + when name_float = pfloat -> () + | Tbase(Tarray (ty1, e1)), Tbase(Tarray (ty2, e2)) -> + add_size_constr (Equal(e1,e2)); + unify (Tbase ty1) (Tbase ty2) + | _ -> raise Unify + +let unify t1 t2 = + try unify t1 t2 with Unify -> error (Etype_clash(t1, t2)) + +let less_than statefull = if not statefull then error Estate_clash + +let kind f statefull = function + | { inputs = ty_list1; + outputs = ty_list2; + node = n } -> + let ty_of_arg_dec v = v.a_type in + if n & not(statefull) then error (Eshould_be_a_node(f)) + else n, List.map ty_of_arg_dec ty_list1, List.map ty_of_arg_dec ty_list2 + +let prod = function + | [] -> assert false + | [ty] -> ty + | ty_list -> Tprod(ty_list) + +let rec typing_const c = + let typed_c, base_ty = match c with + | Cint _ -> c, Tid(pint) + | Cfloat _ -> c, Tid(pfloat) + | Cconstr(c) -> + let { qualid = q; info = base_ty } = find_constr c in + Cconstr(Modname(q)), base_ty + | Cconst_array(n, c) -> + let c, ty = typing_const c in + Cconst_array(n,c), Tarray(base_type ty, n) + in + typed_c, Tbase(base_ty) + +let typ_of_name h x = + try + let { ty = ty } = Env.find x h in ty + with + Not_found -> error (Eundefined(sourcename x)) + +let typ_of_varname h x = + try + let { ty = ty;last = last } = Env.find x h in + (* Don't understand that - GD 15/02/2009 *) + (* if last then error (Eshould_be_last(x)); *) + ty + with + Not_found -> error (Eundefined(sourcename x)) + +let typ_of_last h x = + try + let { ty = ty; last = last } = Env.find x h in + if not last then error (Elast_undefined(sourcename x)); + (* v.last <- true;*) + ty + with + Not_found -> error (Eundefined(sourcename x)) + +let desc_of_ty = function + | Tbase(Tid(ty_name)) -> + let { info = tydesc } = find_type ty_name in tydesc + | Tbase(Tbool) -> Tenum ["true";"false"] + | _ -> Tabstract +let set_of_constr = function + | Tabstract | Tstruct _ -> assert false + | Tenum(tag_list) -> List.fold_right S.add tag_list S.empty + +let name_mem n env = + let check_one id _ acc = + ((name id) = n) or acc + in + Env.fold check_one env false + +(* [check_type t] checks that t exists *) +let rec check_type = function + | Tint | Tfloat | Tbool as t -> t + | Tarray(ty, e) -> + Tarray(check_type ty, e) + | Tid(ty_name) -> + try Tid(Modname((find_type ty_name).qualid)) + with Not_found -> error (Eundefined(fullname ty_name)) + +let rec simplify_type const_env = function + | Tint | Tfloat | Tbool | Tid _ as t -> t + | Tarray(ty, e) -> + Tarray(simplify_type const_env ty, simplify const_env e) + +let simplify_type loc const_env ty = + try + simplify_type const_env ty + with + Instanciation_failed -> message loc (Etype_should_be_static (Tbase ty)) + +let rec subst_base_type_vars m = function + | Tarray(ty, e) -> Tarray(subst_base_type_vars m ty, size_exp_subst m e) + | t -> t + +let rec subst_type_vars m = function + | Tbase ty -> Tbase (subst_base_type_vars m ty) + | Tprod l -> Tprod (List.map (subst_type_vars m) l) + +let equal expected_tag_list actual_tag_list = + if not (List.for_all + (fun tag -> List.mem tag actual_tag_list) expected_tag_list) + then error Enon_exaustive + +(* add two sets of names provided they are distinct *) +let add env1 env2 = + Env.fold + (fun elt ty env -> + if not (Env.mem elt env) + then Env.add elt ty env + else error (Ealready_defined(sourcename elt))) env1 env2 + +(* checks that constructors are included in constructor list from type + def and returns the difference *) +let included_const s1 s2 = + S.iter + (fun elt -> if not (S.mem elt s2) then error (Emissingcase(elt))) + s1 + +let diff_const defined_names local_names = + included_const local_names defined_names; + S.diff defined_names local_names + +(* checks that local_names are included in defined_names and returns *) +(* the difference *) +let included_env s1 s2 = + Env.iter + (fun elt _ -> if not (Env.mem elt s2) then error (Emissing(sourcename elt))) + s1 + +let diff_env defined_names local_names = + included_env local_names defined_names; + Env.diff defined_names local_names + +(* [merge [set1;...;setn]] returns a set of names defined in every seti *) +(* and only partially defined names *) +let rec merge local_names_list = + let two s1 s2 = + let total, partial = Env.partition (fun elt -> Env.mem elt s2) s1 in + let partial = + Env.fold (fun elt ty env -> + if not (Env.mem elt total) then Env.add elt ty env + else env) + s2 partial in + total, partial in + match local_names_list with + | [] -> Env.empty, Env.empty + | [s] -> s, Env.empty + | s :: local_names_list -> + let total, partial1 = merge local_names_list in + let total, partial2 = two s total in + total, Env.union partial1 partial2 + +(* checks that every partial name has a last value *) +let all_last h env = + Env.iter + (fun elt _ -> + if not (Env.find elt h).last then error (Elast_undefined(sourcename elt))) + env + +let last = function | Var -> false | Last _ -> true + +let rec typing statefull h e = + try + let typed_desc,ty = match e.e_desc with + | Econst(c) -> + let typed_c, ty = typing_const c in + Econst(c), + ty + | Econstvar(x) -> Econstvar x, Tbase Tint + | Evar(x) -> + Evar(x), + typ_of_varname h x + | Elast(x) -> + Elast(x), + typ_of_last h x + | Etuple(e_list) -> + let typed_e_list,ty_list = + List.split (List.map (typing statefull h) e_list) in + Etuple(typed_e_list), + Tprod(ty_list) + | Eapp({ a_op = op } as app, e_list ) -> + let ty, op, typed_e_list = typing_app statefull h op e_list in + Eapp({ app with a_op = op }, typed_e_list), + ty + | Efield(e, field) -> + let { qualid = q; + info = { arg = ty_arg; res = ty_res } } = find_field field in + let typed_e = expect statefull h (Tbase(ty_arg)) e in + Efield(typed_e, Modname(q)), + Tbase(ty_res) + | Estruct(l) -> + let { qualid = q; + info = { arg = ty_arg } } = find_field (fst (List.hd l)) in + let size = get_number_of_fields ty_arg in + let rec fieldrec acc_l acc = function + | [] -> + List.rev acc_l, + Tbase(ty_arg) + | (field, e) :: l -> + if S.mem (shortname field) acc + then error (Ealready_defined(fullname field)); + let { qualid = q; + info = { arg = ty; res = ty_res } } = find_field field in + let typed_e = expect statefull h (Tbase(ty_res)) e in + unify (Tbase(ty)) (Tbase(ty_arg)); + fieldrec + ((Modname(q),typed_e)::acc_l) + (S.add (shortname field) acc) + l in + let typed_l, ty = fieldrec [] S.empty l in + (* check that no field is missing *) + if List.length l <> size then error Esome_fields_are_missing; + Estruct(typed_l), + ty + | Earray (exp::e_list) -> + let typed_exp, t1 = typing statefull h exp in + let typed_e_list = List.map (expect statefull h t1) e_list in + Earray(typed_exp::typed_e_list), + const_array_of t1 (List.length e_list + 1) + | Earray [] -> + error (Earity_clash (0, 1)) + | Ereset_mem _ -> assert false + in + { e with + e_desc = typed_desc; + e_ty = ty; }, + ty + with + TypingError(kind) -> message e.e_loc kind + +and expect statefull h expected_ty e = + let typed_e, actual_ty = typing statefull h e in + try + unify actual_ty expected_ty; + typed_e + with TypingError(kind) -> message e.e_loc kind + +and typing_app statefull h op e_list = + match op, e_list with + | Epre(None), [e] -> + less_than statefull; + let typed_e,ty = typing statefull h e in + ty,op,[typed_e] + | Epre(Some(c)), [e] -> + less_than statefull; + let typed_c, t1 = typing_const c in + let typed_e = expect statefull h t1 e in + t1, Epre(Some(typed_c)), [typed_e] + | (Efby | Earrow), [e1;e2] -> + less_than statefull; + let typed_e1, t1 = typing statefull h e1 in + let typed_e2 = expect statefull h t1 e2 in + t1, op, [typed_e1;typed_e2] + | Eifthenelse, [e1;e2;e3] -> + let typed_e1 = expect statefull h (Tbase tbool) e1 in + let typed_e2, t1 = typing statefull h e2 in + let typed_e3 = expect statefull h t1 e3 in + t1, op, [typed_e1; typed_e2; typed_e3] + | (Enode(f, params) | Eevery(f, params) | Eop(f, params)), e_list -> + let { qualid = q; info = ty_desc } = find_value f in + let k, expected_ty_list, result_ty_list = kind f statefull ty_desc in + let m = List.combine ty_desc.params params in + let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in + let typed_e_list = typing_args statefull h expected_ty_list e_list in + let size_constrs = instanciate_constr m ty_desc.params_constraints in + let result_ty_list = List.map (subst_type_vars m) result_ty_list in + List.iter add_size_constr size_constrs; + let f = Modname(q) in + (prod result_ty_list, + (if k then Enode(f, params) else Eop(f, params)), + typed_e_list) +(*Array operators*) + | Erepeat, [e1; e2] -> + let typed_e2 = expect statefull h (Tbase(Tint)) e2 in + let e2 = size_exp_of_exp e2 in + let typed_e1, t1 = typing statefull h e1 in + add_size_constr (LEqual (SConst 1, e2)); + array_of t1 e2, op, [typed_e1; typed_e2] + | Eselect idx_list, [e1] -> + let typed_e1, t1 = typing statefull h e1 in + typing_array_subscript statefull h idx_list t1, op, [typed_e1] + | Eselect_dyn, e1::defe::idx_list -> + let typed_e1, t1 = typing statefull h e1 in + let typed_defe = expect statefull h (element_type t1) defe in + let ty, typed_idx_list = typing_array_subscript_dyn statefull h idx_list t1 in + ty, op, typed_e1::typed_defe::typed_idx_list + | Eupdate idx_list, [e1;e2] -> + let typed_e1, t1 = typing statefull h e1 in + let base_ty = typing_array_subscript statefull h idx_list t1 in + let typed_e2 = expect statefull h base_ty e2 in + t1, op, [typed_e1; typed_e2] + | Eselect_slice, [e; idx1; idx2] -> + let typed_idx1 = expect statefull h (Tbase(Tint)) idx1 in + let typed_idx2 = expect statefull h (Tbase(Tint)) idx2 in + let typed_e, t1 = typing statefull h e in + (*Create the expression to compute the size of the array *) + let e1 = SOp (SMinus, size_exp_of_exp idx2, size_exp_of_exp idx1) in + let e2 = SOp (SPlus, e1, SConst 1) in + add_size_constr (LEqual (SConst 1, e2)); + array_of (element_type t1) e2, op, [typed_e; typed_idx1; typed_idx2] + | Econcat, [e1; e2] -> + let typed_e1, t1 = typing statefull h e1 in + let typed_e2, t2 = typing statefull h e2 in + begin try + unify (element_type t1) (element_type t2) + with + TypingError(kind) -> message e1.e_loc kind + end; + let n = SOp (SPlus, size_exp t1, size_exp t2) in + array_of (element_type t1) n, op, [typed_e1; typed_e2] + | Eiterator (it, f, params, reset), e::e_list -> + let { qualid = q; info = ty_desc } = find_value f in + let f = Modname(q) in + let _, expected_ty_list, result_ty_list = kind f statefull ty_desc in + let m = List.combine ty_desc.params params in + let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in + let size_constrs = instanciate_constr m ty_desc.params_constraints in + let result_ty_list = List.map (subst_type_vars m) result_ty_list in + let typed_e = expect statefull h (Tbase Tint) e in + let e = size_exp_of_exp e in + let ty, typed_e_list = typing_iterator statefull h it e + expected_ty_list result_ty_list e_list in + add_size_constr (LEqual (SConst 1, e)); + List.iter add_size_constr size_constrs; + ty, Eiterator(it, f, params, reset), typed_e::typed_e_list + | Ecopy, [e] -> + let typed_e, ty = typing statefull h e in + ty, op, [typed_e] + | Efield_update field, [e1; e2] -> + let { qualid = q; + info = { arg = ty_arg; res = ty_res } } = find_field field in + let typed_e1 = expect statefull h (Tbase(ty_arg)) e1 in + let typed_e2 = expect statefull h (Tbase(ty_res)) e2 in + Tbase(ty_arg), op, [typed_e1; typed_e2] + | Eflatten n, [e] -> + let { qualid = q; + info = { fields = fields } } = find_struct n in + let typed_e = expect statefull h (Tbase(Tid (Modname q))) e in + prod (List.map (fun (_, ty) -> Tbase (check_type ty)) fields), op, [typed_e] + | Emake n, e_list -> + let { qualid = q; + info = { fields = fields } } = find_struct n in + if List.length e_list <> List.length fields then + error (Earity_clash(List.length e_list, List.length fields)); + let typed_e_list = List.map2 + (fun e (_,ty) -> expect statefull h (Tbase (check_type ty)) e) + e_list fields in + Tbase (Tid (Modname q)), op, typed_e_list +(*Arity problems*) + | Epre _, _ -> + error (Earity_clash(List.length e_list, 1)) + | (Efby | Earrow), _ -> + error (Earity_clash(List.length e_list, 2)) + | Eifthenelse, _ -> + error (Earity_clash(List.length e_list, 2)) + | Eiterator _, _ -> + error (Earity_clash(List.length e_list, 1)) + | Econcat, _ -> + error (Earity_clash(List.length e_list, 2)) + | Eselect_slice, _ -> + error (Earity_clash(List.length e_list, 3)) + | Eupdate _, _ -> + error (Earity_clash(List.length e_list, 2)) + | Eselect _, _ -> + error (Earity_clash(List.length e_list, 1)) + | Eselect_dyn, _ -> + error (Earity_clash(List.length e_list, 2)) + | Erepeat _, _ -> + error (Earity_clash(List.length e_list, 2)) + | Ecopy, _ -> + error (Earity_clash(List.length e_list, 1)) + | Efield_update field, _ -> + error (Earity_clash(List.length e_list, 2)) + +and typing_iterator statefull h it n args_ty_list result_ty_list e_list = + match it with + | Imap -> + let args_ty_list = List.map (fun ty -> array_of ty n) args_ty_list in + let result_ty_list = List.map (fun ty -> array_of ty n) result_ty_list in + let typed_e_list = typing_args statefull h args_ty_list e_list in + prod result_ty_list, typed_e_list + | Ifold -> + let args_ty_list = incomplete_map (fun ty -> array_of ty n) args_ty_list in + let typed_e_list = typing_args statefull h args_ty_list e_list in + (*check accumulator type matches in input and output*) + if List.length result_ty_list > 1 then + error (Etwo_many_outputs); + begin try + unify (last_element args_ty_list) (List.hd result_ty_list) + with + TypingError(kind) -> message (List.hd e_list).e_loc kind + end; + (List.hd result_ty_list), typed_e_list + | Imapfold -> + let args_ty_list = incomplete_map (fun ty -> array_of ty n) args_ty_list in + let result_ty_list = incomplete_map (fun ty -> array_of ty n) result_ty_list in + let typed_e_list = typing_args statefull h args_ty_list e_list in + (*check accumulator type matches in input and output*) + begin try + unify (last_element args_ty_list) (last_element result_ty_list) + with + TypingError(kind) -> message (List.hd e_list).e_loc kind + end; + prod result_ty_list, typed_e_list + +and typing_array_subscript statefull h idx_list ty = + match ty, idx_list with + | ty, [] -> ty + | Tbase(Tarray(base_ty, exp)), idx::idx_list -> + add_size_constr (LEqual (SConst 0, idx)); + add_size_constr (LEqual (idx, SOp(SMinus, exp, SConst 1))); + typing_array_subscript statefull h idx_list (Tbase base_ty) + | _, _ -> error (Esubscripted_value_not_an_array ty) + +(* This function checks that the array dimensions matches + the subscript. It returns the base type wrt the nb of indices. *) +and typing_array_subscript_dyn statefull h idx_list ty = + match ty, idx_list with + | ty, [] -> ty, [] + | Tbase(Tarray(base_ty, exp)), idx::idx_list -> + let typed_idx = expect statefull h (Tbase(Tint)) idx in + let ty, typed_idx_list = + typing_array_subscript_dyn statefull h idx_list (Tbase base_ty) in + ty, typed_idx::typed_idx_list + | _, _ -> error (Esubscripted_value_not_an_array ty) + +and typing_args statefull h expected_ty_list e_list = + try + List.map2 (expect statefull h) expected_ty_list e_list + with Invalid_argument _ -> + error (Earity_clash(List.length e_list, List.length expected_ty_list)) + +let rec typing_pat h acc = function + | Evarpat(x) -> + let ty = typ_of_name h x in + let acc = + if Env.mem x acc + then error (Ealready_defined (sourcename x)) + else Env.add x ty acc in + acc, ty + | Etuplepat(pat_list) -> + let acc, ty_list = + List.fold_right + (fun pat (acc, ty_list) -> + let acc, ty = typing_pat h acc pat in acc, ty :: ty_list) + pat_list (acc, []) in + acc, Tprod(ty_list) + +let rec typing_eq statefull h acc eq = + let typed_desc,acc = match eq.eq_desc with + | Eautomaton(state_handlers) -> + let typed_sh,acc = + typing_automaton_handlers statefull h acc state_handlers in + Eautomaton(typed_sh), + acc + | Eswitch(e, switch_handlers) -> + let typed_e,ty = typing statefull h e in + let typed_sh,acc = + typing_switch_handlers statefull h acc ty switch_handlers in + Eswitch(typed_e,typed_sh), + acc + | Epresent(present_handlers, b) -> + let typed_b, def_names, _ = typing_block statefull h b in + let typed_ph, acc = + typing_present_handlers statefull h acc def_names present_handlers in + Epresent(typed_ph,typed_b), + acc + | Ereset(eq_list, e) -> + let typed_e = expect statefull h (Tbase(tbool)) e in + let typed_eq_list, acc = typing_eq_list statefull h acc eq_list in + Ereset(typed_eq_list,typed_e), + acc + | Eeq(pat, e) -> + let acc, ty_pat = typing_pat h acc pat in + let typed_e = expect statefull h ty_pat e in + Eeq(pat, typed_e), + acc in + { eq with + eq_statefull = statefull; + eq_desc = typed_desc }, + acc + +and typing_eq_list statefull h acc eq_list = + let rev_typed_eq_list,acc = + List.fold_left + (fun (rev_eq_list,acc) eq -> + let typed_eq, acc = typing_eq statefull h acc eq in + (typed_eq::rev_eq_list),acc + ) + ([],acc) + eq_list in + ((List.rev rev_typed_eq_list), + acc) + +and typing_automaton_handlers statefull h acc state_handlers = + (* checks unicity of states *) + let addname acc { s_state = n } = + if S.mem n acc then error (Ealready_defined(n)) else S.add n acc in + let states = List.fold_left addname S.empty state_handlers in + + let escape statefull h ({ e_cond = e; e_next_state = n } as esc) = + if not (S.mem n states) then error (Eundefined(n)); + let typed_e = expect statefull h (Tbase(tbool)) e in + { esc with e_cond = typed_e } in + + let handler + ({ s_state = n; s_block = b; s_until = e_list1; s_unless = e_list2 } as s) = + let typed_b, defined_names, h0 = typing_block statefull h b in + let typed_e_list1 = List.map (escape statefull h0) e_list1 in + let typed_e_list2 = List.map (escape false h) e_list2 in + { s with + s_block = typed_b; + s_until = typed_e_list1; + s_unless = typed_e_list2 }, + defined_names in + + let typed_handlers,defined_names_list = + List.split (List.map handler state_handlers) in + let total, partial = merge defined_names_list in + all_last h partial; + typed_handlers, + (add total (add partial acc)) + +and typing_switch_handlers statefull h acc ty switch_handlers = + (* checks unicity of states *) + let addname acc { w_name = n } = + let n = shortname(n) in + if S.mem n acc then error (Ealready_defined(n)) else S.add n acc in + let cases = List.fold_left addname S.empty switch_handlers in + let d = diff_const (set_of_constr (desc_of_ty ty)) cases in + if not (S.is_empty d) then error (Epartial_switch(S.choose d)); + + let handler ({ w_block = b; w_name = name }) = + let typed_b, defined_names, _ = typing_block statefull h b in + { w_block = typed_b; + (* Replace handler name with fully qualified name *) + w_name = Modname((find_constr name).qualid)}, + defined_names in + + let typed_switch_handlers, defined_names_list = + List.split (List.map handler switch_handlers) in + let total, partial = merge defined_names_list in + all_last h partial; + (typed_switch_handlers, + add total (add partial acc)) + +and typing_present_handlers statefull h acc def_names present_handlers = + let handler ({ p_cond = e; p_block = b }) = + let typed_e = expect false h (Tbase(tbool)) e in + let typed_b, defined_names, _ = typing_block statefull h b in + { p_cond = typed_e; p_block = typed_b }, + defined_names + in + + let typed_present_handlers, defined_names_list = + List.split (List.map handler present_handlers) in + let total, partial = merge (def_names :: defined_names_list) in + all_last h partial; + (typed_present_handlers, + (add total (add partial acc))) + +and typing_block statefull h + ({ b_local = l; b_equs = eq_list; b_loc = loc } as b) = + try + let typed_l, local_names, h0 = build h Env.empty l in + let typed_eq_list, defined_names = + typing_eq_list statefull h0 Env.empty eq_list in + let defnames = diff_env defined_names local_names in + { b with + b_statefull = statefull; + b_defnames = defnames; + b_local = typed_l; + b_equs = typed_eq_list }, + defnames, h0 + with + | TypingError(kind) -> message loc kind + +and build h h0 dec = + List.fold_left + (fun (acc_dec, acc_defined, h) + ({ v_name = n; v_type = btype; v_last = l; v_loc = loc } as v) -> + try + let ty = check_type btype in + (* update type longname with module name from check_type *) + v.v_type <- ty; + if (Env.mem n h0) or (Env.mem n h) + then error (Ealready_defined(sourcename n)) + else + ({ v with v_type = ty }::acc_dec, + Env.add n (Tbase(ty)) acc_defined, + Env.add n { ty = Tbase(ty); last = last l } h) + with + | TypingError(kind) -> message loc kind) + ([], Env.empty, h) dec + +let build_params h params = + let add_one h param = + if Env.mem param h then + error (Ealready_defined(name param)); + Env.add param { ty = Tbase Tint; last = false } h + in + List.fold_left add_one h params + +let typing_contract statefull h contract = + + match contract with + | None -> None,Env.empty,h + | Some ({ c_local = l_list; + c_eq = eq; + c_assume = e_a; + c_enforce = e_g; + c_controllables = c_list }) -> + let typed_c_list, controllable_names, h = build h h c_list in + let typed_l_list, local_names, h' = build h h l_list in + + let typed_eq, defined_names = typing_eq_list statefull h' Env.empty eq in + + (* assumption *) + let typed_e_a = expect statefull h' (Tbase(tbool)) e_a in + (* property *) + let typed_e_g = expect statefull h' (Tbase(tbool)) e_g in + + included_env local_names defined_names; + included_env defined_names local_names; + + Some { c_local = typed_l_list; + c_controllables = List.rev typed_c_list; + c_eq = typed_eq; + c_assume = typed_e_a; + c_enforce = typed_e_g }, + controllable_names, h + +let signature const_env statefull params returns contract node_params constraints = + let arg_dec_of_var_dec vd = + { a_name = Some (sourcename vd.v_name); + a_type = Tbase(check_type vd.v_type); + a_linearity = vd.v_linearity; + a_pass_by_ref = false; } + in + { inputs = List.map arg_dec_of_var_dec params; + outputs = List.map arg_dec_of_var_dec returns; + contract = contract; + node = statefull; + safe = false; + targeting = []; + params = node_params; + params_constraints = constraints; } + +let solve loc env cl = + try + solve env cl + with + Solve_failed c -> message loc (Econstraint_solve_failed c) + +let node const_env ({ n_name = f; n_statefull = statefull; + n_input = i_list; n_output = o_list; + n_contract = contract; + n_local = l_list; n_equs = eq_list; n_loc = loc; + n_params = node_params; } as n) = + try + let typed_i_list, input_names, h = build Env.empty Env.empty i_list in + let typed_o_list, output_names, h = build h h o_list in + + (* typing contract *) + let typed_contract, controllable_names, h = typing_contract statefull h contract in + + let typed_l_list, local_names, h = build h h l_list in + let typed_eq_list, defined_names = typing_eq_list statefull h Env.empty eq_list in + if not (statefull) & (List.length o_list <> 1) + then error (Etwo_many_outputs); + let expected_names = add local_names output_names in + included_env expected_names defined_names; + included_env defined_names expected_names; + + let cl = get_size_constr () in + let ff = Format.formatter_of_out_channel stdout in + Format.fprintf ff "Gathered constraints before solving for %s: %d\n " f (List.length cl); + print_list ff print_size_constr ", " cl; + Format.fprintf ff "\n"; + + let cl = solve loc const_env cl in + Format.fprintf ff "Constraints after solving for %s: %d\n " f (List.length cl); + print_list ff print_size_constr ", " cl; + Format.fprintf ff "\n"; + Format.fprintf ff "@?" ; + + add_value f (signature const_env statefull i_list o_list contract node_params cl); + + { n with + n_input = List.rev typed_i_list; + n_output = List.rev typed_o_list; + n_local = typed_l_list; + n_contract = typed_contract; + n_equs = typed_eq_list } + with + | TypingError(error) -> message loc error + +let deftype const_env { t_name = n; t_desc = tdesc; t_loc = loc } = + try + match tdesc with + | Type_abs -> add_type n Tabstract + | Type_enum(tag_name_list) -> + add_type n (Tenum(tag_name_list)); + List.iter (fun tag -> add_constr tag (Tid(longname n))) tag_name_list + | Type_struct(field_ty_list) -> + let field_ty_list = + List.map (fun (n,ty) -> n, simplify_type loc const_env ty) field_ty_list in + add_type n (Tstruct(field_ty_list)); + add_struct n field_ty_list; + List.iter + (fun (field, ty) -> + add_field field (Tid(longname n)) (check_type ty)) field_ty_list + with + TypingError(error) -> message loc error + +let build_const_env cd_list = + List.fold_left (fun env cd -> NamesEnv.add cd.c_name cd.c_value env) NamesEnv.empty cd_list + +let program + ({ p_opened = opened; p_types = p_type_list; + p_nodes = p_node_list; p_consts = p_consts_list } as p) = + let const_env = build_const_env p_consts_list in + List.iter open_module opened; + List.iter (deftype const_env) p_type_list; + let typed_node_list = List.map (node const_env) p_node_list in + { p with p_nodes = typed_node_list } diff --git a/heptagon/heptagon.ml b/heptagon/heptagon.ml new file mode 100644 index 0000000..53b1ac5 --- /dev/null +++ b/heptagon/heptagon.ml @@ -0,0 +1,370 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* the internal representation *) +(* $Id$ *) + +open Location +open Misc +open Names +open Linearity +open Ident +open Interference_graph +open Static + +type inlining_policy = + | Ino + | Ione + | Irec + +type ty = + | Tbase of base_ty + | Tprod of ty list + +and base_ty = + | Tint | Tfloat | Tbool + | Tid of longname + | Tarray of base_ty * size_exp + +and exp = + { e_desc: desc; + mutable e_ty: ty; + mutable e_linearity : linearity; + e_loc: location } + +and desc = + | Econst of const + | Evar of ident + | Econstvar of name + | Elast of ident + | Etuple of exp list + | Eapp of app * exp list + | Efield of exp * longname + | Estruct of (longname * exp) list + | Earray of exp list + | Ereset_mem of ident * exp * ident + +and app = + { mutable a_op : op; (* hange of global name after typing *) + a_inlined : inlining_policy; (* node to inline or not *) + } + +and op = + | Epre of const option + | Efby | Earrow | Eifthenelse | Enode of longname * size_exp list + | Eevery of longname * size_exp list | Eop of longname * size_exp list + | Erepeat | Eselect of size_exp list | Eselect_dyn + | Eupdate of size_exp list + | Eselect_slice + | Econcat | Ecopy + | Eiterator of iterator_name * longname * size_exp list * exp option + | Efield_update of longname + | Eflatten of longname | Emake of longname + +and const = + | Cint of int + | Cfloat of float + | Cconstr of longname + | Cconst_array of size_exp * const + +and pat = + | Etuplepat of pat list + | Evarpat of ident + +type eq = + { eq_desc : eqdesc; + mutable eq_statefull : bool; + eq_loc : location } + +and eqdesc = + | Eautomaton of state_handler list + | Eswitch of exp * switch_handler list + | Epresent of present_handler list * block + | Ereset of eq list * exp + | Eeq of pat * exp + +and block = + { b_local: var_dec list; + b_equs: eq list; + mutable b_defnames: ty Env.t; + mutable b_statefull: bool; + b_loc: location; } + +and state_handler = + { s_state : name; + s_block : block; + s_until : escape list; + s_unless : escape list; } + +and escape = + { e_cond : exp; + e_reset : bool; + e_next_state : name; } + +and switch_handler = + { w_name : longname; + w_block : block; } + +and present_handler = + { p_cond : exp; + p_block : block; } + +and var_dec = + { v_name : ident; + mutable v_type : base_ty; + mutable v_linearity : linearity; + v_last : last; + v_loc : location; } + +and last = Var | Last of const option + +type type_dec = + { t_name : name; + t_desc : type_desc; + t_loc : location } + +and type_desc = + | Type_abs + | Type_enum of name list + | Type_struct of (name * base_ty) list + +type contract = + { c_assume : exp; + c_enforce : exp; + c_controllables : var_dec list; + c_local : var_dec list; + c_eq : eq list; + } + +type node_dec = + { n_name : name; + n_statefull : bool; + n_input : var_dec list; + n_output : var_dec list; + n_local : var_dec list; + n_contract : contract option; + n_equs : eq list; + n_loc : location; + n_states_graph : (name,name) interf_graph; + n_params : name list; + n_params_constraints : size_constr list; + } + +type const_dec = + { c_name : name; + c_type : base_ty; + c_value : size_exp; + c_loc : location; } + +type program = + { p_pragmas: (name * string) list; + p_opened : name list; + p_types : type_dec list; + p_nodes : node_dec list; + p_consts : const_dec list; } + +type signature = + { sig_name : name; + sig_inputs : (name option * base_ty * linearity) list; + sig_outputs : (name option * base_ty * linearity) list; + sig_node : bool; + sig_safe : bool; + sig_params : name list; } + +type interface = interface_decl list + +and interface_decl = + { interf_desc : interface_desc; + interf_loc : location } + +and interface_desc = + | Iopen of name + | Itypedef of type_dec + | Isignature of signature + +let tbool = Tbool + +let edesc e = e.e_desc +let eqdesc eq = eq.eq_desc + +(* Helper functions to create AST. *) +let pbool = Modname({ qual = "Pervasives"; id = "bool" }) +let ptrue = Modname({ qual = "Pervasives"; id = "true" }) +let pfalse = Modname({ qual = "Pervasives"; id = "false" }) +let por = Modname({ qual = "Pervasives"; id = "or" }) +let pint = Modname({ qual = "Pervasives"; id = "int" }) +let pfloat = Modname({ qual = "Pervasives"; id = "float" }) + +let emake desc ty = { e_desc = desc; e_ty = ty; + e_linearity = NotLinear; e_loc = no_location } +let eop op = { a_op = op; a_inlined = Ino } +let tmake name desc = { t_name = name; t_desc = desc; t_loc = no_location } +let eqmake desc = { eq_desc = desc; eq_statefull = true; eq_loc = no_location } + +let tybool = Tbase(tbool) +let cfalse = Cconstr(pfalse) +let ctrue = Cconstr(ptrue) + +let make_bool desc = emake desc tybool +let bool_var n = make_bool (Evar(n)) +let bool_param n = + { v_name = n; v_type = tbool; v_last = Var; + v_loc = no_location; v_linearity = NotLinear } + +let dfalse = make_bool (Econst(Cconstr(pfalse))) +let dtrue = make_bool (Econst(Cconstr(ptrue))) + +let var n ty = emake (Evar(n)) ty +let param n ty = + { v_name = n; v_type = ty; v_linearity = NotLinear; + v_last = Var; v_loc = no_location } +let fby_state initial e = + { e with e_desc = Eapp(eop (Epre(Some(Cconstr initial))), [e]) } +let fby_false e = emake (Eapp(eop (Epre(Some(cfalse))), [e])) tybool +let last_false x = emake (Elast(x)) tybool +let ifthenelse e1 e2 e3 = emake (Eapp(eop Eifthenelse, [e1;e2;e3])) e2.e_ty +let rec or_op e1 e2 = { e1 with e_desc = Eapp(eop (Eop(por, [])), [e1; e2]) } +let pair e1 e2 = emake (Etuple([e1;e2])) (Tprod [e1.e_ty;e2.e_ty]) +let block defnames eqs = + { b_local = []; b_equs = eqs; b_defnames = defnames; + b_statefull = true; b_loc = no_location } +let eq pat e = eqmake (Eeq(pat, e)) +let reset eq_list e = eqmake (Ereset(eq_list, e)) +let switch e l = eqmake (Eswitch(e, l)) + +let varpat n = Evarpat(n) + +(* Helper functions to work with type*) +let base_type ty = + match ty with + | Tbase ty -> ty + | _ -> assert false + +let is_scalar_type ty = + let pint = Modname({ qual = "Pervasives"; id = "int" }) in + let pfloat = Modname({ qual = "Pervasives"; id = "float" }) in + let pbool = Modname({ qual = "Pervasives"; id = "bool" }) in + match ty with + | Tbase(Tint) | Tbase(Tfloat) | Tbase(Tbool) -> true + | Tbase(Tid name_int) when name_int = pint -> true + | Tbase(Tid name_float) when name_float = pfloat -> true + | Tbase(Tid name_bool) when name_bool = pbool -> true + | _ -> false + +let array_of ty exp = + Tbase(Tarray (base_type ty, exp)) + +let const_array_of ty n = + array_of ty (SConst n) + +let op_from_app app = + match app.a_op with + | Eop (n,_) -> op_from_app_name n + | _ -> raise Not_static + +let rec size_exp_of_exp e = + match e.e_desc with + | Econstvar n -> SVar n + | Econst (Cint i) -> SConst i + | Eapp(app, [e1;e2]) -> + let op = op_from_app app in + SOp(op, size_exp_of_exp e1, size_exp_of_exp e2) + | _ -> raise Not_static + +module Vars = +struct + let rec vars_pat locals acc = function + | Evarpat(x) -> + if (IdentSet.mem x locals) or (IdentSet.mem x acc) then + acc + else + IdentSet.add x acc + | Etuplepat(pat_list) -> List.fold_left (vars_pat locals) acc pat_list + + let rec left locals acc e = + match e.e_desc with + | Eapp({a_op = Epre _},[e]) -> acc + | Eapp({a_op = Efby}, [e1;e2]) -> left locals acc e1 + | Etuple(e_list) | Eapp({a_op = _}, e_list) | Earray(e_list)-> + List.fold_left (left locals) acc e_list + | Evar(n) | Ereset_mem (_, _, n) -> + if (IdentSet.mem n acc) or (IdentSet.mem n locals) then + acc + else + IdentSet.add n acc + | Efield(e, _) -> left locals acc e + | Estruct(f_e_list) -> + List.fold_left (fun acc (_, e) -> left locals acc e) acc f_e_list + | Elast _ | Econst _ | Econstvar _ -> acc + + let rec read locals acc eq = + match eq.eq_desc with + | Eeq(pat, e) -> left locals acc e + | Ereset(eq_list, e) -> + List.fold_left (read locals) (left locals acc e) eq_list + | Eautomaton(state_handlers) -> + let escapes locals acc e_list = + List.fold_left + (fun acc { e_cond = e } -> left locals acc e) acc e_list in + List.fold_left + (fun acc {s_block = b; s_until = e_list1; s_unless = e_list2} -> + let new_locals, acc = read_and_locals_block locals acc b in + let acc = escapes new_locals acc e_list1 in + escapes locals acc e_list2) + acc state_handlers + | Eswitch(e, switch_handlers) -> + List.fold_left + (fun acc { w_block = b } -> read_block locals acc b) + (left locals acc e) switch_handlers + | Epresent(present_handlers, b) -> + List.fold_left + (fun acc { p_cond = e; p_block = b } -> + read_block locals (left locals acc e) b) + (read_block locals acc b) present_handlers + + and read_and_locals_block locals acc { b_local = l; b_equs = eq_list } = + let locals = + List.fold_left + (fun acc { v_name = n } -> if IdentSet.mem n acc then acc else IdentSet.add n acc) + locals l in + locals, List.fold_left (read locals) acc eq_list + + and read_block locals acc b = + let _, acc = read_and_locals_block locals acc b in acc + + let rec def locals acc eq = + match eq.eq_desc with + | Eeq(pat, _) -> vars_pat locals acc pat + | Eautomaton(state_handler) -> + List.fold_left + (fun acc { s_block = b } -> + def_block locals acc b) acc state_handler + | Eswitch(_, switch_handler) -> + List.fold_left + (fun acc { w_block = b } -> + def_block locals acc b) acc switch_handler + | Epresent(present_handler, b) -> + List.fold_left + (fun acc { p_block = b } -> def_block locals acc b) + (def_block locals acc b) present_handler + | Ereset(eq_list, _) -> def_list locals acc eq_list + + and def_block locals acc ({ b_local = l; b_equs = eq_list }) = + let locals = + List.fold_left + (fun acc { v_name = n } -> if IdentSet.mem n acc then acc else IdentSet.add n acc) + locals l in + def_list locals acc eq_list + + and def_list locals acc def_list = List.fold_left (def locals) acc def_list + + let read eq = IdentSet.elements (read IdentSet.empty IdentSet.empty eq) + let def eq = IdentSet.elements (def IdentSet.empty IdentSet.empty eq) + let antidep eq = false + let vars_list pat = IdentSet.elements (vars_pat IdentSet.empty IdentSet.empty pat) +end diff --git a/heptagon/main/compiler.ml b/heptagon/main/compiler.ml new file mode 100644 index 0000000..e69de29 diff --git a/heptagon/main/hepcheck.ml b/heptagon/main/hepcheck.ml new file mode 100644 index 0000000..e69de29 diff --git a/heptagon/parsing/lexer.mll b/heptagon/parsing/lexer.mll new file mode 100644 index 0000000..a1d6c55 --- /dev/null +++ b/heptagon/parsing/lexer.mll @@ -0,0 +1,315 @@ +(* lexer.mll *) + +(* $Id$ *) + +{ +open Lexing +open Parser + +type lexical_error = + Illegal_character + | Unterminated_comment + | Bad_char_constant + | Unterminated_string;; + +exception Lexical_error of lexical_error * int * int;; + +let comment_depth = ref 0 + +let keyword_table = ((Hashtbl.create 149) : (string, token) Hashtbl.t);; + +List.iter (fun (str,tok) -> Hashtbl.add keyword_table str tok) [ + "node", NODE; + "fun", FUN; + "safe", SAFE; + "returns", RETURNS; + "var", VAR; + "val", VAL; + "const", CONST; + "unsafe", UNSAFE; + "let", LET; + "tel", TEL; + "end", END; + "fby", FBY; + "switch", SWITCH; + "when", WHEN; + "type", TYPE; + "every", EVERY; + "true", BOOL(true); + "false", BOOL(false); + "pre", PRE; + "or", OR; + "not", NOT; + "open", OPEN; + "automaton", AUTOMATON; + "switch", SWITCH; + "present", PRESENT; + "reset", RESET; + "state", STATE; + "unless", UNLESS; + "until", UNTIL; + "emit", EMIT; + "last", LAST; + "if", IF; + "then", THEN; + "else", ELSE; + "default", DEFAULT; + "continue", CONTINUE; + "case", CASE; + "do", DO; + "contract", CONTRACT; + "assume", ASSUME; + "enforce", ENFORCE; + "with", WITH; + "inlined", INLINED; + "at", AT; + "with", WITH; + "map", MAP; + "fold", FOLD; + "mapfold", MAPFOLD; + "copy", COPY; + "flatten", FLATTEN; + "make", MAKE; + "quo", INFIX3("quo"); + "mod", INFIX3("mod"); + "land", INFIX3("land"); + "lor", INFIX2("lor"); + "lxor", INFIX2("lxor"); + "lsl", INFIX4("lsl"); + "lsr", INFIX4("lsr"); + "asr", INFIX4("asr") +] + + +(* To buffer string literals *) + +let initial_string_buffer = String.create 256 +let string_buff = ref initial_string_buffer +let string_index = ref 0 + +let reset_string_buffer () = + string_buff := initial_string_buffer; + string_index := 0; + () + +(* +let incr_linenum lexbuf = + let pos = lexbuf.Lexing.lex_curr_p in + lexbuf.Lexing.lex_curr_p <- { pos with + Lexing.pos_lnum = pos.Lexing.pos_lnum + 1; + Lexing.pos_bol = pos.Lexing.pos_cnum; + } +*) + +let store_string_char c = + if !string_index >= String.length (!string_buff) then begin + let new_buff = String.create (String.length (!string_buff) * 2) in + String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff)); + string_buff := new_buff + end; + String.set (!string_buff) (!string_index) c; + incr string_index + + +let get_stored_string () = + let s = String.sub (!string_buff) 0 (!string_index) in + string_buff := initial_string_buffer; + s + +let char_for_backslash = function + 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + +let char_for_decimal_code lexbuf i = + let c = + 100 * (int_of_char(Lexing.lexeme_char lexbuf i) - 48) + + 10 * (int_of_char(Lexing.lexeme_char lexbuf (i+1)) - 48) + + (int_of_char(Lexing.lexeme_char lexbuf (i+2)) - 48) in + char_of_int(c land 0xFF) + + +} + +rule token = parse + | [' ' '\010' '\013' '\009' '\012'] + { token lexbuf } + | "." {DOT} + | "(" {LPAREN} + | ")" {RPAREN} + | "*" { STAR } + | "{" {LBRACE} + | "}" {RBRACE} + | ":" {COLON} + | ";" {SEMICOL} + | "=" {EQUAL} + | "==" {EQUALEQUAL} + | "&" {AMPERSAND} + | "&&" {AMPERAMPER} + | "||" {BARBAR} + | "," {COMMA} + | "->" {ARROW} + | "|" {BAR} + | "-" {SUBTRACTIVE "-"} + | "-." {SUBTRACTIVE "-."} + | "^" {POWER} + | "[" {LBRACKET} + | "]" {RBRACKET} + | "@" {AROBASE} + | ".." {DOUBLE_DOT} + | "<<" {DOUBLE_LESS} + | ">>" {DOUBLE_GREATER} + | (['A'-'Z']('_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9']) * as id) + {Constructor id} + | (['A'-'Z' 'a'-'z']('_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9']) * as id) + { let s = Lexing.lexeme lexbuf in + begin try + Hashtbl.find keyword_table s + with + Not_found -> IDENT id + end + } + | ['0'-'9']+ + | '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ + | '0' ['o' 'O'] ['0'-'7']+ + | '0' ['b' 'B'] ['0'-'1']+ + { INT (int_of_string(Lexing.lexeme lexbuf)) } + | ['0'-'9']+ ('.' ['0'-'9']*)? (['e' 'E'] ['+' '-']? ['0'-'9']+)? + { FLOAT (float_of_string(Lexing.lexeme lexbuf)) } + | "\"" + { reset_string_buffer(); + let string_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in + begin try + string lexbuf + with Lexical_error(Unterminated_string, _, string_end) -> + raise(Lexical_error(Unterminated_string, string_start, string_end)) + end; + lexbuf.lex_start_pos <- string_start - lexbuf.lex_abs_pos; + STRING (get_stored_string()) } + | "'" [^ '\\' '\''] "'" + { CHAR(Lexing.lexeme_char lexbuf 1) } + | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" + { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) } + | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + { CHAR(char_for_decimal_code lexbuf 2) } + | "(*@ " (['A'-'Z' 'a'-'z']('_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9']) * as id) + { + reset_string_buffer(); + let pragma_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in + begin try + pragma lexbuf + with Lexical_error(Unterminated_comment, _, pragma_end) -> + raise(Lexical_error(Unterminated_comment, pragma_start, pragma_end)) + end; + lexbuf.lex_start_pos <- pragma_start - lexbuf.lex_abs_pos; + PRAGMA(id,get_stored_string()) + } + | "(*" + { let comment_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in + comment_depth := 1; + begin try + comment lexbuf + with Lexical_error(Unterminated_comment, _, comment_end) -> + raise(Lexical_error(Unterminated_comment, + comment_start, comment_end)) + end; + token lexbuf } + | ['!' '?' '~'] + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' + '<' '=' '>' '?' '@' '^' '|' '~'] * + { PREFIX(Lexing.lexeme lexbuf) } + | ['=' '<' '>' '&' '|' '&' '$'] + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' + '?' '@' '^' '|' '~'] * + { INFIX0(Lexing.lexeme lexbuf) } + | ['@' '^'] + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' + '?' '@' '^' '|' '~'] * + { INFIX1(Lexing.lexeme lexbuf) } + | ['+' '-'] + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' + '?' '@' '^' '|' '~'] * + { INFIX2(Lexing.lexeme lexbuf) } + | "**" + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' + '?' '@' '^' '|' '~'] * + { INFIX4(Lexing.lexeme lexbuf) } + | ['*' '/' '%'] + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' + '?' '@' '^' '|' '~'] * + { INFIX3(Lexing.lexeme lexbuf) } + | eof {EOF} + | _ {raise (Lexical_error (Illegal_character, + Lexing.lexeme_start lexbuf, + Lexing.lexeme_end lexbuf))} + +and pragma = parse + "(*" + { let comment_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in + comment_depth := 1; + begin try + comment lexbuf + with Lexical_error(Unterminated_comment, _, comment_end) -> + raise(Lexical_error(Unterminated_comment, + comment_start, comment_end)) + end; + pragma lexbuf } + | "@*)" + { } + | eof + { raise(Lexical_error(Unterminated_comment,0, + Lexing.lexeme_start lexbuf)) } + + | _ + { store_string_char(Lexing.lexeme_char lexbuf 0); + pragma lexbuf } + +and comment = parse + "(*" + { comment_depth := succ !comment_depth; comment lexbuf } + | "*)" + { comment_depth := pred !comment_depth; + if !comment_depth > 0 then comment lexbuf } + | "\"" + { reset_string_buffer(); + let string_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in + begin try + string lexbuf + with Lexical_error(Unterminated_string, _, string_end) -> + raise(Lexical_error(Unterminated_string, string_start, string_end)) + end; + comment lexbuf } + | "''" + { comment lexbuf } + | "'" [^ '\\' '\''] "'" + { comment lexbuf } + | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" + { comment lexbuf } + | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + { comment lexbuf } + | eof + { raise(Lexical_error(Unterminated_comment,0, + Lexing.lexeme_start lexbuf)) } + | _ + { comment lexbuf } + +and string = parse + '"' + { () } + | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] * + { string lexbuf } + | '\\' ['\\' '"' 'n' 't' 'b' 'r'] + { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); + string lexbuf } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + { store_string_char(char_for_decimal_code lexbuf 1); + string lexbuf } + | eof + { raise (Lexical_error + (Unterminated_string, 0, Lexing.lexeme_start lexbuf)) } + | _ + { store_string_char(Lexing.lexeme_char lexbuf 0); + string lexbuf } + +(* eof *) diff --git a/heptagon/parsing/parser.mly b/heptagon/parsing/parser.mly new file mode 100644 index 0000000..9c04a1d --- /dev/null +++ b/heptagon/parsing/parser.mly @@ -0,0 +1,607 @@ +%{ +(* $Id$ *) + +open Misc +open Global +open Location +open Names +open Linearity +open Parsetree + +%} + +%token DOT LPAREN RPAREN LBRACE RBRACE COLON SEMICOL +%token EQUAL EQUALEQUAL BARBAR COMMA BAR ARROW LET TEL +%token Constructor +%token IDENT +%token INT +%token FLOAT +%token BOOL +%token CHAR +%token STRING +%token PRAGMA +%token TYPE FUN NODE RETURNS VAR VAL UNSAFE IN OPEN SAFE END CONST +%token FBY PRE SWITCH WHEN EVERY +%token OR STAR NOT +%token AMPERSAND +%token AMPERAMPER +%token AUTOMATON +%token SWITCH +%token PRESENT +%token RESET +%token STATE +%token UNLESS +%token UNTIL +%token EMIT +%token LAST +%token IF +%token THEN +%token ELSE +%token DEFAULT +%token DO +%token CONTINUE +%token CASE +%token CONTRACT +%token ASSUME +%token ENFORCE +%token WITH +%token INLINED +%token AT +%token POWER +%token LBRACKET +%token RBRACKET +%token WITH DOUBLE_DOT +%token AROBASE +%token DOUBLE_LESS DOUBLE_GREATER +%token MAP FOLD MAPFOLD +%token PREFIX +%token INFIX0 +%token INFIX1 +%token INFIX2 +%token SUBTRACTIVE +%token INFIX3 +%token INFIX4 +%token EOF +%token COPY +%token FLATTEN MAKE + +%right AROBASE +%left WITH +%nonassoc prec_ident +%nonassoc LBRACKET +%left IF ELSE +%right ARROW +%nonassoc EVERY +%left OR +%left AMPERSAND +%left INFIX0 EQUAL +%right INFIX1 +%left INFIX2 SUBTRACTIVE +%left STAR INFIX3 +%left INFIX4 +%right NOT +%right prec_uminus +%right FBY +%right PRE +%right LAST +%right prec_apply +%left POWER +%right PREFIX +%left DOT + +%start program +%type program + +%start interface +%type interface + +%% + +program: + | pragma_headers open_modules const_decs type_decs node_decs EOF + {{ p_pragmas = $1; + p_opened = List.rev $2; + p_types = $4; + p_nodes = $5; + p_consts = $3; }} +; + +pragma_headers: + | /* empty */ { [] } + | PRAGMA pragma_headers { $1 :: $2 } + +open_modules: + | /* empty */ { [] } + | open_modules OPEN Constructor { $3 :: $1 } +; + +const_decs: + | /* empty */ { [] } + | const_dec const_decs { $1 :: $2 } +; + +const_dec: + | CONST IDENT COLON ty_ident EQUAL exp + { cmake $2 $4 $6 } +; + +type_decs: + | /* empty */ { [] } + | type_dec type_decs { $1 :: $2 } +; + +type_dec: + | TYPE IDENT { tmake $2 Type_abs } + | TYPE IDENT EQUAL enum_ty_desc { tmake $2 (Type_enum ($4)) } + | TYPE IDENT EQUAL struct_ty_desc { tmake $2 (Type_struct ($4)) } +; + +enum_ty_desc: + | Constructor BAR Constructor {[$1;$3]} + | BOOL BAR BOOL {[(if $1 then "true" else "false"); + (if $3 then "true" else "false")]} + | Constructor BAR enum_ty_desc {$1 :: $3} +; + +struct_ty_desc: + | LBRACE label_ty_list RBRACE { $2 } +; + +label_ty_list: + | label_ty { [$1] } + | label_ty SEMICOL label_ty_list { $1 :: $3 } +; + +label_ty: + IDENT COLON ty_ident { ($1, fst $3) } +; + +node_decs: + | /* empty */ {[]} + | node_dec node_decs {$1 :: $2} +; + +node_dec: + | node_or_fun ident node_params LPAREN in_params RPAREN + RETURNS LPAREN out_params RPAREN + contract loc_vars LET equs TEL + {{ n_name = $2; + n_statefull = $1; + n_input = $5; + n_output = $9; + n_contract = $11; + n_local = $12; + n_equs = $14; + n_params = $3; + n_loc = Location.get_current_location () }} +; + +node_or_fun: + | NODE { true } + | FUN { false } +; + +safe: + | /* empty */ { false } + | SAFE { true } +; + +in_params: + | params {$1} +; + +params: + | /* empty */ { [] } + | nonmt_params { $1 } +; + +nonmt_params: + | param { $1 } + | param SEMICOL nonmt_params { $1 @ $3 } +; + +param: + | ident_list COLON ty_ident + { List.map (fun id -> vmake id $3 Var) $1 } +; + +out_params: + | /* empty */ { [] } + | nonmt_out_params { $1 } +; + +nonmt_out_params: + | var_last { $1 } + | var_last SEMICOL nonmt_out_params { $1 @ $3 } +; + +node_params: + | /* empty */ { [] } + | DOUBLE_LESS ident_list DOUBLE_GREATER { $2 } +; + +contract: + | /* empty */ {None} + | CONTRACT loc_vars opt_equs opt_assume enforce opt_with + {Some{c_local = $2; + c_eq = $3; + c_assume = $4; + c_enforce = $5; + c_controllables = $6 }} +; + +opt_equs: + | /* empty */ { [] } + | LET equs TEL { $2 } +; + +opt_assume: + | /* empty */ { e_true () } + | ASSUME exp { $2 } +; + +enforce: + | ENFORCE exp { $2 } +; + +opt_with: + | /* empty */ { [] } + | WITH LPAREN params RPAREN { $3 } +; + +loc_vars: + | /* empty */ { [] } + | VAR loc_params { $2 } +; + +loc_params: + | var_last SEMICOL { $1 } + | var_last SEMICOL loc_params { $1 @ $3 } +; + +var_last: + | ident_list COLON ty_ident + { List.map (fun id -> vmake id $3 Var) $1 } + | LAST IDENT COLON ty_ident EQUAL const + { [ vmake $2 $4 (Last(Some($6))) ] } + | LAST IDENT COLON ty_ident + { [ vmake $2 $4 (Last(None)) ] } +; + +ident_list: + | IDENT { [$1] } + | IDENT COMMA ident_list { $1 :: $3 } +; + +ty_ident: + | ty_ident_base + { $1, NotLinear } + | ty_ident_base AT ident + { $1, At $3 } +; + +ty_ident_base: + | IDENT + { Tid(Name($1)) } + | ty_ident_base POWER simple_exp + { Tarray ($1, $3) } +; + +equs: + | /* empty */ { [] } + | non_empty_equs opt_semi { List.rev $1 } +; + +non_empty_equs: + | equ { [$1] } + | non_empty_equs SEMICOL equ {$3 :: $1} +; + +opt_semi: + | {} + | SEMICOL {} +; + +opt_bar: + | {} + | BAR {} +; + +equ: + | pat EQUAL exp { eqmake (Eeq($1, $3)) } + | AUTOMATON automaton_handlers END + { eqmake (Eautomaton(List.rev $2)) } + | SWITCH exp opt_bar switch_handlers END + { eqmake (Eswitch($2, List.rev $4)) } + | PRESENT opt_bar present_handlers END + { eqmake (Epresent(List.rev $3, bmake [] [])) } + | PRESENT opt_bar present_handlers DEFAULT loc_vars DO equs END + { eqmake (Epresent(List.rev $3, bmake $5 $7)) } + | IF exp THEN loc_vars DO equs ELSE loc_vars DO equs END + { eqmake (Eswitch($2, + [{ w_name = Name("true"); w_block = bmake $4 $6}; + { w_name = Name("false"); w_block = bmake $8 $10 }])) } + | RESET equs EVERY exp + { eqmake (Ereset($2, $4)) } +; + +automaton_handler: + | STATE Constructor loc_vars DO equs opt_until_escapes opt_unless_escapes + { { s_state = $2; s_block = bmake $3 $5; + s_until = $6; s_unless = $7 } } +; + +automaton_handlers: + | automaton_handler + { [$1] } + | automaton_handlers automaton_handler + { $2 :: $1 } +; + +opt_until_escapes: + | { [] } + | UNTIL escapes + { List.rev $2 } +; + +opt_unless_escapes: + | { [] } + | UNLESS escapes + { List.rev $2 } +; + +escape: + | exp THEN Constructor + { { e_cond = $1; e_reset = true; e_next_state = $3 } } + | exp CONTINUE Constructor + { { e_cond = $1; e_reset = false; e_next_state = $3 } } +; + +escapes: + | escape + { [$1] } + | escapes BAR escape + { $3 :: $1 } +; + +switch_handler: + | constructor loc_vars DO equs + { { w_name = $1; w_block = bmake $2 $4 } } +; + +switch_handlers: + | switch_handler + { [$1] } + | switch_handlers BAR switch_handler + { $3 :: $1 } +; + +present_handler: + | exp loc_vars DO equs + { { p_cond = $1; p_block = bmake $2 $4 } } +; + +present_handlers: + | present_handler + { [$1] } + | present_handlers BAR present_handler + { $3 :: $1 } +; + +pat: + | IDENT {Evarpat $1} + | LPAREN ids RPAREN {Etuplepat $2} +; + +ids: + | pat COMMA pat {[$1; $3]} + | pat COMMA ids {$1 :: $3} +; + +nonmtexps: + | exp {[$1]} + | exp COMMA nonmtexps {$1 :: $3} +; + +exps: + | /* empty */ {[]} + | nonmtexps {$1} +; + +simple_exp: + | IDENT { emake (Evar $1) } + | const { emake (Econst $1) } + | LBRACE field_exp_list RBRACE + { emake (Estruct($2)) } + | LBRACKET array_exp_list RBRACKET + { emake (Earray $2) } + | LPAREN tuple_exp RPAREN + { emake (Etuple $2) } + | LPAREN exp RPAREN + { $2 } +; + +node_name: + | longname call_params + { Enode($1, $2) } + +exp: + | simple_exp { $1 } + | simple_exp FBY exp + { emake (Eapp(eop (Efby), [$1; $3])) } + | PRE exp + { emake (Eapp(eop (Epre(None)), [$2])) } + | node_name LPAREN exps RPAREN %prec prec_apply + { emake (Eapp(eop $1, $3)) } + | INLINED node_name LPAREN exps RPAREN %prec prec_apply + { emake (Eapp(eop_inlined $2, $4)) } + | NOT exp + { emake (Eapp(eop (Eop(Name("not"),[])), [$2])) } + | exp INFIX4 exp + { emake (Eapp(eop (Eop(Name($2),[])), [$1; $3])) } + | exp INFIX3 exp + { emake (Eapp(eop (Eop(Name($2),[])), [$1; $3])) } + | exp INFIX2 exp + { emake (Eapp(eop (Eop(Name($2),[])), [$1; $3])) } + | exp INFIX1 exp + { emake (Eapp(eop (Eop(Name($2),[])), [$1; $3])) } + | exp INFIX0 exp + { emake (Eapp(eop (Eop(Name($2),[])), [$1; $3])) } + | exp EQUAL exp + { emake (Eapp(eop (Eop(Name("="),[])), [$1; $3])) } + | exp OR exp + { emake (Eapp(eop (Eop(Name("or"),[])), [$1; $3])) } + | exp STAR exp + { emake (Eapp(eop (Eop(Name("*"),[])), [$1; $3])) } + | exp AMPERSAND exp + { emake (Eapp(eop (Eop(Name("&"),[])), [$1; $3])) } + | exp SUBTRACTIVE exp + { emake (Eapp(eop (Eop(Name($2),[])), [$1; $3])) } + | PREFIX exp + { emake (Eapp(eop (Eop(Name($1),[])), [$2])) } + | SUBTRACTIVE exp %prec prec_uminus + { emake (Eapp(eop (Eop(Name("~" ^ $1),[])), [$2])) } + | IF exp THEN exp ELSE exp + { emake (Eapp(eop Eifthenelse, [$2; $4; $6])) } + | simple_exp ARROW exp + { emake (Eapp(eop Earrow, [$1; $3])) } + | LAST IDENT + { emake (Elast($2)) } + | exp DOT longname { emake (Efield($1, $3)) } +/*Array operations*/ + | exp POWER simple_exp + { emake (Eapp(eop (Erepeat), [$1; $3])) } + | exp indexes + { emake (Eapp(eop (Eselect $2), [$1])) } + | exp DOT indexes DEFAULT exp + { emake (Eapp(eop (Eselect_dyn), [$1; $5]@$3)) } + | exp WITH indexes EQUAL exp + { emake (Eapp(eop (Eupdate $3), [$1; $5])) } + | exp LBRACKET exp DOUBLE_DOT exp RBRACKET + { emake (Eapp(eop Eselect_slice, [$1; $3; $5])) } + | exp AROBASE exp + { emake (Eapp(eop Econcat, [$1; $3])) } +/*Iterators*/ + | iterator longname DOUBLE_LESS simple_exp DOUBLE_GREATER LPAREN exps RPAREN %prec prec_apply + { emake (Eapp(eop (Eiterator ($1, $2, [])), $4::$7)) } + | iterator LPAREN longname DOUBLE_LESS array_exp_list DOUBLE_GREATER + RPAREN DOUBLE_LESS simple_exp DOUBLE_GREATER LPAREN exps RPAREN %prec prec_apply + { emake (Eapp(eop (Eiterator ($1, $3, $5)), $9::$12)) } + | COPY LPAREN exp RPAREN %prec prec_apply + { emake (Eapp(eop Ecopy, [$3])) } +/*Records operators */ + | exp WITH DOT longname EQUAL exp + { emake (Eapp(eop (Efield_update $4), [$1; $6])) } + | LPAREN FLATTEN longname RPAREN LPAREN exps RPAREN + { emake (Eapp(eop (Eflatten $3), $6)) } + | LPAREN MAKE longname RPAREN LPAREN exps RPAREN + { emake (Eapp(eop (Emake $3), $6)) } +; + +call_params: + | /* empty */ { [] } + | DOUBLE_LESS array_exp_list DOUBLE_GREATER { $2 } +; + +iterator: + | MAP { Imap } + | FOLD { Ifold } + | MAPFOLD { Imapfold } +; + +indexes: + LBRACKET exp RBRACKET { [$2] } + | LBRACKET exp RBRACKET indexes { $2::$4 } +; + +constructor: + | Constructor { Name($1) } %prec prec_ident + | Constructor DOT Constructor { Modname({qual = $1; id = $3}) } + | BOOL { Name(if $1 then "true" else "false") } +; + +longname: + | ident { Name($1) } + | Constructor DOT ident { Modname({qual = $1; id = $3}) } +; + +const: + | INT { Cint($1) } + | FLOAT { Cfloat($1) } + | constructor { Cconstr($1) } +; + +tuple_exp: + | exp COMMA exp {[$1; $3]} + | exp COMMA tuple_exp {$1 :: $3} +; + +field_exp_list: + | field_exp { [$1] } + | field_exp SEMICOL field_exp_list { $1 :: $3 } +; + +array_exp_list: + | exp { [$1] } + | exp COMMA array_exp_list { $1 :: $3 } +; + +field_exp: + | longname EQUAL exp { ($1, $3) } +; + +/* identifiers */ +ident: + | IDENT + { $1 } + | LPAREN infx RPAREN + { $2 } +; + +infx: + | INFIX0 { $1 } + | INFIX1 { $1 } | INFIX2 { $1 } + | INFIX3 { $1 } | INFIX4 { $1 } + | STAR { "*" } + | EQUAL { "=" } + | EQUALEQUAL { "==" } + | SUBTRACTIVE { $1 } | PREFIX { $1 } + | AMPERSAND { "&" } | AMPERAMPER { "&&" } + | OR { "or" } | BARBAR { "||" } + | NOT { "not" } +; + +interface: + | interface_decls EOF { List.rev $1 } +; + +interface_decls: + | /* empty */ { [] } + | interface_decls interface_decl { $2 :: $1 } +; + +interface_decl: + | type_dec { imake (Itypedef($1)) } + | OPEN Constructor { imake (Iopen($2)) } + | VAL safe node_or_fun ident node_params LPAREN params_signature RPAREN + RETURNS LPAREN params_signature RPAREN + { imake (Isignature({ sig_name = $4; sig_inputs = $7; sig_outputs = $11; + sig_node = $3; sig_safe = $2; sig_params = $5; })) } +; + +params_signature: + | /* empty */ {[]} + | nonmt_params_signature {$1} +; + +nonmt_params_signature: + | param_signature { [$1] } + | param_signature SEMICOL nonmt_params_signature { $1 :: $3 } +; + +param_signature: + | IDENT COLON ty_ident { (Some($1), $3) } + | ty_ident { (None, $1) } +; + +%% diff --git a/heptagon/parsing/parsetree.ml b/heptagon/parsing/parsetree.ml new file mode 100644 index 0000000..d1c2d77 --- /dev/null +++ b/heptagon/parsing/parsetree.ml @@ -0,0 +1,195 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* the internal representation *) +(* $Id$ *) + +open Location +open Names +open Linearity +open Misc + +type inlining_policy = + | Ino + | Ione + | Irec + +type ty = + | Tprod of ty list + | Tid of longname + | Tarray of ty * exp + +and exp = + { e_desc: desc; + e_loc: location } + +and desc = + | Econst of const + | Evar of name + | Elast of name + | Etuple of exp list + | Eapp of app * exp list + | Efield of exp * longname + | Estruct of (longname * exp) list + | Earray of exp list + +and app = + { a_op : op; (* change of global name after typing *) + a_inlined : inlining_policy; (* node to inline or not *) + } + +and op = + | Epre of const option + | Efby | Earrow | Eifthenelse | Enode of longname * exp list + | Eevery of longname * exp list | Eop of longname * exp list + | Erepeat | Eselect of exp list | Eselect_dyn + | Eupdate of exp list + | Eselect_slice + | Econcat | Ecopy + | Eiterator of iterator_name * longname * exp list + | Efield_update of longname + | Eflatten of longname | Emake of longname + +and const = + | Cint of int + | Cfloat of float + | Cconstr of longname + +and pat = + | Etuplepat of pat list + | Evarpat of name + +type eq = + { eq_desc : eqdesc; + eq_loc : location } + +and eqdesc = + | Eautomaton of state_handler list + | Eswitch of exp * switch_handler list + | Epresent of present_handler list * block + | Ereset of eq list * exp + | Eeq of pat * exp + +and block = + { b_local: var_dec list; + b_equs: eq list; + b_loc: location; } + +and state_handler = + { s_state : name; + s_block : block; + s_until : escape list; + s_unless : escape list; } + +and escape = + { e_cond : exp; + e_reset : bool; + e_next_state : name; } + +and switch_handler = + { w_name : longname; + w_block : block; } + +and present_handler = + { p_cond : exp; + p_block : block; } + +and var_dec = + { v_name : name; + v_type : ty; + v_linearity : linearity; + v_last : last; + v_loc : location; } + +and last = Var | Last of const option + +type type_dec = + { t_name : name; + t_desc : type_desc; + t_loc : location } + +and type_desc = + | Type_abs + | Type_enum of name list + | Type_struct of (name * ty) list + +type contract = + { c_assume : exp; + c_enforce : exp; + c_controllables : var_dec list; + c_local : var_dec list; + c_eq : eq list; + } + +type node_dec = + { n_name : name; + n_statefull : bool; + n_input : var_dec list; + n_output : var_dec list; + n_local : var_dec list; + n_contract : contract option; + n_equs : eq list; + n_loc : location; + n_params : name list; } + +type const_dec = + { c_name : name; + c_type : ty; + c_value : exp; + c_loc : location; } + +type program = + { p_pragmas: (name * string) list; + p_opened : name list; + p_types : type_dec list; + p_nodes : node_dec list; + p_consts : const_dec list; } + +type signature = + { sig_name : name; + sig_inputs : (name option * (ty * linearity)) list; + sig_outputs : (name option * (ty * linearity)) list; + sig_node : bool; + sig_safe : bool; + sig_params : name list; } + +type interface = interface_decl list + +and interface_decl = + { interf_desc : interface_desc; + interf_loc : location } + +and interface_desc = + | Iopen of name + | Itypedef of type_dec + | Isignature of signature + +(* Helper functions to create AST. *) +let emake desc = + { e_desc = desc; e_loc = get_current_location () } +let e_true () = + emake (Econst(Cconstr(Modname{ qual="Pervasives"; id="true"}))) +let eop op = { a_op = op; a_inlined = Ino } +let eop_inlined op = { a_op = op; a_inlined = Ione } +let tmake name desc = + { t_name = name; t_desc = desc; t_loc = get_current_location () } +let eqmake desc = + { eq_desc = desc; eq_loc = get_current_location () } +let imake desc = + { interf_desc = desc; interf_loc = get_current_location () } +let vmake name (ty, linearity) last = + { v_name = name; v_type = ty; v_linearity = linearity; + v_last = last; v_loc = get_current_location () } + +let bmake locals eqs = + { b_local = locals; b_equs = eqs; + b_loc = get_current_location () } + +let cmake id (ty,_) e = + { c_name = id; c_type = ty; c_value = e; + c_loc = get_current_location (); } diff --git a/heptagon/parsing/scoping.ml b/heptagon/parsing/scoping.ml new file mode 100644 index 0000000..35a378c --- /dev/null +++ b/heptagon/parsing/scoping.ml @@ -0,0 +1,334 @@ +(** Scoping. Introduces unique indexes for local names and replace global + names by qualified names *) + +open Location +open Parsetree +open Names +open Ident +open Format +open Printf +open Static + +module Error = +struct + type error = + | Evar of string + | Econst_var of string + | Evariable_already_defined of string + | Econst_variable_already_defined of string + | Estatic_exp_expected + + let message loc kind = + begin match kind with + | Evar name -> + eprintf "%aThe value identifier %s is unbound.\n" + output_location loc + name + | Econst_var name -> + eprintf "%aThe const identifier %s is unbound.\n" + output_location loc + name + | Evariable_already_defined name -> + eprintf "%aThe variable %s is already defined.\n" + output_location loc + name + | Econst_variable_already_defined name -> + eprintf "%aThe const variable %s is already defined.\n" + output_location loc + name + | Estatic_exp_expected -> + eprintf "%aA static expression was expected.\n" + output_location loc + end; + raise Misc.Error +end + +module Rename = +struct + include + (Map.Make (struct type t = string let compare = String.compare end)) + let append env0 env = + fold (fun key v env -> add key v env) env0 env + + let name loc env n = + try + find n env + with + Not_found -> Error.message loc (Error.Evar(n)) +end + +(*Functions to build the renaming map*) +let add_var loc x env = + if Rename.mem x env then + Error.message loc (Error.Evariable_already_defined x) + else (* create a new id for this var and add it to the env *) + Rename.add x (ident_of_var x) env + +let add_const_var loc x env = + if NamesEnv.mem x env then + Error.message loc (Error.Econst_variable_already_defined x) + else (* create a new id for this var and add it to the env *) + NamesEnv.add x (ident_of_var x) env + +let rec build_pat loc env = function + | Evarpat x -> add_var loc x env + | Etuplepat l -> + List.fold_left (build_pat loc) env l + +let build_vd_list env l = + let build_vd env vd = + add_var vd.v_loc vd.v_name env + in + List.fold_left build_vd env l + +let build_cd_list env l = + let build_cd env cd = + add_const_var cd.c_loc cd.c_name env + in + List.fold_left build_cd env l + +let build_id_list loc env l = + let build_id env id = + add_const_var loc id env + in + List.fold_left build_id env l + +(* Translate the AST into Heptagon. *) +let translate_inlining_policy = function + | Ino -> Heptagon.Ino + | Ione -> Heptagon.Ione + | Irec -> Heptagon.Irec + +let translate_const = function + | Cint i -> Heptagon.Cint i + | Cfloat f -> Heptagon.Cfloat f + | Cconstr ln -> Heptagon.Cconstr ln + +let op_from_app loc app = + match app.a_op with + | Eop (op,_) -> op_from_app_name op + | _ -> Error.message loc Error.Estatic_exp_expected + +let check_const_vars = ref true +let rec translate_size_exp const_env e = + match e.e_desc with + | Evar n -> + if !check_const_vars & not (NamesEnv.mem n const_env) then + Error.message e.e_loc (Error.Econst_var n) + else + SVar n + | Econst (Cint i) -> SConst i + | Eapp(app, [e1;e2]) -> + let op = op_from_app e.e_loc app in + SOp(op, translate_size_exp const_env e1, translate_size_exp const_env e2) + | _ -> Error.message e.e_loc Error.Estatic_exp_expected + +let rec translate_type const_env = function + | Tprod ty_list -> + Heptagon.Tprod(List.map (translate_type const_env) ty_list) + | Tid ln -> Heptagon.Tbase (Heptagon.Tid ln) + | Tarray (ty, e) -> + let ty = Heptagon.base_type (translate_type const_env ty) in + Heptagon.Tbase (Heptagon.Tarray (ty, translate_size_exp const_env e)) + +and translate_exp const_env env e = + { Heptagon.e_desc = translate_desc e.e_loc const_env env e.e_desc; + Heptagon.e_ty = Heptagon.Tprod []; + Heptagon.e_linearity = Linearity.NotLinear; + Heptagon.e_loc = e.e_loc } + +and translate_app const_env env app = + let op = match app.a_op with + | Epre None -> Heptagon.Epre None + | Epre (Some c) -> Heptagon.Epre (Some (translate_const c)) + | Efby -> Heptagon.Efby + | Earrow -> Heptagon.Earrow + | Eifthenelse -> Heptagon.Eifthenelse + | Erepeat -> Heptagon.Erepeat + | Eselect_slice -> Heptagon.Eselect_slice + | Econcat -> Heptagon.Econcat + | Ecopy -> Heptagon.Ecopy + | Eselect_dyn -> Heptagon.Eselect_dyn + | Enode (ln, params) -> Heptagon.Enode (ln, List.map (translate_size_exp const_env) params) + | Eevery (ln, params) -> Heptagon.Eevery (ln, List.map (translate_size_exp const_env) params) + | Eop (ln, params) -> Heptagon.Eop (ln, List.map (translate_size_exp const_env) params) + | Eselect e_list -> Heptagon.Eselect (List.map (translate_size_exp const_env) e_list) + | Eupdate e_list -> Heptagon.Eupdate (List.map (translate_size_exp const_env) e_list) + | Eiterator (it, ln, params) -> + Heptagon.Eiterator (it, ln, List.map (translate_size_exp const_env) params, None) + | Efield_update f -> Heptagon.Efield_update f + | Emake f -> Heptagon.Emake f + | Eflatten f -> Heptagon.Eflatten f + in + { Heptagon.a_op = op; + Heptagon.a_inlined = translate_inlining_policy app.a_inlined } + +and translate_desc loc const_env env = function + | Econst c -> Heptagon.Econst (translate_const c) + | Evar x -> + if Rename.mem x env then + Heptagon.Evar (Rename.name loc env x) + else if NamesEnv.mem x const_env then (* var not defined, maybe a const var*) + Heptagon.Econstvar x + else + Error.message loc (Error.Evar x) + | Elast x -> Heptagon.Elast (Rename.name loc env x) + | Etuple e_list -> Heptagon.Etuple (List.map (translate_exp const_env env) e_list) + | Eapp ({ a_op = Erepeat} as app, e_list) -> + let e_list = List.map (translate_exp const_env env) e_list in + (match e_list with + | [{ Heptagon.e_desc = Heptagon.Econst c }; e1 ] -> + Heptagon.Econst (Heptagon.Cconst_array (Heptagon.size_exp_of_exp e1, c)) + | _ -> Heptagon.Eapp (translate_app const_env env app, e_list) + ) + | Eapp (app, e_list) -> + let e_list = List.map (translate_exp const_env env) e_list in + Heptagon.Eapp (translate_app const_env env app, e_list) + | Efield (e, field) -> Heptagon.Efield (translate_exp const_env env e, field) + | Estruct f_e_list -> + let f_e_list = List.map (fun (f,e) -> f, translate_exp const_env env e) f_e_list in + Heptagon.Estruct f_e_list + | Earray e_list -> Heptagon.Earray (List.map (translate_exp const_env env) e_list) + +and translate_pat loc env = function + | Evarpat x -> Heptagon.Evarpat (Rename.name loc env x) + | Etuplepat l -> Heptagon.Etuplepat (List.map (translate_pat loc env) l) + +let rec translate_eq const_env env eq = + { Heptagon.eq_desc = translate_eq_desc eq.eq_loc const_env env eq.eq_desc ; + Heptagon.eq_statefull = false; + Heptagon.eq_loc = eq.eq_loc } + +and translate_eq_desc loc const_env env = function + | Eswitch(e, switch_handlers) -> + Heptagon.Eswitch (translate_exp const_env env e, + List.map (translate_switch_handler loc const_env env) switch_handlers) + | Eeq(p, e) -> + Heptagon.Eeq (translate_pat loc env p, translate_exp const_env env e) + | Epresent (present_handlers, b) -> + Heptagon.Epresent (List.map (translate_present_handler const_env env) present_handlers, + translate_block const_env env b) + | Eautomaton state_handlers -> + Heptagon.Eautomaton (List.map (translate_state_handler const_env env) state_handlers) + | Ereset (eq_list, e) -> + Heptagon.Ereset (List.map (translate_eq const_env env) eq_list, + translate_exp const_env env e) + +and translate_block const_env env b = + let env = build_vd_list env b.b_local in + + { Heptagon.b_local = translate_vd_list const_env env b.b_local; + Heptagon.b_equs = List.map (translate_eq const_env env) b.b_equs; + Heptagon.b_defnames = Env.empty ; + Heptagon.b_statefull = false; + Heptagon.b_loc = b.b_loc } + +and translate_state_handler const_env env sh = + { Heptagon.s_state = sh.s_state; + Heptagon.s_block = translate_block const_env env sh.s_block; + Heptagon.s_until = List.map (translate_escape const_env env) sh.s_until; + Heptagon.s_unless = List.map (translate_escape const_env env) sh.s_unless; } + +and translate_escape const_env env esc = + { Heptagon.e_cond = translate_exp const_env env esc.e_cond; + Heptagon.e_reset = esc.e_reset; + Heptagon.e_next_state = esc.e_next_state } + +and translate_present_handler const_env env ph = + { Heptagon.p_cond = translate_exp const_env env ph.p_cond; + Heptagon.p_block = translate_block const_env env ph.p_block } + +and translate_switch_handler loc const_env env sh = + { Heptagon.w_name = sh.w_name; + Heptagon.w_block = translate_block const_env env sh.w_block } + +and translate_var_dec const_env env vd = + { Heptagon.v_name = Rename.name vd.v_loc env vd.v_name; + Heptagon.v_type = Heptagon.base_type (translate_type const_env vd.v_type); + Heptagon.v_linearity = vd.v_linearity; + Heptagon.v_last = translate_last env vd.v_last; + Heptagon.v_loc = vd.v_loc } + +and translate_vd_list const_env env = + List.map (translate_var_dec const_env env) + +and translate_last env = function + | Var -> Heptagon.Var + | Last (None) -> Heptagon.Last None + | Last (Some c) -> Heptagon.Last (Some (translate_const c)) + +let translate_contract const_env env ct = + { Heptagon.c_assume = translate_exp const_env env ct.c_assume; + Heptagon.c_enforce = translate_exp const_env env ct.c_enforce; + Heptagon.c_controllables = translate_vd_list const_env env ct.c_controllables; + Heptagon.c_local = translate_vd_list const_env env ct.c_local; + Heptagon.c_eq = List.map (translate_eq const_env env) ct.c_eq } + +let translate_node const_env env node = + let const_env = build_id_list node.n_loc const_env node.n_params in + let env = build_vd_list env (node.n_input @ node.n_output @ node.n_local) in + { Heptagon.n_name = node.n_name; + Heptagon.n_statefull = node.n_statefull; + Heptagon.n_input = translate_vd_list const_env env node.n_input; + Heptagon.n_output = translate_vd_list const_env env node.n_output; + Heptagon.n_local = translate_vd_list const_env env node.n_local; + Heptagon.n_contract = Misc.optional (translate_contract const_env env) node.n_contract; + Heptagon.n_equs = List.map (translate_eq const_env env) node.n_equs; + Heptagon.n_loc = node.n_loc; + Heptagon.n_states_graph = Interference_graph.mk_graph [] ""; + Heptagon.n_params = node.n_params; + Heptagon.n_params_constraints = []; } + +let translate_typedec const_env ty = + let onetype = function + | Type_abs -> Heptagon.Type_abs + | Type_enum(tag_list) -> Heptagon.Type_enum(tag_list) + | Type_struct(field_ty_list) -> + let translate_field_type (f,ty) = + f, Heptagon.base_type (translate_type const_env ty) + in + Heptagon.Type_struct (List.map translate_field_type field_ty_list) + in + { Heptagon.t_name = ty.t_name; + Heptagon.t_desc = onetype ty.t_desc; + Heptagon.t_loc = ty.t_loc } + +let translate_const_dec const_env cd = + { Heptagon.c_name = cd.c_name; + Heptagon.c_type = Heptagon.base_type (translate_type const_env cd.c_type); + Heptagon.c_value = translate_size_exp const_env cd.c_value; + Heptagon.c_loc = cd.c_loc; } + +let translate_program p = + let const_env = build_cd_list NamesEnv.empty p.p_consts in + { Heptagon.p_pragmas = p.p_pragmas; + Heptagon.p_opened = p.p_opened; + Heptagon.p_types = List.map (translate_typedec const_env) p.p_types; + Heptagon.p_nodes = List.map (translate_node const_env Rename.empty) p.p_nodes; + Heptagon.p_consts = List.map (translate_const_dec const_env) p.p_consts; } + +let translate_signature const_env s = + let translate_field_type (f,(ty,lin)) = + f, Heptagon.base_type (translate_type const_env ty), lin + in + + let const_env = build_id_list no_location const_env s.sig_params in + { Heptagon.sig_name = s.sig_name; + Heptagon.sig_inputs = List.map translate_field_type s.sig_inputs; + Heptagon.sig_outputs = List.map translate_field_type s.sig_outputs; + Heptagon.sig_node = s.sig_node; + Heptagon.sig_safe = s.sig_safe; + Heptagon.sig_params = s.sig_params; } + +let translate_interface_desc const_env = function + | Iopen n -> Heptagon.Iopen n + | Itypedef tydec -> Heptagon.Itypedef (translate_typedec const_env tydec) + | Isignature s -> Heptagon.Isignature (translate_signature const_env s) + +let translate_interface_decl const_env idecl = + { Heptagon.interf_desc = translate_interface_desc const_env idecl.interf_desc; + Heptagon.interf_loc = idecl.interf_loc } + +let translate_interface = + List.map (translate_interface_decl NamesEnv.empty) + diff --git a/heptagon/printer.ml b/heptagon/printer.ml new file mode 100644 index 0000000..5042bbc --- /dev/null +++ b/heptagon/printer.ml @@ -0,0 +1,459 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* the printer *) + +(* $Id$ *) + +open Location +open Misc +open Names +open Ident +open Heptagon +open Modules +open Static +open Format + +let rec print_list ff print sep l = + match l with + | [] -> () + | [x] -> print ff x + | x :: l -> + print ff x; + fprintf ff "%s@ " sep; + print_list ff print sep l + +(* Infix chars are surrounded by parenthesis *) +let is_infix = + let module StrSet = Set.Make(String) in + let set_infix = + List.fold_right + StrSet.add + ["or"; "quo"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] + StrSet.empty in + fun s -> StrSet.mem s set_infix + +let print_name ff s = + let c = String.get s 0 in + let s = if is_infix s then "(" ^ s ^ ")" + else match c with + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> s + | '*' -> "( " ^ s ^ " )" + | _ -> if s = "()" then s else "(" ^ s ^ ")" in + fprintf ff "%s" s + +let print_longname ff ln = + let ln = currentname ln in + match ln with + | Name(m) -> print_name ff m + | Modname({ qual = "Pervasives"; id = m }) -> + print_name ff m + | Modname({ qual = m1; id = m2 }) -> + fprintf ff "%s." m1; print_name ff m2 + +let print_ident ff id = + fprintf ff "%s" (name id) + +let print_iterator ff it = + fprintf ff "%s" (iterator_to_string it) + +let rec print_pat ff = function + | Evarpat(n) -> print_ident ff n + | Etuplepat(pat_list) -> + fprintf ff "@[("; + print_list ff print_pat "," pat_list; + fprintf ff ")@]" + +let rec print_base_type ff = function + | Tint -> fprintf ff "int" + | Tbool -> fprintf ff "bool" + | Tfloat -> fprintf ff "float" + | Tid(id) -> print_longname ff id + | Tarray(ty, e) -> + print_base_type ff ty; + fprintf ff "^"; + print_size_exp ff e; + +and print_type ff = function + | Tbase(base_ty) -> print_base_type ff base_ty + | Tprod(ty_list) -> + fprintf ff "@[("; + print_list ff print_type " *" ty_list; + fprintf ff ")@]" + +and print_c ff = function + | Cint i -> fprintf ff "%d" i + | Cfloat f -> fprintf ff "%f" f + | Cconstr(tag) -> print_longname ff tag + | Cconst_array (n, c) -> + print_c ff c; + fprintf ff "^"; + print_size_exp ff n + +and print_vd ff { v_name = n; v_type = ty; v_last = last } = + fprintf ff "@["; + begin match last with Last _ -> fprintf ff "last " | _ -> () end; + print_ident ff n; + fprintf ff ": "; + print_base_type ff ty; + begin + match last with Last(Some(v)) -> fprintf ff "= ";print_c ff v + | _ -> () + end; + fprintf ff "@]" + +and print_exps ff e_list = + fprintf ff "@[("; print_list ff print_exp "," e_list; fprintf ff ")@]" + +and print_exp ff e = + if !Misc.full_type_info then fprintf ff "("; + begin match e.e_desc with + | Evar x -> print_ident ff x + | Econstvar x -> print_name ff x + | Elast x -> fprintf ff "last "; print_ident ff x + | Econst c -> print_c ff c + | Eapp({ a_op = op }, e_list) -> print_op ff op e_list + | Etuple(e_list) -> + fprintf ff "@[("; + print_list ff print_exp "," e_list; + fprintf ff ")@]" + | Efield(e, field) -> + print_exp ff e; fprintf ff "."; + print_longname ff field + | Estruct(f_e_list) -> + fprintf ff "@[{"; + print_list ff + (fun ff (field, e) -> print_longname ff field;fprintf ff " = "; + print_exp ff e) + ";" f_e_list; + fprintf ff "}@]" + | Earray(e_list) -> + fprintf ff "@[["; + print_list ff print_exp "," e_list; + fprintf ff "]@]" + | Ereset_mem(y,v,res) -> + fprintf ff "@[reset_mem "; + print_ident ff y; + fprintf ff " = "; + print_exp ff v; + fprintf ff " every "; + print_ident ff res; + fprintf ff "@]" + end; + if !Misc.full_type_info then fprintf ff " : %a)" print_type e.e_ty + +and print_call_params ff = function + | [] -> () + | l -> + fprintf ff "<<"; + print_list ff print_size_exp "," l; + fprintf ff ">>" + +and print_op ff op e_list = + match op, e_list with + | Epre(None), [e] -> fprintf ff "pre "; print_exp ff e + | Epre(Some(c)), [e] -> print_c ff c; fprintf ff " fby "; print_exp ff e + | Efby, [e1;e2] -> print_exp ff e1; fprintf ff " fby "; print_exp ff e2 + | Earrow, [e1;e2] -> print_exp ff e1; fprintf ff " -> "; print_exp ff e2 + | Eifthenelse,[e1;e2;e3] -> + fprintf ff "@["; fprintf ff "if "; print_exp ff e1; + fprintf ff "@ then@ "; print_exp ff e2; + fprintf ff "@ else@ "; print_exp ff e3; + fprintf ff "@]" + | Enode(f, params), e_list -> + print_longname ff f; + print_call_params ff params; + fprintf ff "(@["; print_list ff print_exp "," e_list; + fprintf ff ")@]" + | Eevery(f,params), e_list -> + print_longname ff f; + print_call_params ff params; + fprintf ff "(@["; print_list ff print_exp "," e_list; + fprintf ff ")@]" + | Eop(f, params), e_list -> + print_longname ff f; + print_call_params ff params; + fprintf ff "(@["; print_list ff print_exp "," e_list; + fprintf ff ")@]" + | Erepeat, [e1; e2] -> + print_exp ff e1; + fprintf ff "^"; + print_exp ff e2 + | Eselect idx_list, [e] -> + print_exp ff e; + fprintf ff "["; + print_list ff print_size_exp "][" idx_list; + fprintf ff "]" + | Eselect_dyn, e::defe::idx_list -> + fprintf ff "@[("; + print_exp ff e; + fprintf ff "["; + print_list ff print_exp "][" idx_list; + fprintf ff "] default "; + print_exp ff defe; + fprintf ff ")@]" + | Eupdate idx_list, [e1;e2] -> + fprintf ff "(@["; + print_exp ff e1; + fprintf ff " with ["; + print_list ff print_size_exp "][" idx_list; + fprintf ff "] = "; + print_exp ff e2; + fprintf ff ")@]" + | Eselect_slice, [e; idx1; idx2] -> + print_exp ff e; + fprintf ff "["; + print_exp ff idx1; + fprintf ff ".."; + print_exp ff idx2; + fprintf ff "]" + | Eiterator (it, op, params, reset), e::e_list -> + fprintf ff "("; + print_iterator ff it; + fprintf ff " "; + (match params with + | [] -> print_longname ff op + | l -> + fprintf ff "("; + print_longname ff op; + print_call_params ff params; + fprintf ff ")" + ); + fprintf ff " <<"; + print_exp ff e; + fprintf ff ">>) (@["; + print_list ff print_exp "," e_list; + fprintf ff ")@]"; + (match reset with + | None -> () + | Some r -> fprintf ff " every %a" print_exp r + ) + | Econcat, [e1;e2] -> + fprintf ff "@["; + print_exp ff e1; + fprintf ff " @@ "; + print_exp ff e2; + fprintf ff "@]" + | Ecopy, [e] -> + fprintf ff "@[copy ("; + print_exp ff e; + fprintf ff ")@]" + | Efield_update f, [e1;e2] -> + fprintf ff "(@["; + print_exp ff e1; + fprintf ff " with ."; + print_longname ff f; + fprintf ff " = "; + print_exp ff e2; + fprintf ff ")@]" + | Eflatten n, e_list -> + fprintf ff "@[(flatten "; + print_longname ff n; + fprintf ff ")("; + print_list ff print_exp "," e_list; + fprintf ff ")@]" + | Emake n, e_list -> + fprintf ff "@[(make "; + print_longname ff n; + fprintf ff ")("; + print_list ff print_exp "," e_list; + fprintf ff ")@]" + | _ -> assert false + +let rec print_eq ff eq = + match eq.eq_desc with + | Eeq(p, e) -> + fprintf ff "@["; + print_pat ff p; + fprintf ff " =@ "; + print_exp ff e; + fprintf ff "@]" + | Eautomaton(state_handler_list) -> + fprintf ff "@[automaton@,"; + fprintf ff "@["; + print_list ff print_state_handler "" state_handler_list; + fprintf ff "@]@,"; + fprintf ff "end@]" + | Eswitch(e, switch_handler_list) -> + fprintf ff "@[switch "; + print_exp ff e; + fprintf ff "@,@["; + print_list ff print_switch_handler "" switch_handler_list; + fprintf ff "@]@,"; + fprintf ff "end@]" + | Epresent(present_handler_list, b) -> + fprintf ff "@[present@,"; + print_list ff print_present_handler "" present_handler_list; + if b.b_equs <> [] then begin + fprintf ff " @[default@,"; + print_block ff b; + fprintf ff "@]" + end; + fprintf ff "@,end@]" + | Ereset(eq_list, e) -> + fprintf ff "@[reset@,"; + fprintf ff " @["; + print_eq_list ff eq_list; + fprintf ff "@]"; + fprintf ff "@,every "; + print_exp ff e; + fprintf ff "@]" + +and print_eq_list ff = function + | [] -> () + | [eq] -> print_eq ff eq;fprintf ff ";" + | eq :: l -> print_eq ff eq;fprintf ff ";@,";print_eq_list ff l + +and print_state_handler ff + { s_state = s; s_block = b; s_until = until; s_unless = unless } = + fprintf ff " @[state "; + fprintf ff "%s@," s; + print_block ff b; + if until <> [] then + begin + fprintf ff "@,@[until "; + print_list ff print_escape "" until; + fprintf ff "@]" + end; + if unless <> [] then + begin + fprintf ff "@,@[unless "; + print_list ff print_escape " " unless; + fprintf ff "@]" + end; + fprintf ff "@]" + +and print_switch_handler ff { w_name = tag; w_block = b } = + fprintf ff " @[| "; + print_longname ff tag; + fprintf ff "@,"; + print_block ff b; + fprintf ff "@]" + +and print_present_handler ff { p_cond = e; p_block = b } = + fprintf ff " @[| "; + print_exp ff e; + fprintf ff "@,"; + print_block ff b; + fprintf ff "@]" + +and print_escape ff { e_cond = e; e_reset = r; e_next_state = ns} = + fprintf ff "@,| "; + print_exp ff e; + if r then fprintf ff " then " else fprintf ff " continue "; + print_name ff ns + +and print_block ff { b_local = v_list; b_equs = eqs; b_defnames = defnames } = + if v_list <> [] then + begin + fprintf ff "@[var "; + print_list ff print_vd ";" v_list; + fprintf ff "@]@," + end; + (* (\* DEBUG *\) *) + (* fprintf ff "@[defines @,"; *) + (* Env.iter (fun n t -> fprintf ff "%s," n) defnames; *) + (* fprintf ff "@]@\n"; *) + (* (\* END DEBUG *\) *) + fprintf ff "@[do@,"; + print_eq_list ff eqs; + fprintf ff "@]" + +let print_type_def ff { t_name = name; t_desc = tdesc } = + match tdesc with + | Type_abs -> fprintf ff "@[type %s@\n@]" name + | Type_enum(tag_name_list) -> + fprintf ff "@[type %s = " name; + print_list ff print_name "| " tag_name_list; + fprintf ff "@\n@]" + | Type_struct(f_ty_list) -> + fprintf ff "@[type %s = " name; + fprintf ff "@[{"; + print_list ff + (fun ff (field, ty) -> + print_name ff field; + fprintf ff ": "; + print_base_type ff ty) ";" f_ty_list; + fprintf ff "}@]@.@]" + +let print_const_dec ff c = + fprintf ff "@[const "; + print_name ff c.c_name; + fprintf ff " : "; + print_base_type ff c.c_type; + fprintf ff " = "; + print_size_exp ff c.c_value; + fprintf ff "@.@]" + +let print_contract ff {c_local = l; + c_eq = eqs; + c_assume = e_a; + c_enforce = e_g; + c_controllables = cl } = + if l <> [] then begin + fprintf ff "@[contract@\n"; + fprintf ff "@[var "; + print_list ff print_vd ";" l; + fprintf ff ";@]@\n" + end; + if eqs <> [] then begin + fprintf ff "@[let @,"; + print_eq_list ff eqs; + fprintf ff "@]"; fprintf ff "tel@\n" + end; + fprintf ff "assume %a@;enforce %a@;with (@[" + print_exp e_a + print_exp e_g; + print_list ff print_vd ";" cl; + fprintf ff "@])@]@\n" + +let print_node_params ff = function + | [] -> () + | l -> + fprintf ff "<<"; + print_list ff print_name "," l; + fprintf ff ">>" + +let print_node ff + { n_name = n; n_statefull = statefull; n_input = ni; + n_local = nl; n_output = no; n_contract = contract; n_equs = ne; + n_params = params; } = + fprintf ff "@[%s " (if statefull then "node" else "fun"); + print_name ff n; + print_node_params ff params; + fprintf ff "(@["; + print_list ff print_vd ";" ni; + fprintf ff "@]) returns (@["; + print_list ff print_vd ";" no; + fprintf ff "@])@,"; + optunit (print_contract ff) contract; + if nl <> [] then begin + fprintf ff "@[var "; + print_list ff print_vd ";" nl; + fprintf ff ";@]@," + end; + fprintf ff "@[let @,"; + print_eq_list ff ne; + fprintf ff "@]@;"; fprintf ff "tel";fprintf ff "@.@]" + +let print_open_module ff name = + fprintf ff "@[open "; + print_name ff name; + fprintf ff "@.@]" + +let ptype oc ty = + let ff = formatter_of_out_channel oc in + print_type ff ty; fprintf ff "@?" + +let print oc { p_opened = po; p_types = pt; p_nodes = pn; p_consts = pc } = + let ff = formatter_of_out_channel oc in + List.iter (print_open_module ff) po; + List.iter (print_const_dec ff) pc; + List.iter (print_type_def ff) pt; + List.iter (print_node ff) pn; + fprintf ff "@?" diff --git a/heptagon/transformations/automata.ml b/heptagon/transformations/automata.ml new file mode 100644 index 0000000..6ae138f --- /dev/null +++ b/heptagon/transformations/automata.ml @@ -0,0 +1,204 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* removing automata statements *) + +(* $Id$ *) + +open Location +open Misc +open Names +open Ident +open Heptagon +open Global +open Initial +open Interference_graph + +let rename_states env g = + let rename_one n = + try + let olds = List.hd n.g_content in + let s = NamesEnv.find olds env in + Hashtbl.remove g.g_hash olds; + Hashtbl.add g.g_hash s n; + n.g_content <- [s] + with Not_found -> () + in + List.iter rename_one g.g_nodes + +(* the list of enumerated types introduced to represent states *) +let state_type_dec_list = ref [] + +let intro_type states = + let list env = NamesEnv.fold (fun _ state l -> state :: l) env [] in + let n = gen_symbol () in + let state_type = "st" ^ n in + state_type_dec_list := + (tmake state_type (Type_enum(list states))) :: !state_type_dec_list; + Name(state_type) + +(* an automaton may be a Moore automaton, i.e., with only weak transitions; *) +(* a Mealy one, i.e., with only strong transition or mixed *) +let moore_mealy state_handlers = + let handler (moore, mealy) { s_until = l1; s_unless = l2 } = + (moore or (l1 <> []), mealy or (l2 <> [])) in + List.fold_left handler (false, false) state_handlers + +let rec translate_eq g (v, eq_list) eq = + match eq.eq_desc with + Eautomaton(state_handlers) -> + translate_automaton g v eq_list state_handlers + | Eswitch(e, switch_handlers) -> + v, + { eq with eq_desc = + Eswitch(e, translate_switch_handlers g switch_handlers) } + :: eq_list + | Epresent(present_handlers, block) -> + v, { eq with eq_desc = + Epresent(translate_present_handlers g present_handlers, + translate_block g block) } :: eq_list + | Ereset(r_eq_list, e) -> + let v, r_eq_list = translate_eqs g v r_eq_list in + v, { eq with eq_desc = Ereset(r_eq_list, e) } :: eq_list + | Eeq _ -> v, eq :: eq_list + +and translate_eqs g v eq_list = List.fold_left (translate_eq g) (v, []) eq_list + +and translate_block g ({ b_local = v; b_equs = eq_list } as b) = + let v, eq_list = translate_eqs g v eq_list in + { b with b_local = v; b_equs = eq_list } + +and translate_switch_handlers g handlers = + let translate_switch_handler { w_name = n; w_block = b } = + { w_name = n; w_block = translate_block g b } in + List.map translate_switch_handler handlers + +and translate_present_handlers g handlers = + let translate_present_handler { p_cond = e; p_block = b } = + { p_cond = e; p_block = translate_block g b } in + List.map translate_present_handler handlers + +and translate_automaton g v eq_list handlers = + let has_until, has_unless = moore_mealy handlers in + let states = + let suffix = gen_symbol () in + List.fold_left + (fun env { s_state = n } -> NamesEnv.add n (n ^ suffix) env) + NamesEnv.empty handlers in + + let statetype = intro_type states in + let tstatetype = Tbase(Tid(statetype)) in + let initial = Name(NamesEnv.find (List.hd handlers).s_state states) in + + let statename = Ident.fresh "s" in + let next_statename = Ident.fresh "ns" in + let resetname = Ident.fresh "r" in + let next_resetname = Ident.fresh "nr" in + let pre_next_resetname = Ident.fresh "pnr" in + + (* update the states graph with the suffixed names *) + rename_states states g; + + let name n = Name(NamesEnv.find n states) in + let state n = + emake (Econst(Cconstr(name n))) tstatetype in + let statevar n = var n tstatetype in + let boolvar n = var n tybool in + + let escapes n s rcont = + let escape { e_cond = e; e_reset = r; e_next_state = n } cont = + ifthenelse e (pair (state n) (if r then dtrue else dfalse)) cont in + List.fold_right escape s (pair (state n) rcont) in + let strong { s_state = n; s_unless = su } = + block + (Env.add statename tstatetype + (Env.add resetname tybool Env.empty)) + ([reset( + [eq (Etuplepat[Evarpat(statename);Evarpat(resetname)]) + (escapes n su (boolvar pre_next_resetname))]) + (boolvar pre_next_resetname)]) in + + let weak { s_state = n; s_block = b; s_until = su } = + let b = translate_block g b in + { b with b_equs = + [reset ((eq (Etuplepat[Evarpat(next_statename); + Evarpat(next_resetname)]) + (escapes n su dfalse)) :: b.b_equs) + (boolvar resetname)]; + (* (or_op (boolvar pre_next_resetname) (boolvar resetname))]; *) + b_defnames = + Env.add next_statename tstatetype + (Env.add next_resetname tybool + b.b_defnames) + } in + let v = + (param next_statename (Tid(statetype))) :: + (param resetname tbool) :: + (param next_resetname tbool) :: + (param pre_next_resetname tbool) :: v in + (* we optimise the case of an only strong automaton *) + (* or only weak automaton *) + match has_until, has_unless with + | true, false -> + (* a Moore automaton with only weak transitions *) + v, (switch (fby_state initial (statevar next_statename)) + (List.map + (fun ({ s_state = n } as case) -> + { w_name = name n; w_block = weak case }) + handlers)) :: + (eq (Evarpat pre_next_resetname) + (fby_false (boolvar (next_resetname)))) :: + (eq (Evarpat resetname) (boolvar pre_next_resetname)) :: eq_list + | _ -> + (* the general case; two switch to generate, + statename variable used and defined *) + (param statename (Tid(statetype))) :: v, + (switch (fby_state initial (statevar next_statename)) + (List.map + (fun ({ s_state = n } as case) -> + { w_name = name n; w_block = strong case }) + handlers)) :: + (switch (statevar statename) + (List.map + (fun ({ s_state = n } as case) -> + { w_name = name n; w_block = weak case }) + handlers)) :: + (eq (Evarpat pre_next_resetname) + (fby_false (boolvar (next_resetname)))) :: + eq_list + +let translate_contract g ({ c_local = v; c_eq = eq_list} as c) = + let v, eq_list = translate_eqs g v eq_list in + { c with c_local = v; c_eq = eq_list } + +let node ({ n_local = v; n_equs = eq_list; n_contract = contract; n_states_graph = g } as n) = + let v, eq_list = translate_eqs g v eq_list in + let contract = optional (translate_contract g) contract in + { n with n_local = v; n_equs = eq_list; n_contract = contract } + +let program ({ p_types = pt_list; p_nodes = n_list } as p) = + let n_list = List.map node n_list in + { p with p_types = !state_type_dec_list @ pt_list; + p_nodes = n_list } + +(* + A -> do ... unless c1 then A1 ... until c'1 then A'1 ... + + match A fby next_state with + A -> resA = pre_next_res or (if c1 then ... else .. + + match state with + A -> reset + next_res = if c'1 then true else ... else false + every resA + + if faut donc: - une memoire pour pre(next_res) + n memoires (pre(resA),...) + + merge state + (A -> reset ... when A(state) every pre_next_res or res) +*) diff --git a/heptagon/transformations/completion.ml b/heptagon/transformations/completion.ml new file mode 100644 index 0000000..cfdeffa --- /dev/null +++ b/heptagon/transformations/completion.ml @@ -0,0 +1,86 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* complete partial definitions with [x = last(x)] *) + +(* $Id$ *) + +open Location +open Ident +open Misc +open Heptagon +open Global + +(* adds an equation [x = last(x)] for every partially defined variable *) +(* in a control structure *) +let complete_with_last defined_names local_defined_names eq_list = + let last n ty = + { e_desc = Elast(n); e_ty = ty; e_linearity = Linearity.NotLinear; + e_loc = no_location } in + let equation n ty eq_list = + { eq_desc = Eeq(Evarpat(n), last n ty); eq_statefull = false; + eq_loc = no_location } :: eq_list in + let d = Env.diff defined_names local_defined_names in + Env.fold equation d eq_list + +let rec translate_eq eq = + match eq.eq_desc with + | Ereset(eq_list, e) -> + { eq with eq_desc = Ereset(translate_eqs eq_list, e) } + | Eeq(pat, e) -> + { eq with eq_desc = Eeq(pat, e) } + | Eswitch(e, switch_handlers) -> + let defnames = + List.fold_left + (fun acc { w_block = { b_defnames = d } } -> Env.union acc d) + Env.empty switch_handlers in + let switch_handlers = + List.map (fun ({ w_block = b } as handler) -> + { handler with w_block = translate_block defnames b }) + switch_handlers in + { eq with eq_desc = Eswitch(e, switch_handlers) } + | Epresent(present_handlers, b) -> + let defnames = + List.fold_left + (fun acc { p_block = { b_defnames = d } } -> Env.union acc d) + b.b_defnames present_handlers in + let present_handlers = + List.map (fun ({ p_block = b } as handler) -> + { handler with p_block = translate_block defnames b }) + present_handlers in + let b = translate_block defnames b in + {eq with eq_desc = Epresent(present_handlers, b)} + | Eautomaton(state_handlers) -> + let defnames = + List.fold_left + (fun acc { s_block = { b_defnames = d } } -> Env.union acc d) + Env.empty state_handlers in + let state_handlers = + List.map (fun ({ s_block = b } as handler) -> + { handler with s_block = translate_block defnames b }) + state_handlers in + { eq with eq_desc = Eautomaton(state_handlers) } + +and translate_eqs eq_list = List.map translate_eq eq_list + +and translate_block defnames + ({ b_defnames = bdefnames; b_equs = eq_list } as b) = + let eq_list = translate_eqs eq_list in + let eq_list = complete_with_last defnames bdefnames eq_list in + { b with b_equs = eq_list; b_defnames = defnames } + +let translate_contract ({ c_eq = eqs } as c) = + { c with c_eq = translate_eqs eqs } + +let node ({ n_equs = eq_list; n_contract = contract } as n) = + { n with + n_equs = translate_eqs eq_list; + n_contract = optional translate_contract contract } + +let program ({ p_types = pt_list; p_nodes = n_list } as p) = + { p with p_types = pt_list; p_nodes = List.map node n_list } diff --git a/heptagon/transformations/every.ml b/heptagon/transformations/every.ml new file mode 100644 index 0000000..c7008e8 --- /dev/null +++ b/heptagon/transformations/every.ml @@ -0,0 +1,175 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* removing complex reset expressions : + equations + x = (f every e) e' + --> + r = e; + x = (f every r) e' +*) + +(* $Id$ *) + +open Location +open Misc +open Ident +open Heptagon +open Global +open Initial +open Reset + +let eq pat e = + { eq_desc = Eeq(pat, e); eq_statefull = false; eq_loc = no_location } +let statefulleq = Heptagon.eq + +(* add an equation *) +let equation v acc_eq_list e = + let n = Ident.fresh "r" in + n, + (bool_param n) :: v, + { eq_desc = Eeq(Evarpat(n), e); eq_statefull = true; eq_loc = e.e_loc } :: + acc_eq_list + +let orthen v acc_eq_list res e = + match e.e_desc with + Evar(n) -> v, acc_eq_list, Rorthen(res, n) + | _ -> + let n, v, acc_eq_list = equation v acc_eq_list e in + v, acc_eq_list, Rorthen(res, n) + +let add_locals m n locals = + let rec loop locals i n = + if i < n then + loop ((bool_param m.(i)) :: locals) (i+1) n + else locals in + loop locals 0 n + +(* +let defnames m n d = + let rec loop acc k = if k < n then loop (S.add m.(k) acc) (k+1) else acc in + loop d 0 +*) + +let statefull eq_list = List.exists (fun eq -> eq.eq_statefull) eq_list + +let is_var = function + | { e_desc = Evar(_) } -> true + | _ -> false + +let rec translate_eq v acc_eq_list eq = + match eq.eq_desc with + | Eeq(pat, e) -> + let v,acc_eq_list,e = translate v acc_eq_list e in + v, { eq with eq_desc = Eeq(pat, e) } :: acc_eq_list + | Eswitch(e, tag_block_list) -> + let v,acc_eq_list,e = translate v acc_eq_list e in + let tag_block_list, acc_eq_list = + translate_switch acc_eq_list tag_block_list in + v, { eq with eq_desc = Eswitch(e, tag_block_list) } :: acc_eq_list + | Ereset _ | Epresent _ | Eautomaton _ -> assert false + +and translate_eqs v acc_eq_list eq_list = + List.fold_left + (fun (v,acc_eq_list) eq -> + translate_eq v acc_eq_list eq) (v,acc_eq_list) eq_list + +and translate_switch acc_eq_list switch_handlers = + + let body {w_name = c; + w_block = ({ b_local = lv; b_defnames = d; b_equs = eqs } as b)} = + let lv,eqs = translate_eqs lv [] eqs in + { w_name = c; + w_block = { b with b_local = lv; b_defnames = d; b_equs = eqs } } in + + let rec loop switch_handlers = + match switch_handlers with + [] -> [] + | handler :: switch_handlers -> + (body handler) :: (loop switch_handlers) in + + loop switch_handlers, acc_eq_list + +and translate v acc_eq_list e = + match e.e_desc with + Econst _ | Evar _ | Econstvar _ | Elast _ -> v,acc_eq_list,e + | Etuple(e_list) -> + let v, acc_eq_list,e_list = translate_list v acc_eq_list e_list in + v,acc_eq_list, + { e with e_desc = Etuple(e_list) } + | Eapp({ a_op = Eevery(f,params) } as op, re :: e_list) + when not (is_var re) -> + let v, acc_eq_list,re = translate v acc_eq_list re in + let n, v, acc_eq_list = equation v acc_eq_list re in + let v, acc_eq_list, e_list = translate_list v acc_eq_list e_list in + v,acc_eq_list, + { e with e_desc = + Eapp({ op with a_op = Eevery(f,params) }, + { re with e_desc = Evar(n) } :: e_list) } + | Eapp({ a_op = Eiterator(it, f, params, Some re) } as op, e_list) + when not (is_var re) -> + let v, acc_eq_list,re = translate v acc_eq_list re in + let n, v, acc_eq_list = equation v acc_eq_list re in + let v, acc_eq_list, e_list = translate_list v acc_eq_list e_list in + let re = { re with e_desc = Evar n } in + v,acc_eq_list, + { e with e_desc = + Eapp({ op with a_op = Eiterator(it, f, params, Some re) },e_list) } + | Eapp(f, e_list) -> + let v, acc_eq_list, e_list = translate_list v acc_eq_list e_list in + v, acc_eq_list, + { e with e_desc = Eapp(f, e_list) } + | Efield(e', field) -> + let v, acc_eq_list, e' = translate v acc_eq_list e' in + v,acc_eq_list, + { e with e_desc = Efield(e', field) } + | Estruct(e_f_list) -> + let v,acc_eq_list,e_f_list = + List.fold_left + (fun (v,acc_eq_list,acc_e_f) (f,e) -> + let v,acc_eq_list,e = translate v acc_eq_list e in + (v,acc_eq_list,(f,e)::acc_e_f)) + (v,acc_eq_list,[]) e_f_list in + v,acc_eq_list, + { e with e_desc = Estruct(List.rev e_f_list) } + | Earray(e_list) -> + let v, acc_eq_list,e_list = translate_list v acc_eq_list e_list in + v,acc_eq_list, + { e with e_desc = Earray(e_list) } + | Ereset_mem _ -> v,acc_eq_list,e + +and translate_list v acc_eq_list e_list = + let v,acc_eq_list,acc_e = + List.fold_left + (fun (v,acc_eq_list,acc_e) e -> + let v,acc_eq_list,e = translate v acc_eq_list e in + (v,acc_eq_list,e::acc_e)) + (v,acc_eq_list,[]) e_list in + v,acc_eq_list,List.rev acc_e + +let translate_contract ({ c_local = v; + c_eq = eq_list; + c_assume = e_a; + c_enforce = e_g } as c) = + let v,acc_eq,e_a = translate v [] e_a in + let v,acc_eq,e_g = translate v acc_eq e_g in + let v, eq_list = translate_eqs v acc_eq eq_list in + { c with + c_local = v; + c_eq = eq_list; + c_assume = e_a; + c_enforce = e_g } + +let node ({ n_local = v; n_equs = eq_list; n_contract = contract } as n) = + let contract = optional translate_contract contract in + let v, eq_list = translate_eqs v [] eq_list in + { n with n_local = v; n_equs = eq_list; n_contract = contract } + +let program ({ p_types = pt_list; p_nodes = n_list } as p) = + { p with p_types = pt_list; p_nodes = List.map node n_list } diff --git a/heptagon/transformations/last.ml b/heptagon/transformations/last.ml new file mode 100644 index 0000000..903e33f --- /dev/null +++ b/heptagon/transformations/last.ml @@ -0,0 +1,111 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* removing accessed to shared variables (last x) *) + +(* $Id$ *) + +open Location +open Misc +open Ident +open Heptagon +open Global + +(* introduce a fresh equation [last_x = pre(x)] for every *) +(* variable declared with a last *) +let last (eq_list, env, v) { v_name = n; v_type = t; v_last = last } = + match last with + | Var -> (eq_list, env, v) + | Last(default) -> + let lastn = Ident.fresh ("last" ^ (sourcename n)) in + (eqmake (Eeq(Evarpat(lastn), + emake + (Eapp (eop (Epre(default)), + [emake (Evar(n)) (Tbase(t))])) + (Tbase(t))))) + :: eq_list, + Env.add n lastn env, + (param lastn t) :: v + +let extend_env env v = List.fold_left last ([], env, []) v + +let rec translate_eq env eq = + match eq.eq_desc with + | Ereset(eq_list, e) -> + { eq with eq_desc = Ereset(translate_eqs env eq_list, translate env e) } + | Eeq(pat, e) -> + { eq with eq_desc = Eeq(pat, translate env e) } + | Eswitch(e, handler_list) -> + let handler_list = + List.map (fun ({ w_block = b } as handler) -> + { handler with w_block = translate_block env b }) + handler_list in + { eq with eq_desc = Eswitch(translate env e, handler_list) } + | Epresent _ | Eautomaton _ -> assert false + +and translate_eqs env eq_list = List.map (translate_eq env) eq_list + +and translate_block env ({ b_local = v; b_equs = eq_list } as b) = + let eq_lastn_n_list, env, last_v = extend_env env v in + let eq_list = translate_eqs env eq_list in + { b with b_local = v @ last_v; b_equs = eq_lastn_n_list @ eq_list } + +and translate env e = + match e.e_desc with + Econst _ | Evar _ | Econstvar _ -> e + | Elast(x) -> + let lx = Env.find x env in { e with e_desc = Evar(lx) } + | Etuple(e_list) -> + { e with e_desc = Etuple(List.map (translate env) e_list) } + | Eapp(op, e_list) -> + { e with e_desc = Eapp(op, List.map (translate env) e_list) } + | Efield(e', field) -> + { e with e_desc = Efield(translate env e', field) } + | Estruct(e_f_list) -> + { e with e_desc = + Estruct(List.map (fun (f, e) -> (f, translate env e)) e_f_list) } + | Earray(e_list) -> + { e with e_desc = Earray(List.map (translate env) e_list) } + | Ereset_mem _ -> assert false + +let translate_contract env contract = + match contract with + | None -> None, env + | Some { c_local = v; + c_eq = eq_list; + c_assume = e_a; + c_enforce = e_g; + c_controllables = cl } -> + let _, env, _ = extend_env env cl in + let eq_lastn_n_list, env', last_v = extend_env env v in + let eq_list = translate_eqs env' eq_list in + let e_a = translate env' e_a in + let e_g = translate env' e_g in + Some { c_local = v @ last_v; + c_eq = eq_lastn_n_list @ eq_list; + c_assume = e_a; + c_enforce = e_g; + c_controllables = List.rev cl }, + env + +let node ({ n_input = i; n_local = v; n_output = o; + n_equs = eq_list; n_contract = contract } as n) = + let _, env, _ = extend_env Env.empty i in + let eq_lasto_list, env, last_o = extend_env env o in + let contract, env = translate_contract env contract in + let eq_lastn_n_list, env, last_v = extend_env env v in + let eq_list = translate_eqs env eq_list in + { n with + n_input = i; + n_output = o; + n_local = v @ last_o @ last_v; + n_contract = contract; + n_equs = eq_lasto_list @ eq_lastn_n_list @ eq_list } + +let program ({ p_types = pt_list; p_nodes = n_list } as p) = + { p with p_types = pt_list; p_nodes = List.map node n_list } diff --git a/heptagon/transformations/present.ml b/heptagon/transformations/present.ml new file mode 100644 index 0000000..0a86fa6 --- /dev/null +++ b/heptagon/transformations/present.ml @@ -0,0 +1,73 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* removing present statements *) + +(* $Id$ *) + +open Misc +open Location +open Heptagon +open Global +open Initial + +let block defnames statefull eqs = + { b_local = []; b_equs = eqs; b_defnames = defnames; + b_statefull = statefull; b_loc = no_location } +let switch statefull e l = + { eq_desc = Eswitch(e, l); eq_statefull = statefull; eq_loc = no_location } + +let rec translate_eq v eq = + match eq.eq_desc with + | Eswitch(e, switch_handlers) -> + v, { eq with eq_desc = + Eswitch(e, translate_switch_handlers switch_handlers) } + | Epresent(present_handlers, block) -> + v, + translate_present_handlers present_handlers (translate_block block) + | Ereset(eq_list, e) -> + let v, eq_list = translate_eqs v eq_list in + v, { eq with eq_desc = Ereset(eq_list, e) } + | Eeq _ -> v, eq + | Eautomaton _ -> assert false + +and translate_eqs v eq_list = + List.fold_left + (fun (v, eq_list) eq -> + let v, eq = translate_eq v eq in v, eq :: eq_list) + (v, []) eq_list + +and translate_block ({ b_local = v; b_equs = eq_list } as b) = + let v, eq_list = translate_eqs v eq_list in + { b with b_local = v; b_equs = eq_list } + +and translate_switch_handlers handlers = + let translate_switch_handler { w_name = n; w_block = b } = + { w_name = n; w_block = translate_block b } in + List.map translate_switch_handler handlers + +and translate_present_handlers handlers cont = + let translate_present_handler { p_cond = e; p_block = b } cont = + let statefull = b.b_statefull or cont.b_statefull in + block b.b_defnames statefull + [switch statefull e [{ w_name = ptrue; w_block = b }; + { w_name = pfalse; w_block = cont }]] in + let b = List.fold_right translate_present_handler handlers cont in + List.hd (b.b_equs) + +let translate_contract ({ c_local = v; c_eq = eq_list} as c) = + let v, eq_list = translate_eqs v eq_list in + { c with c_local = v; c_eq = eq_list } + +let node ({ n_local = v; n_equs = eq_list; n_contract = contract } as n) = + let v, eq_list = translate_eqs v eq_list in + let contract = optional translate_contract contract in + { n with n_local = v; n_equs = eq_list; n_contract = contract } + +let program ({ p_types = pt_list; p_nodes = n_list } as p) = + { p with p_types = pt_list; p_nodes = List.map node n_list } diff --git a/heptagon/transformations/reset.ml b/heptagon/transformations/reset.ml new file mode 100644 index 0000000..2b95d64 --- /dev/null +++ b/heptagon/transformations/reset.ml @@ -0,0 +1,266 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* removing reset statements *) + +(* $Id$ *) + +open Location +open Misc +open Ident +open Heptagon +open Global +open Initial + +(* We introduce an initialization variable for each block *) +(* Using an asynchronous reset would allow to produce *) +(* better code avoiding to introduce n local variables and *) +(* n state variables *) +(* reset + switch e with + case C1 do ... + | case C2 do ... + | case C3 do ... + end + every r + + switch e with + case C1 do ... (* l_m1 *) + m1 = false; m2 = l_m2; m3 = l_m3 + | case C2 do ... (* l_m2 *) + m1 = l_m1; m2 = false; m3 = l_m3 + | case C3 do ... (* l_m3 *) + m1 = l_m1; m2 = l_m2; m3 = false + end; + l_m1 = if res then true else true fby m1;...; + l_m3 = if res then true else true fby m3 + + e1 -> e2 is translated into if (true fby false) then e1 else e2 +*) + +let pre_true e = + { e with e_desc = Eapp(eop (Epre(Some(Cconstr(ptrue)))), [e]) } +let init e = pre_true { dfalse with e_loc = e.e_loc } +let ifthenelse e1 e2 e3 = + { e3 with e_desc = Eapp(eop Eifthenelse, [e1; e2; e3]) } +let eq pat e = + { eq_desc = Eeq(pat, e); eq_statefull = false; eq_loc = no_location } +let statefulleq = Heptagon.eq + +(* the boolean condition for a structural reset *) +type reset = + | Rfalse + | Rorthen of reset * ident + +let rfalse = Rfalse +let rvar n = Rorthen(Rfalse, n) + +let true_reset = function + | Rfalse -> false + | _ -> true + +let rec or_op res e = + match res with + | Rfalse -> e + | Rorthen(res, n) -> + or_op res { e with e_desc = Eapp(eop (Eop(por,[])), [bool_var n; e]) } + +let default e = + match e.e_desc with + | Econst c -> Some(c) + | _ -> None + +let exp_of_res res = + match res with + | Rfalse -> dfalse + | Rorthen(res, n) -> or_op res (bool_var n) + +let ifres res e2 e3 = + match res with + | Rfalse -> ifthenelse (init e3) e2 e3 + | _ -> (* a reset occurs *) + ifthenelse (exp_of_res res) e2 e3 + +(* add an equation *) +let equation v acc_eq_list e = + let n = Ident.fresh "r" in + n, + (bool_param n) :: v, + { eq_desc = Eeq(Evarpat(n), e); eq_statefull = true; eq_loc = e.e_loc } :: + acc_eq_list + +let orthen v acc_eq_list res e = + match e.e_desc with + | Evar(n) -> v, acc_eq_list, Rorthen(res, n) + | _ -> + let n, v, acc_eq_list = equation v acc_eq_list e in + v, acc_eq_list, Rorthen(res, n) + +let add_locals m n locals = + let rec loop locals i n = + if i < n then + loop ((bool_param m.(i)) :: locals) (i+1) n + else locals in + loop locals 0 n + +let add_local_equations i n m lm acc = + (* [mi = false;...; m1 = l_m1;...; mn = l_mn] *) + let rec loop acc k = + if k < n then + if k = i then loop ((eq (varpat(m.(k))) dfalse) :: acc) (k+1) + else + loop + ((eq (varpat(m.(k))) (bool_var lm.(k))) :: acc) (k+1) + else acc + in loop acc 0 + +let add_global_equations n m lm res acc = + (* [ l_m1 = if res then true else true fby m1;...; + l_mn = if res then true else true fby mn ] *) + let rec loop acc k = + if k < n then + loop + ((statefulleq (varpat(lm.(k))) + (match res with + | Rfalse -> pre_true (bool_var m.(k)) + | _ -> ifres res dtrue (pre_true (bool_var m.(k))) + ) + ) :: acc) (k+1) + else acc in + loop acc 0 + +let defnames m n d = + let rec loop acc k = + if k < n + then loop (Env.add m.(k) tybool acc) (k+1) + else acc in + loop d 0 + +let statefull eq_list = List.exists (fun eq -> eq.eq_statefull) eq_list + +let rec translate_eq res v acc_eq_list eq = + match eq.eq_desc with + | Ereset(eq_list, e) -> + let e = translate res e in + if statefull eq_list then + let v, acc_eq_list, res = orthen v acc_eq_list res e in + translate_eqs res v acc_eq_list eq_list + else + let _, v, acc_eq_list = equation v acc_eq_list e in + translate_eqs res v acc_eq_list eq_list + | Eeq(pat, e) -> + v, { eq with eq_desc = Eeq(pat, translate res e) } :: acc_eq_list + | Eswitch(e, tag_block_list) -> + let e = translate res e in + let v, tag_block_list, acc_eq_list = + translate_switch res v acc_eq_list tag_block_list in + v, { eq with eq_desc = Eswitch(e, tag_block_list) } :: acc_eq_list + | Epresent _ | Eautomaton _ -> assert false + +and translate_eqs res v acc_eq_list eq_list = + List.fold_left + (fun (v, acc_eq_list) eq -> + translate_eq res v acc_eq_list eq) (v, acc_eq_list) eq_list + +and translate_switch res locals acc_eq_list switch_handlers = + (* introduce a reset bit for each branch *) + let tab_of_vars n = Array.init n (fun _ -> Ident.fresh "r") in + let n = List.length switch_handlers in + let m = tab_of_vars n in + let lm = tab_of_vars n in + + let locals = add_locals m n locals in + let locals = add_locals lm n locals in + + let body i {w_name = ci; + w_block = ({ b_local = li; b_defnames = d; b_equs = eqi } as b)} = + let d = defnames m n d in + let li, eqi = translate_eqs (rvar (lm.(i))) li [] eqi in + let eqi = add_local_equations i n m lm eqi in + { w_name = ci; + w_block = { b with b_local = li; b_defnames = d; b_equs = eqi } } in + + let rec loop i switch_handlers = + match switch_handlers with + [] -> [] + | handler :: switch_handlers -> + (body i handler) :: (loop (i+1) switch_handlers) in + + let acc_eq_list = add_global_equations n m lm res acc_eq_list in + + locals, loop 0 switch_handlers, acc_eq_list + +and translate res e = + match e.e_desc with + | Econst _ | Evar _ | Econstvar _ | Elast _ -> e + | Etuple(e_list) -> + { e with e_desc = Etuple(List.map (translate res) e_list) } + | Eapp({a_op = Efby } as op, [e1;e2]) -> + let e1 = translate res e1 in + let e2 = translate res e2 in + begin + match res, e1 with + | Rfalse, { e_desc = Econst(c) } -> + (* no reset *) + { e with e_desc = + Eapp({ op with a_op = Epre(Some(c)) }, [e2]) } + | _ -> + ifres res e1 + { e with e_desc = + Eapp({ op with a_op = Epre(default e1) }, [e2]) } + end + | Eapp({ a_op = Earrow }, [e1;e2]) -> + let e1 = translate res e1 in + let e2 = translate res e2 in + ifres res e1 e2 + | Eapp({ a_op = Enode(f,params) } as op, e_list) -> + let e_list = List.map (translate res) e_list in + if true_reset res then + { e with e_desc = Eapp({ op with a_op = Eevery(f, params) }, + (exp_of_res res) :: e_list) } + else + { e with e_desc = Eapp({ op with a_op = Enode(f,params) }, e_list ) } + | Eapp( { a_op = Eiterator(it,f, params, _) } as op, e_list) -> + let e_list = List.map (translate res) e_list in + if true_reset res then + let r = Some (exp_of_res res) in + { e with e_desc = Eapp({ op with a_op = Eiterator(it,f,params,r) }, + e_list) } + else + { e with e_desc = Eapp(op, e_list) } + | Eapp({ a_op = Eevery(f, params) } as op, re :: e_list) -> + let re = translate res re in + let e_list = List.map (translate res) e_list in + { e with e_desc = Eapp({ op with a_op = Eevery(f, params)}, + (or_op res re) :: e_list) } + | Eapp(op, e_list) -> + { e with e_desc = Eapp(op, List.map (translate res) e_list) } + | Efield(e', field) -> + { e with e_desc = Efield(translate res e', field) } + | Estruct(e_f_list) -> + { e with e_desc = + Estruct(List.map (fun (f, e) -> (f, translate res e)) e_f_list) } + | Earray(e_list) -> + { e with e_desc = Earray(List.map (translate res) e_list) } + +let translate_contract ({ c_local = v; + c_eq = eq_list; + c_assume = e_a; + c_enforce = e_g } as c) = + let v, eq_list = translate_eqs rfalse v [] eq_list in + let e_a = translate rfalse e_a in + let e_g = translate rfalse e_g in + { c with c_local = v; c_eq = eq_list; c_assume = e_a; c_enforce = e_g } + +let node (n) = + let c = optional translate_contract n.n_contract in + let var, eqs = translate_eqs rfalse n.n_local [] n.n_equs in + { n with n_local = var; n_equs = eqs; n_contract = c } + +let program (p) = + { p with p_nodes = List.map node p.p_nodes } diff --git a/main/compiler.ml b/main/compiler.ml new file mode 100644 index 0000000..045faa5 --- /dev/null +++ b/main/compiler.ml @@ -0,0 +1,345 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* $Id$ *) + +open Location +open Misc +open Global + +let lexical_error err loc = + Printf.eprintf "%aIllegal character.\n" output_location loc; + raise Error + +let syntax_error loc = + Printf.eprintf "%aSyntax error.\n" output_location loc; + raise Error + +let language_error lang = + Printf.eprintf "Unknown language: %s.\n" lang + +let parse parsing_fun lexing_fun lexbuf = + try + parsing_fun lexing_fun lexbuf + with + | Lexer.Lexical_error(err, pos1, pos2) -> + lexical_error err (Loc(pos1, pos2)) + | Parsing.Parse_error -> + let pos1 = Lexing.lexeme_start lexbuf + and pos2 = Lexing.lexeme_end lexbuf in + let l = Loc(pos1,pos2) in + syntax_error l + +let comment s = Printf.printf "** %s done **\n" s; flush stdout + +let build_path suf = + match !target_path with + | None -> suf + | Some path -> Filename.concat path suf + +let clean_dir dir = + if Sys.file_exists dir && Sys.is_directory dir + then begin + let rm_file_in_dir fn = Sys.remove (Filename.concat dir fn) in + Array.iter rm_file_in_dir (Sys.readdir dir); + end else Unix.mkdir dir 0o740; + dir + +(** Generation of a dataflow target *) +let dataflow_target filename p target_languages = + let rec one_target = function + (* | "z3z" :: others -> + let dirname = build_path (filename ^ "_z3z") in + let dir = clean_dir dirname in + let p = Dynamic_system.program p in + if !verbose then + comment "Translation into dynamic system (Z/3Z equations)"; + Sigali.Printer.print dir p; + one_target others *) + | ("vhdl_df" | "vhdl") :: others -> + let dirname = build_path (filename ^ "_vhdl") in + let dir = clean_dir dirname in + let vhdl = Mls2vhdl.translate (Filename.basename filename) p in + Vhdl.print dir vhdl; + one_target others + | unknown_lg :: others -> unknown_lg :: one_target others + | [] -> [] in + one_target target_languages + +(** Generation of a sequential target *) +let sequential_target filename o target_languages = + let rec one_target = function + | "c-old" :: others -> + let dirname = build_path (filename ^ "_c-old") in + let dir = clean_dir dirname in + C_old.print o dir; + one_target others + | "java" :: others -> + let dirname = build_path filename in + let dir = clean_dir dirname in + Java.print dir o; + one_target others + | "c" :: others -> + let dirname = build_path (filename ^ "_c") in + let dir = clean_dir dirname in + let c_ast = Cgen.translate filename o in + C.output dir c_ast; + one_target others + | "caml" :: others -> Caml.print filename o; one_target others + | unknown_lg :: others -> unknown_lg :: one_target others + | [] -> [] in + one_target target_languages + +(** Whole translation. *) +let targets filename df obc target_languages = + let target_languages = dataflow_target filename df target_languages in + let target_languages = sequential_target filename obc target_languages in + match target_languages with + | [] -> () + | target :: _ -> language_error target + +let parse_implementation lexbuf = + parse Parser.program Lexer.token lexbuf + +let parse_interface lexbuf = + parse Parser.interface Lexer.token lexbuf + +let interface modname filename = + (* input and output files *) + let source_name = filename ^ ".epi" + and obj_interf_name = filename ^ ".epci" in + + let ic = open_in source_name + and itc = open_out_bin obj_interf_name in + let close_all_files () = + close_in ic; + close_out itc in + + try + Location.initialize source_name ic; + Modules.initialize modname; + Initial.initialize (); + + (* Parsing of the file *) + let lexbuf = Lexing.from_channel ic in + let l = parse_interface lexbuf in + + (* Convert the parse tree to Heptagon AST *) + let l = Scoping.translate_interface l in + + Interface.Type.main l; + Modules.write itc; + if !print_types then Interface.Printer.print stdout; + close_all_files () + with + | x -> close_all_files (); raise x + +let do_pass f d p pp enabled = + if enabled + then + let r = f p in + if !verbose + then begin + comment d; + pp r; + end; + r + else p + +let do_silent_pass f d p enabled = + if enabled + then begin + let r = f p in + if !verbose then comment d; r + end + else p + +let compile modname filename = + (* input and output files *) + let source_name = filename ^ ".ept" + and obj_interf_name = filename ^ ".epci" + and mls_name = filename ^ ".mls" + and mls_norm_name = filename ^ "_norm.mls" + and obc_name = filename ^ ".obc" + and ml_name = filename ^ ".ml" in + + let ic = open_in source_name + and itc = open_out_bin obj_interf_name + and mlsc = open_out mls_name + and mlsnc = open_out mls_norm_name + and obc = open_out obc_name + and mlc = open_out ml_name in + + let close_all_files () = + close_in ic; + close_out itc; + close_out mlsc; + close_out obc; + close_out mlc in + + try + Location.initialize source_name ic; + Modules.initialize modname; + Initial.initialize (); + + let pp = Printer.print stdout in + + (* Parsing of the file *) + let lexbuf = Lexing.from_channel ic in + let p = parse_implementation lexbuf in + + (* Convert the parse tree to Heptagon AST *) + let p = Scoping.translate_program p in + if !verbose + then begin + comment "Parsing"; + pp p + end; + +(* Misc.reset_symbol (); *) + + (* Typing *) + let p = do_pass Typing.program "Typing" p pp true in + + (* Linear typing *) + let p = do_pass Linear_typing.program "Linear Typing" p pp (not !no_mem_alloc) in + + if !print_types then Interface.Printer.print stdout; + Modules.write itc; + + (* Causality check *) + let p = + do_silent_pass Causality.program "Causality check" p true in + + (* Initialization check *) + let p = + do_silent_pass Initialization.program "Initialization check" p !init in + + (* Mark nodes to be inlined *) +(* let to_inline = List.map Misc.mk_longname !nodes_to_inline in + let p = Inline.mark_calls_to to_inline p in + let p = match !node_to_flatten with + | None -> p + | Some nn -> Inline.flatten nn p in + if !verbose then comment "Inlining pre-pass";*) + + (* Inline marked nodes *) +(* let p = do_pass Inline.program "Inlining" p pp true in *) + + (* Automata memory sharing *) + let p = do_pass Automata_mem.program "Automata memory sharing" p pp (not !no_mem_alloc) in + + (* Completion of partial definitions *) + let p = do_pass Completion.program "Completion" p pp true in + + (* Automata *) + let p = do_pass Automata.program "Automata" p pp true in + + (* Present *) + let p = do_pass Present.program "Present" p pp true in + + (* Shared variables (last) *) + let p = do_pass Last.program "Last" p pp true in + + (* Reset *) + let reset_prog = if !use_new_reset_encoding then Reset_new.program else Reset.program in + let p = do_pass reset_prog "Reset" p pp true in + + (* Every *) + let p = do_pass Every.program "Every" p pp true in + + (* Merge and translate the heptagon program into the *) + (* clocked data-flow language mini-ls *) + let pp = Minils.Printer.print stdout in + + let p = Merge.program p in + if !verbose then comment "Translation into clocked equations"; + Minils.Printer.print mlsc p; + + (* Annotation of expressions with their clock *) + let p = Clocking.program p in + + (* Mls2dot.program "" p; *) + + (** Start of data-flow optimizations *) + (* Normalization to maximize opportunities *) + let p = do_pass Normalize.program "Normalization" p pp true in + + (* Back-end causality check. Only useful to check that *) + (* we did not make any mistake during code generation *) + let p = + do_silent_pass Dfcausality.program "Post-pass causality check" p true in + + (* Check that the dataflow code is well initialized *) + (* + let p = + do_silent_pass Init.program "Post-pass initialization check" p true in + *) + + let sigali = List.mem "z3z" !target_languages in + + (* Boolean translation of enumerated values *) + (* let p = + do_pass + Boolean.program "Boolean transformation" p pp (!boolean or sigali) in + *) + + (* Normalization to maximize opportunities *) + let p = do_pass Normalize.program "Normalization" p pp true in + + (* Mls2dot.program "normalized_" p; *) + + let p = + do_pass Deadcode.program "Deadcode removal" p pp !deadcode in + + (* Automata minimization *) + let p = do_pass Tommls.program "Automata minimization" p pp !tomato in + + (* Common sub-expression elimination *) + let p = + do_pass Cmse.program "Common sub-expression elimination" p pp !cse in + + (* Removing intermediate equations *) + let p = + do_pass Intermediate.program "Intermediate-equations removal" + p pp !intermediate in + + Mls2dot.program "optimized_" p; + + (* Splitting *) + let p = do_pass Splitting.program "Splitting" p pp (not !no_mem_alloc) in + + (* Scheduling *) + let scheduler = if !use_interf_scheduler then Schedule_interf.program else Schedule.program in + let p = do_pass scheduler "Scheduling" p pp true in + + (* Memory allocation *) + Interference.world.Interference.node_is_scheduled <- true; + let p = do_pass Memalloc.program + "Interference graph building and Memory Allocation" p pp (not !no_mem_alloc) in + + (* Parametrized functions instantiation *) + let p = do_pass Callgraph.program + "Parametrized functions instantiation" p pp true in + + Minils.Printer.print mlsnc p; + + (* Producing Object-based code *) + let o = Translate.program p in + if !verbose then comment "Translation into Object-based code"; + Obc.Printer.print obc o; + + let pp = Obc.Printer.print stdout in + if !verbose then pp o; + + (* Translation into dataflow and sequential languages *) + targets filename p o !target_languages; + + close_all_files (); + + with x -> close_all_files (); raise x diff --git a/main/hept2mls.ml b/main/hept2mls.ml new file mode 100644 index 0000000..b845498 --- /dev/null +++ b/main/hept2mls.ml @@ -0,0 +1,468 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* removing switch statements and translation into Minils *) + +(* $Id$ *) + +open Location +open Misc +open Names +open Ident +open Linearity +open Static + +module HeptPrinter = Printer + +open Minils +open Global + +module Env = + (* associate a clock level [base on C1(x1) on ... Cn(xn)] to every *) + (* local name [x] *) + (* then [x] is translated into [x when C1(x1) ... when Cn(xn)] *) +struct + type env = + | Eempty + | Ecomp of env * IdentSet.t + | Eon of env * longname * ident + + let empty = Eempty + + let push env tag c = Eon(env, tag, c) + + let add l env = + Ecomp(env, + List.fold_left + (fun acc { Heptagon.v_name = n } -> IdentSet.add n acc) IdentSet.empty l) + + (* sample e according to the clock [base on C1(x1) on ... on Cn(xn)] *) + let con env x e = + let rec conrec env = + match env with + | Eempty -> Format.printf "%s\n" (name x); assert false + | Eon(env, tag, name) -> + let e, ck = conrec env in + let ck_tag_name = Con(ck, tag, name) in + { e with e_desc = Ewhen(e, tag, name); e_ck = ck_tag_name }, + ck_tag_name + | Ecomp(env, l) -> + if IdentSet.mem x l then (e, Cbase) else conrec env in + let e, _ = conrec env in e + + (* a constant [c] is translated into [c when C1(x1) on ... on Cn(xn)] *) + let const env e = + let rec constrec env = + match env with + | Eempty -> e, Cbase + | Eon(env, tag, name) -> + let e, ck = constrec env in + let ck_tag_name = Con(ck, tag, name) in + { e with e_desc = Ewhen(e, tag, name); e_ck = ck_tag_name }, + ck_tag_name + | Ecomp(env, l) -> constrec env in + let e, _ = constrec env in e +end + +(* add an equation *) +let equation locals l_eqs e = + let n = Ident.fresh "ck" in + n, + { v_name = n; v_copy_of = None; + v_type = exp_base_type e; v_linearity = NotLinear; v_clock = Cbase } :: locals, + { p_lhs = Evarpat(n); p_rhs = e } :: l_eqs + +(* inserts the definition [x,e] into the set of shared equations *) +let rec add x e shared = + match shared with + | [] -> [x, e] + | (y, e_y) :: s -> + if x < y then (x, e) :: shared else (y, e_y) :: add x e s + +let add_locals ni l_eqs s_eqs s_handlers = + let rec addrec l_eqs s_eqs s_handlers = + match s_handlers with + | [] -> l_eqs, s_eqs + | (x, e) :: s_handlers -> + if IdentSet.mem x ni then addrec l_eqs (add x e s_eqs) s_handlers + else + addrec ({ p_lhs = Evarpat(x); p_rhs = e } :: l_eqs) + s_eqs s_handlers in + addrec l_eqs s_eqs s_handlers + +let rec translate_btype ty = + let pint = Modname({ qual = "Pervasives"; id = "int" }) in + let pfloat = Modname({ qual = "Pervasives"; id = "float" }) in + let pbool = Modname({ qual = "Pervasives"; id = "bool" }) in + match ty with + | Heptagon.Tid (Name "int") -> Tint + | Heptagon.Tid name_int when name_int = pint -> Tint + | Heptagon.Tint -> Tint + | Heptagon.Tid name_bool when name_bool = pbool -> Tid(Name("bool")) + | Heptagon.Tbool -> Tid(Name("bool")) + | Heptagon.Tid (Name "float") -> Tfloat + | Heptagon.Tid name_float when name_float = pfloat -> Tfloat + | Heptagon.Tfloat -> Tfloat + | Heptagon.Tid(id) -> Tid(id) + | Heptagon.Tarray(ty, exp) -> + Tarray (translate_btype ty, exp) + +let rec translate_type = function + | Heptagon.Tbase(ty) -> Tbase(translate_btype ty) + | Heptagon.Tprod(ty_list) -> Tprod(List.map translate_type ty_list) + +let translate_var { Heptagon.v_name = n; Heptagon.v_type = t; Heptagon.v_linearity = l } = + { v_name = n; v_copy_of = None; + v_type = translate_btype t; v_linearity = l; + v_clock = Cbase } + +let translate_locals locals l = + List.fold_left (fun locals v -> translate_var v :: locals) locals l + +(*transforms [c1, [(x1, e11);...;(xn, e1n)];...;ck, [(x1,ek1);...;(xn,ekn)]] *) +(*into [x1=merge x (c1, e11)...(ck, ek1);...;xn=merge x (c1, e1n)...(ck,ekn)]*) +let switch x ci_eqs_list = + (* Defensive coherence check *) + let check ci_eqs_list = + let rec unique = function + [] -> true + | x :: h -> not (List.mem x h) && (unique h) in + + let rec extract eqs_lists = + match eqs_lists with + | [] -> [],[] + | []::eqs_lists' -> + (* check length *) + assert (List.for_all (function [] -> true | _ -> false) eqs_lists'); + [],[] + | ((x,e)::eqs)::eqs_lists' -> + let firsts,nexts = extract eqs_lists' in + (x,e)::firsts,eqs::nexts in + + let rec check_eqs eqs_lists = + match eqs_lists with + | [] -> () + | []::eqs_lists' -> + (* check length *) + assert (List.for_all (function [] -> true | _ -> false) eqs_lists') + | _ -> + let firsts,nexts = extract eqs_lists in + (* check all firsts defining same name *) + if (List.for_all (fun (x,e) -> x = (fst (List.hd firsts))) firsts) + then () + else + begin + List.iter (fun (x,e) -> Printf.eprintf "|%s|, " (name x)) firsts; + assert false + end; + check_eqs nexts in + + let ci,eqs = List.split ci_eqs_list in + (* constructors uniqueness *) + assert (unique ci); + check_eqs eqs in + + let rec split ci_eqs_list = + match ci_eqs_list with + | [] | (_, []) :: _ -> [], [] + | (ci, (y, e) :: shared_eq_list) :: ci_eqs_list -> + let ci_e_list, ci_eqs_list = split ci_eqs_list in + (ci, e) :: ci_e_list, (ci, shared_eq_list) :: ci_eqs_list in + + let rec distribute ci_eqs_list = + match ci_eqs_list with + | [] | (_, []) :: _ -> [] + | (ci, (y, { e_ty = ty; e_loc = loc }) :: _) :: _ -> + let ci_e_list, ci_eqs_list = split ci_eqs_list in + (y, make_exp (Emerge(x, ci_e_list)) ty NotLinear Cbase loc) :: + distribute ci_eqs_list in + + check ci_eqs_list; + distribute ci_eqs_list + +let rec const = function + | Heptagon.Cint i -> Cint i + | Heptagon.Cfloat f -> Cfloat f + | Heptagon.Cconstr t -> Cconstr t + | Heptagon.Cconst_array(n, c) -> Cconst_array(n, const c) + +open Format + +(** [mpol_of_hpol b] translates Heptagon's inlining policies (plain booleans at + the moment) to MiniLS's subtler specifications. *) +let mpol_of_hpol hp = match hp with + | Heptagon.Ino -> Ino + | Heptagon.Ione -> Ione + | Heptagon.Irec -> Irec + +let application env { Heptagon.a_op = op; Heptagon.a_inlined = inlined } e_list = + match op, e_list with + | Heptagon.Epre(None), [e] -> Efby(None, e) + | Heptagon.Epre(Some(c)), [e] -> Efby(Some(const c), e) + | Heptagon.Efby, [{ e_desc = Econst(c) } ; e] -> Efby(Some(c), e) + | Heptagon.Eifthenelse, [e1;e2;e3] -> Eifthenelse(e1, e2, e3) + | Heptagon.Enode(f, params), _ -> + Eapp({ a_op = f; a_inlined = mpol_of_hpol inlined }, params, e_list) + | Heptagon.Eevery(f, params), { e_desc = Evar(n) } :: e_list -> + Eevery({ a_op = f; a_inlined = mpol_of_hpol inlined }, params, e_list, n) + | Heptagon.Eop(f, params), _ -> Eop(f, params, e_list) +(*Array operators*) + | Heptagon.Erepeat, [e; idx] -> + Erepeat (size_exp_of_exp idx, e) + | Heptagon.Eselect idx_list, [e] -> + Eselect (idx_list, e) +(*Little hack: we need the to access the type of the array being accessed to + store the bounds (which will be used at code generation time, where the types + are harder to find). *) + | Heptagon.Eselect_dyn, e::defe::idx_list -> + let bounds = bounds_list (exp_base_type e) in + Eselect_dyn (idx_list, bounds, + e, defe) + | Heptagon.Eupdate idx_list, [e1;e2] -> + Eupdate (idx_list, e1, e2) + | Heptagon.Eselect_slice, [e; idx1; idx2] -> + Eselect_slice (size_exp_of_exp idx1, size_exp_of_exp idx2, e) + | Heptagon.Econcat, [e1; e2] -> + Econcat (e1, e2) + | Heptagon.Eiterator(it, f, params, reset), idx::e_list -> + (match reset with + | None -> + Eiterator(it, f, params, size_exp_of_exp idx, e_list, None) + | Some { Heptagon.e_desc = Heptagon.Evar(n) } -> + Eiterator(it, f, params, size_exp_of_exp idx, e_list, Some n) + | _ -> assert false + ) + | Heptagon.Ecopy, [e] -> + e.e_desc + | Heptagon.Efield_update f, [e1;e2] -> + Efield_update(f, e1, e2) + | _ -> assert false + +let rec translate env + { Heptagon.e_desc = desc; Heptagon.e_ty = ty; + Heptagon.e_linearity = l; Heptagon.e_loc = loc } = + let ty = translate_type ty in + match desc with + | Heptagon.Econst(c) -> + Env.const env + { e_desc = Econst(const c); e_ty = ty; + e_linearity = l; e_loc = loc; e_ck = Cbase } + | Heptagon.Evar(x) -> + Env.con env x + { e_desc = Evar(x); e_ty = ty; + e_linearity = l; e_loc = loc; e_ck = Cbase } + | Heptagon.Econstvar(x) -> + Env.const env + { e_desc = Econstvar(x); e_ty = ty; + e_linearity = l; e_loc = loc; e_ck = Cbase } + | Heptagon.Etuple(e_list) -> + { e_desc = Etuple (List.map (translate env) e_list); + e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase } + | Heptagon.Eapp ({ Heptagon.a_op = Heptagon.Eflatten n}, [e]) -> + let { qualid = q; + info = { fields = fields } } = Modules.find_struct n in + let e = translate env e in + { e_desc = Etuple (List.map (fun (n,_) -> { e with e_desc = Efield(e, Name n) }) fields); + e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase } + | Heptagon.Eapp ({ Heptagon.a_op = Heptagon.Emake n}, e_list) -> + let { qualid = q; + info = { fields = fields } } = Modules.find_struct n in + let e_list = List.map (translate env) e_list in + { e_desc = Estruct (List.map2 (fun (n,_) e -> Name n,e) fields e_list); + e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase } + | Heptagon.Eapp(app, e_list) -> + { e_desc = application env app (List.map (translate env) e_list); + e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase } + | Heptagon.Efield(e, field) -> + { e_desc = Efield(translate env e, field); + e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase } + | Heptagon.Estruct(f_e_list) -> + { e_desc = Estruct(List.map + (fun (f, e) -> (f, translate env e)) + f_e_list); + e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase } + | Heptagon.Earray(e_list) -> + { e_desc = Earray (List.map (translate env) e_list); + e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase } + | Heptagon.Elast _ -> assert false + | Heptagon.Ereset_mem (y, v, res) -> + (match v.Heptagon.e_desc with + | Heptagon.Econst c -> + { e_desc = Ereset_mem(y, const c, res); + e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase } + | _ -> assert false + ) + +let rec translate_pat = function + | Heptagon.Evarpat(n) -> Evarpat n + | Heptagon.Etuplepat(l) -> Etuplepat (List.map translate_pat l) + +let rec rename_pat ni locals s_eqs = function + | Heptagon.Evarpat(n), Heptagon.Tbase(base_ty) -> + if IdentSet.mem n ni then + let n_copy = Ident.fresh (sourcename n) in + let base_ty = translate_btype base_ty in + Evarpat(n_copy), + { v_name = n_copy; v_copy_of = None; + v_type = base_ty; v_linearity = NotLinear; v_clock = Cbase } :: locals, + add n (make_exp (Evar n_copy) (Tbase(base_ty)) NotLinear Cbase no_location) + s_eqs + else Evarpat n, locals, s_eqs + | Heptagon.Etuplepat(l), Heptagon.Tprod(l_ty) -> + let l, locals, s_eqs = + List.fold_right2 + (fun pat ty (p_list, locals, s_eqs) -> + let pat, locals, s_eqs = rename_pat ni locals s_eqs (pat,ty) in + pat :: p_list, locals, s_eqs) l l_ty + ([], locals, s_eqs) in + Etuplepat(l), locals, s_eqs + | _ -> assert false + +let all_locals ni p = + IdentSet.is_empty (IdentSet.inter (Heptagon.Vars.vars_pat IdentSet.empty IdentSet.empty p) ni) + +let rec translate_eq env ni (locals, l_eqs, s_eqs) eq = + match Heptagon.eqdesc eq with + | Heptagon.Eswitch(e, switch_handlers) -> + translate_switch_handlers env ni (locals,l_eqs,s_eqs) e switch_handlers + | Heptagon.Eeq(Heptagon.Evarpat(n), e) when IdentSet.mem n ni -> + locals, + l_eqs, + add n (translate env e) s_eqs + | Heptagon.Eeq(p, e) when all_locals ni p -> + (* all vars from [p] are local *) + locals, + { p_lhs = translate_pat p; p_rhs = translate env e } :: l_eqs, + s_eqs + | Heptagon.Eeq(p, e) (* some are local *) -> + (* transforms [p = e] into [p' = e; p = p'] *) + let p', locals, s_eqs = + rename_pat ni locals s_eqs (p,e.Heptagon.e_ty) in + locals, + { p_lhs = p'; p_rhs = translate env e } :: l_eqs, + s_eqs + | Heptagon.Epresent _ | Heptagon.Eautomaton _ | Heptagon.Ereset _ -> + assert false + +and translate_eqs env ni (locals, local_eqs, shared_eqs) eq_list = + List.fold_left + (fun (locals, local_eqs, shared_eqs) eq -> + translate_eq env ni (locals, local_eqs, shared_eqs) eq) + (locals, local_eqs, shared_eqs) eq_list + +and translate_block env ni (locals, l_eqs) + { Heptagon.b_local = l; Heptagon.b_equs = eq_list} = + let env = Env.add l env in + let locals = translate_locals locals l in + let locals, local_eqs, shared_eqs = + translate_eqs env ni (locals, l_eqs, []) eq_list in + locals, local_eqs, shared_eqs + +and translate_switch_handlers env ni (locals, l_eqs, s_eqs) e handlers = + let rec transrec x ni_handlers (locals, l_eqs, ci_s_eqs_list) handlers = + match handlers with + [] -> locals, l_eqs, ci_s_eqs_list + | { Heptagon.w_name = ci; Heptagon.w_block = b } :: handlers -> + let locals, l_eqs, s_eqs = + translate_block (Env.push env ci x) ni_handlers (locals, l_eqs) b in + transrec x ni_handlers (locals, l_eqs, (ci, s_eqs) :: ci_s_eqs_list) + handlers in + + let def = function + [] -> IdentSet.empty + | { Heptagon.w_block = { Heptagon.b_defnames = env } } :: _ -> + (* Create set from env *) + (Ident.Env.fold (fun name _ set -> IdentSet.add name set) env IdentSet.empty) in + + let ni_handlers = def handlers in + let x, locals, l_eqs = equation locals l_eqs (translate env e) in + let locals, l_eqs, ci_s_eqs_list = + transrec x ni_handlers (locals, l_eqs, []) handlers in + let s_handlers = switch x ci_s_eqs_list in + let l_eqs, s_eqs = add_locals ni l_eqs s_eqs s_handlers in + locals, l_eqs, s_eqs + +let translate_contract env contract = + match contract with + | None -> None, env + | Some { Heptagon.c_local = v; + Heptagon.c_eq = eq_list; + Heptagon.c_assume = e_a; + Heptagon.c_enforce = e_g; + Heptagon.c_controllables = cl } -> + let env = Env.add cl env in + let env' = Env.add v env in + let locals = translate_locals [] v in + let locals, l_eqs, s_eqs = + translate_eqs env' IdentSet.empty (locals, [], []) eq_list in + let l_eqs, _ = add_locals IdentSet.empty l_eqs [] s_eqs in + let e_a = translate env' e_a in + let e_g = translate env' e_g in + Some { c_local = locals; + c_eq = l_eqs; + c_assume = e_a; + c_enforce = e_g; + c_controllables = List.map translate_var cl }, + env + + +let node + { Heptagon.n_name = n; Heptagon.n_input = i; Heptagon.n_output = o; + Heptagon.n_contract = contract; + Heptagon.n_local = l; Heptagon.n_equs = eq_list; + Heptagon.n_loc = loc; Heptagon.n_states_graph = states_graph; + Heptagon.n_params = params; Heptagon.n_params_constraints = params_constr } = + let env = Env.add o (Env.add i Env.empty) in + let contract, env = translate_contract env contract in + let env = Env.add l env in + let locals = translate_locals [] l in + let locals, l_eqs, s_eqs = + translate_eqs env IdentSet.empty (locals, [], []) eq_list in + let l_eqs, _ = add_locals IdentSet.empty l_eqs [] s_eqs in + { n_name = n; + n_input = List.map translate_var i; + n_output = List.map translate_var o; + n_contract = contract; + n_local = locals; + n_equs = l_eqs; + n_loc = loc ; + n_targeting = []; + n_mem_alloc = []; + n_states_graph = states_graph; + n_params = params; + n_params_constraints = params_constr; + n_params_instances = []; } + +let typedec + {Heptagon.t_name = n; Heptagon.t_desc = tdesc; Heptagon.t_loc = loc} = + let onetype = function + | Heptagon.Type_abs -> Type_abs + | Heptagon.Type_enum(tag_list) -> Type_enum(tag_list) + | Heptagon.Type_struct(field_ty_list) -> + Type_struct + (List.map (fun (f, ty) -> (f, translate_btype ty)) field_ty_list) + in + { t_name = n; t_desc = onetype tdesc; t_loc = loc } + +let const_dec cd = + { c_name = cd.Heptagon.c_name; + c_value = cd.Heptagon.c_value; + c_loc = cd.Heptagon.c_loc; } + +let program + { Heptagon.p_pragmas = pragmas; + Heptagon.p_opened = modules; + Heptagon.p_types = pt_list; + Heptagon.p_nodes = n_list; + Heptagon.p_consts = c_list; } = + { p_pragmas = pragmas; + p_opened = modules; + p_types = List.map typedec pt_list; + p_nodes = List.map node n_list; + p_consts = List.map const_dec c_list} diff --git a/main/main.ml b/main/main.ml new file mode 100644 index 0000000..15273c9 --- /dev/null +++ b/main/main.ml @@ -0,0 +1,100 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* the main *) + +(* $Id$ *) + +open Misc +open Compiler + +let compile file = + if Filename.check_suffix file ".ept" + then + let filename = Filename.chop_suffix file ".ept" in + let modname = String.capitalize(Filename.basename filename) in + compile modname filename + else if Filename.check_suffix file ".epi" + then + let filename = Filename.chop_suffix file ".epi" in + let modname = String.capitalize(Filename.basename filename) in + interface modname filename + else + raise (Arg.Bad ("don't know what to do with " ^ file)) + +let doc_verbose = "\t\t\tSet verbose mode" +and doc_version = "\t\tThe version of the compiler" +and doc_print_types = "\t\t\tPrint types" +and doc_include = "\t\tAdd to the list of include directories" +and doc_stdlib = "\t\tDirectory for the standard library" +and doc_sim = "\t\tCreate simulation for node " +and doc_locate_stdlib = "\t\tLocate standard libray" +and doc_no_pervasives = "\tDo not load the pervasives module" +and doc_target = + "\tGenerate code in language \n\t\t\t(with =c, c-old," + ^ " vhdl_seq, vhdl_df,\n\t\t\t java, caml or z3z)" +and doc_full_type_info = "\t\t\tPrint full type information" +and doc_target_path = + "\tGenerated files will be placed in \n\t\t\t(the directory is cleaned)" +and doc_boolean = "\t\tTranslate enumerated values towards boolean vectors" +and doc_deadcode = "\t\tDeadcode removal" +and doc_noinit = "\t\tDisable initialization analysis" +and doc_cse = "\t\t\tPerform common sub-expression elimination" +and doc_tomato = "\t\tPerform auTOMATa minimizatiOn" +and doc_sigali = "\t\t\tGenerate symbolic equations for Sigali (Z/3Z format)" +and doc_flatten = "\tRecursively inline all calls in specified node" +and doc_inline = "\tInline the list of nodes, separated by commas" +and doc_dep2dot = "\tOutput to .dot files the dependency graph of " + ^ "the list of nodes, separated by commas" +and doc_intermediate = "\t\tPerform intermediate-equations removal (buggy)" +and doc_nomemalloc = "\t\tDisable memory allocation algorithm" +and doc_interfscheduler = "\tUse the new scheduler, that tries to minimise interference" +and doc_main_node = "\t\tUse as the toplevel node" +and doc_new_reset = "\t\tUse the new alternate encoding of resets" + +let errmsg = "Options are:" + +let main () = + try + Arg.parse + [ + "-v",Arg.Set verbose, doc_verbose; + "-version", Arg.Unit show_version, doc_version; + "-i", Arg.Set print_types, doc_print_types; + "-I", Arg.String add_include, doc_include; + "-where", Arg.Unit locate_stdlib, doc_locate_stdlib; + "-stdlib", Arg.String set_stdlib, doc_stdlib; + "-s", Arg.String set_simulation_node, doc_sim; + "-nopervasives", Arg.Unit set_no_pervasives, doc_no_pervasives; + "-target", Arg.String add_target_language, doc_target; + "-targetpath", Arg.String set_target_path, doc_target_path; + "-bool", Arg.Set boolean, doc_boolean; + "-deadcode", Arg.Set deadcode, doc_deadcode; + "-noinit", Arg.Clear init, doc_noinit; + "-fti", Arg.Set full_type_info, doc_full_type_info; + "-cse", Arg.Set cse, doc_cse; + "-tomato", Arg.Set tomato, doc_tomato; + "-z3z", Arg.Unit set_sigali, doc_sigali; + "-inter", Arg.Set intermediate, doc_intermediate; + "-flatten", Arg.String (fun s -> node_to_flatten := Some s), doc_flatten; + ("-inline", + Arg.String (fun s -> nodes_to_inline := Misc.split_string s ','), + doc_inline); + ("-dep2dot", + Arg.String (fun s -> nodes_to_display := Misc.split_string s ','), + doc_dep2dot); + "-nomemalloc", Arg.Set no_mem_alloc, doc_nomemalloc; + "-interfscheduler", Arg.Set use_interf_scheduler, doc_interfscheduler; + "-new-reset-encoding", Arg.Set use_new_reset_encoding, doc_new_reset; + ] + compile + errmsg; + with + | Misc.Error -> exit 2;; + +main () diff --git a/minils/minils.ml b/minils/minils.ml new file mode 100644 index 0000000..2940871 --- /dev/null +++ b/minils/minils.ml @@ -0,0 +1,753 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* The internal MiniLustre representation *) + +(* $Id$ *) + +open Location +open Dep +open Misc +open Names +open Ident +open Linearity +open Interference_graph +open Global +open Static + +(** Inlining policies, to be held in app records. *) +type inlining_policy = + | Ino (** Do not inline. *) + | Ione (** Just inline on one step. *) + | Irec (** Recursively inline all sub-calls. *) + +type type_dec = + { t_name: name; + t_desc: tdesc; + t_loc: location } + +and tdesc = + | Type_abs + | Type_enum of name list + | Type_struct of (name * base_ty) list + +and exp = + { e_desc: desc; (* its descriptor *) + mutable e_ck: ck; + mutable e_ty: ty; + mutable e_linearity : linearity; + e_loc: location } + +and desc = + | Econst of const + | Evar of ident + | Econstvar of name + | Efby of const option * exp + | Ereset_mem of ident * const * ident + | Etuple of exp list + | Eop of longname * size_exp list * exp list + | Eapp of app * size_exp list * exp list + | Eevery of app * size_exp list * exp list * ident + | Ewhen of exp * longname * ident + | Emerge of ident * (longname * exp) list + | Eifthenelse of exp * exp * exp + | Efield of exp * longname + | Estruct of (longname * exp) list +(*Array operators*) + | Earray of exp list + | Erepeat of size_exp * exp + | Eselect of size_exp list * exp (*indices, array*) + | Eselect_dyn of exp list * size_exp list * exp * exp (*indices, bounds, array, default*) + | Eupdate of size_exp list * exp * exp (*indices, array, value*) + | Eselect_slice of size_exp * size_exp * exp (*lower bound, upper bound, array*) + | Econcat of exp * exp + | Eiterator of iterator_name * longname * size_exp list * size_exp * exp list * ident option + | Efield_update of longname * exp * exp (*field, record, value*) + +and app = + { a_op: longname; + a_inlined: inlining_policy + } + +and ct = + | Ck of ck + | Cprod of ct list + +and ck = + | Cbase + | Cvar of link ref + | Con of ck * longname * ident + +and link = + | Cindex of int + | Clink of ck + +and ty = + | Tbase of base_ty + | Tprod of ty list + +and base_ty = + | Tint | Tfloat + | Tid of longname + | Tarray of base_ty * size_exp + +and const = + | Cint of int + | Cfloat of float + | Cconstr of longname + | Cconst_array of size_exp * const + +and pat = + | Etuplepat of pat list + | Evarpat of ident + +type eq = + { p_lhs : pat; + p_rhs : exp; } + +type var_dec = + { v_name : ident; + v_copy_of : ident option; + v_type : base_ty; + v_linearity : linearity; + v_clock : ck } + +type contract = + { c_assume : exp; + c_enforce : exp; + c_controllables : var_dec list; + c_local : var_dec list; + c_eq : eq list; + } + +type node_dec = + { n_name : name; + n_input : var_dec list; + n_output : var_dec list; + n_contract : contract option; + n_local : var_dec list; + n_equs : eq list; + n_loc : location; + n_targeting : (int*int) list; + n_mem_alloc : (base_ty * ivar list) list; + n_states_graph : (name,name) interf_graph; + n_params : name list; + n_params_constraints : size_constr list; + n_params_instances : (int list) list; } + +type const_dec = + { c_name : name; + c_value : size_exp; + c_loc : location; } + +type program = + { p_pragmas: (name * string) list; + p_opened : name list; + p_types : type_dec list; + p_nodes : node_dec list; + p_consts : const_dec list; } + +(*Helper functions to build the AST*) +let make_exp desc ty l ck loc = + { e_desc = desc; e_ty = ty; e_linearity = l; e_ck = ck; e_loc = loc } + +let make_dummy_exp desc ty = + { e_desc = desc; e_ty = ty; e_linearity = NotLinear; + e_ck = Cbase; e_loc = no_location } + +(* Helper functions to work with types *) +let base_type = function + | Tbase(bty) -> bty + | Tprod _ -> assert false + +(* get the type of an expression ; assuming that this type is a base type *) +let exp_base_type e = + base_type e.e_ty + +let rec size_exp_of_exp e = + match e.e_desc with + | Econstvar n -> SVar n + | Econst (Cint i) -> SConst i + | Eop(op, _, [e1;e2]) -> + let sop = op_from_app_name op in + SOp(sop, size_exp_of_exp e1, size_exp_of_exp e2) + | _ -> raise Not_static + +(*Returns the list of bounds of an array type*) +let rec bounds_list ty = + match ty with + | Tarray(ty, n) -> n::(bounds_list ty) + | _ -> [] + +(** Returns the var_dec object corresponding to the name n + in a list of var_dec. *) +let rec vd_find n = function + | [] -> Format.printf "Not found var %s\n" (name n); raise Not_found + | vd::l -> + if vd.v_name = n then vd else vd_find n l + +(** Returns whether an object of name n belongs to + a list of var_dec. *) +let rec vd_mem n = function + | [] -> false + | vd::l -> vd.v_name = n or (vd_mem n l) + +(** Same as vd_mem but for an ivar value. *) +let ivar_vd_mem var vds = + match var with + | IVar id -> vd_mem id vds + | _ -> false + +(** [is_record_type ty] returns whether ty corresponds to a record type. *) +let is_record_type ty = + match ty with + | Tid n -> + (try + ignore (Modules.find_struct n); + true + with + Not_found -> false + ) + | _ -> false + + +module Vars = +struct + let rec vars_pat acc = function + | Evarpat(x) -> x :: acc + | Etuplepat(pat_list) -> List.fold_left vars_pat acc pat_list + + let rec vars_ck acc = function + | Con(ck, c, n) -> if List.mem (IVar n) acc then acc else (IVar n) :: acc + | Cbase | Cvar { contents = Cindex _ } -> acc + | Cvar { contents = Clink ck } -> vars_ck acc ck + + let rec read is_left acc e = + let add x acc = if List.mem (IVar x) acc then acc else (IVar x) :: acc in + let acc = + match e.e_desc with + | Emerge(x, c_e_list) -> + let acc = add x acc in + List.fold_left (fun acc (_, e) -> read is_left acc e) acc c_e_list + | Eifthenelse(e1, e2, e3) -> + read is_left (read is_left (read is_left acc e1) e2) e3 + | Ewhen(e, c, x) -> + let acc = add x acc in + read is_left acc e + | Eop(_, _, e_list) + | Etuple(e_list) -> List.fold_left (read is_left) acc e_list + | Eapp(_, _, e_list) -> List.fold_left (read is_left) acc e_list + | Eevery(_, _, e_list, x) -> + let acc = add x acc in + List.fold_left (read is_left) acc e_list + | Efby(_, e) -> + if is_left then vars_ck acc e.e_ck else read is_left acc e + | Ereset_mem (_, _,res) -> add res acc + | Evar(n) -> add n acc + | Efield({ e_desc = Evar x }, f) -> + let acc = add x acc in + let x = IField(x,f) in + if List.mem x acc then acc else x::acc + | Efield(e, _) -> read is_left acc e + | Estruct(f_e_list) -> + List.fold_left (fun acc (_, e) -> read is_left acc e) acc f_e_list + | Econst _ | Econstvar _ -> acc + (*Array operators*) + | Earray e_list -> List.fold_left (read is_left) acc e_list + | Erepeat (_,e) -> read is_left acc e + | Eselect (_,e) -> read is_left acc e + | Eselect_dyn (e_list, _, e1, e2) -> + let acc = List.fold_left (read is_left) acc e_list in + read is_left (read is_left acc e1) e2 + | Eupdate (_, e1, e2) | Efield_update (_, e1, e2) -> + read is_left (read is_left acc e1) e2 + | Eselect_slice (_ , _, e) -> read is_left acc e + | Econcat (e1, e2) -> + read is_left (read is_left acc e1) e2 + | Eiterator (_, _, _, _, e_list, _) -> + List.fold_left (read is_left) acc e_list + in + vars_ck acc e.e_ck + + let rec remove x = function + | [] -> [] + | y :: l -> if x = y then l else y :: remove x l + + let def acc { p_lhs = pat } = vars_pat acc pat + + let read is_left { p_lhs = pat; p_rhs = e } = + match pat, e.e_desc with + | Evarpat(n), Efby(_, e1) -> + if is_left + then remove (IVar n) (read is_left [] e1) + else read is_left [] e1 + | _ -> read is_left [] e + + let rec remove_records = function + | [] -> [] + | (IVar x)::l -> (IVar x)::(remove_records l) + | (IField(x,f))::l -> + let l = remove (IVar x) l in + (IField(x,f))::(remove_records l) + + let read_ivars is_left eq = + remove_records (read is_left eq) + + let read is_left eq = + filter_vars (read is_left eq) + + let antidep { p_rhs = e } = + match e.e_desc with Efby _ -> true | _ -> false + let clock { p_rhs = e } = + match e.e_desc with + | Emerge(_, (_, e) :: _) -> e.e_ck + | _ -> e.e_ck + let head ck = + let rec headrec ck l = + match ck with + | Cbase | Cvar { contents = Cindex _ } -> l + | Con(ck, c, n) -> headrec ck (n :: l) + | Cvar { contents = Clink ck } -> headrec ck l in + headrec ck [] + + let rec linear_use acc e = + match e.e_desc with + | Emerge(_, c_e_list) -> + List.fold_left (fun acc (_, e) -> linear_use acc e) acc c_e_list + | Eifthenelse(e1, e2, e3) -> + linear_use (linear_use (linear_use acc e1) e2) e3 + | Ewhen(e, _, _) | Efield(e, _) | Efby(_, e) -> linear_use acc e + | Eop(_,_, e_list) + | Etuple(e_list) | Earray e_list + | Eapp(_,_, e_list) | Eiterator (_, _, _, _, e_list, _) + | Eevery(_,_, e_list, _) -> List.fold_left linear_use acc e_list + | Evar(n) -> + (match e.e_linearity with + | At _ -> if List.mem n acc then acc else n :: acc + | _ -> acc + ) + | Estruct(f_e_list) -> + List.fold_left (fun acc (_, e) -> linear_use acc e) acc f_e_list + | Econst _ | Econstvar _ | Ereset_mem (_, _,_) -> acc + (*Array operators*) + | Erepeat (_,e) + | Eselect (_,e) | Eselect_slice (_ , _, e) -> linear_use acc e + | Eselect_dyn (e_list, _, e1, e2) -> + let acc = List.fold_left linear_use acc e_list in + linear_use (linear_use acc e1) e2 + | Eupdate (_, e1, e2) | Efield_update (_, e1, e2) + | Econcat (e1, e2) -> + linear_use (linear_use acc e1) e2 + + let mem_reset { p_rhs = e } = + match e.e_desc with + | Ereset_mem (y, _, _) -> [y] + | _ -> [] +end + +(* data-flow dependences. pre-dependences are discarded *) +module DataFlowDep = Make + (struct + type equation = eq + let read eq = Vars.read true eq + let def = Vars.def + let linear_read eq = Vars.linear_use [] eq.p_rhs + let mem_reset = Vars.mem_reset + let antidep = Vars.antidep + end) + +(* all dependences between variables *) +module AllDep = Make + (struct + type equation = eq + let read eq = Vars.read false eq + let linear_read eq = Vars.linear_use [] eq.p_rhs + let mem_reset = Vars.mem_reset + let def = Vars.def + let antidep eq = false + end) + +module Printer = +struct + open Format + + let is_infix = + let module StrSet = Set.Make(String) in + let set_infix = StrSet.singleton "or" in + fun s -> + if (StrSet.mem s set_infix) then true + else begin + match (String.get s 0) with + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> false + | _ -> true + end + + let rec print_list ff print sep l = + match l with + | [] -> () + | [x] -> print ff x + | x :: l -> + print ff x; + fprintf ff "%s@ " sep; + print_list ff print sep l + + let print_name ff n = + let n = if is_infix n then + match n with + | "*" -> "( * )" + | _ -> "(" ^ n ^ ")" + else n + in fprintf ff "%s" n + + let print_longname ff n = + match n with + | Name(m) -> print_name ff m + | Modname({ qual = "Pervasives"; id = m }) -> + print_name ff m + | Modname({ qual = m1; id = m2 }) -> + fprintf ff "%s." m1; print_name ff m2 + + let print_ident ff id = + fprintf ff "%s" (name id) + + let rec print_pat ff = function + | Evarpat(n) -> print_ident ff n + | Etuplepat(pat_list) -> + fprintf ff "@[("; + print_list ff print_pat "," pat_list; + fprintf ff ")@]" + + let rec print_base_type ff = function + | Tint -> fprintf ff "int" + | Tfloat -> fprintf ff "float" + | Tid(id) -> print_longname ff id + | Tarray(ty, n) -> + print_base_type ff ty; + fprintf ff "^"; + print_size_exp ff n + + let rec print_type ff = function + | Tbase(base_ty) -> print_base_type ff base_ty + | Tprod(ty_list) -> + fprintf ff "@[("; + print_list ff print_type " *" ty_list; + fprintf ff ")@]" + + let rec print_ck ff = function + | Cbase -> fprintf ff "base" + | Con(ck, c, n) -> + print_ck ff ck; fprintf ff " on "; + print_longname ff c; fprintf ff "("; + print_ident ff n; fprintf ff ")" + | Cvar { contents = Cindex n } -> fprintf ff "base" + | Cvar { contents = Clink ck } -> print_ck ff ck + + let rec print_clock ff = function + | Ck(ck) -> print_ck ff ck + | Cprod(ct_list) -> + fprintf ff "@[("; + print_list ff print_clock " *" ct_list; + fprintf ff ")@]" + + let print_vd ff { v_name = n; v_type = ty; v_clock = ck } = + fprintf ff "@["; + print_ident ff n; + fprintf ff ":"; + print_base_type ff ty; + fprintf ff " at "; + print_ck ff ck; + fprintf ff "@]" + + let rec print_c ff = function + | Cint i -> fprintf ff "%d" i + | Cfloat f -> fprintf ff "%f" f + | Cconstr(tag) -> print_longname ff tag + | Cconst_array (n, c) -> + print_c ff c; + fprintf ff "^"; + print_size_exp ff n + + let print_call_params ff = function + | [] -> () + | l -> + fprintf ff "<<"; + print_list ff print_size_exp "," l; + fprintf ff ">>" + + let rec print_exps ff e_list = + fprintf ff "@[(";print_list ff print_exp "," e_list; fprintf ff ")@]" + + and print_exp ff e = + if !Misc.full_type_info then fprintf ff "("; + begin match e.e_desc with + | Evar x -> print_ident ff x + | Econstvar x -> print_name ff x + | Econst c -> print_c ff c + | Efby(Some(c), e) -> + print_c ff c; fprintf ff " fby "; print_exp ff e + | Ereset_mem(y,v,res) -> + fprintf ff "@[reset_mem "; + print_ident ff y; + fprintf ff " = "; + print_c ff v; + fprintf ff " every "; + print_ident ff res; + fprintf ff "@]" + | Efby(None, e) -> + fprintf ff "pre "; print_exp ff e + | Eop((Name(m) | Modname { qual = "Pervasives"; id = m }), params, [e1;e2]) + when is_infix m -> + fprintf ff "(%a %s %a %a)" + print_exp e1 + m + print_call_params params + print_exp e2 + | Eop(op, params, e_list) -> + print_longname ff op; + print_call_params ff params; + print_exps ff e_list + | Eapp({ a_op = f }, params, e_list) -> + print_longname ff f; + print_call_params ff params; + print_exps ff e_list + | Eevery({ a_op = f }, params, e_list, x) -> + print_longname ff f; + print_call_params ff params; + print_exps ff e_list; + fprintf ff " every "; print_ident ff x + | Ewhen(e, c, n) -> + fprintf ff "("; + print_exp ff e; + fprintf ff " when "; + print_longname ff c; fprintf ff "("; + print_ident ff n; fprintf ff ")"; + fprintf ff ")" + | Eifthenelse(e1, e2, e3) -> + fprintf ff "@[if ";print_exp ff e1; + fprintf ff "@ then "; + print_exp ff e2; + fprintf ff "@ else "; + print_exp ff e3; + fprintf ff "@]" + | Emerge(x, tag_e_list) -> + fprintf ff "@[merge ";print_ident ff x;fprintf ff "@ "; + fprintf ff "@["; + print_tag_e_list ff tag_e_list; + fprintf ff "@]@]" + | Etuple(e_list) -> + fprintf ff "@[("; + print_list ff print_exp "," e_list; + fprintf ff ")@]" + | Efield(e, field) -> + print_exp ff e; + fprintf ff "."; + print_longname ff field + | Estruct(f_e_list) -> + fprintf ff "@[{"; + print_list ff + (fun ff (field, e) -> print_longname ff field;fprintf ff " = "; + print_exp ff e) + ";" f_e_list; + fprintf ff "}@]" + (*Array operators*) + | Earray e_list -> + fprintf ff "@[["; + print_list ff print_exp ";" e_list; + fprintf ff "]@]" + | Erepeat (n,e) -> + print_exp ff e; + fprintf ff "^"; + print_size_exp ff n + | Eselect (idx,e) -> + print_exp ff e; + fprintf ff "["; + print_list ff print_size_exp "][" idx; + fprintf ff "]" + | Eselect_dyn (idx, _, e1, e2) -> + fprintf ff "@["; + print_exp ff e1; + fprintf ff "["; + print_list ff print_exp "][" idx; + fprintf ff "] default "; + print_exp ff e2; + fprintf ff "@]" + | Eupdate (idx, e1, e2) -> + fprintf ff "@["; + print_exp ff e1; + fprintf ff " with ["; + print_list ff print_size_exp "][" idx; + fprintf ff "] = "; + print_exp ff e2; + fprintf ff "@]" + | Eselect_slice (idx1, idx2, e) -> + print_exp ff e; + fprintf ff "["; + print_size_exp ff idx1; + fprintf ff ".."; + print_size_exp ff idx2; + fprintf ff "]" + | Econcat (e1, e2) -> + print_exp ff e1; + fprintf ff " @@ "; + print_exp ff e2 + | Eiterator (it, f, params, n, e_list, reset) -> + fprintf ff "("; + fprintf ff "%s" (iterator_to_string it); + fprintf ff " "; + (match params with + | [] -> print_longname ff f + | l -> + fprintf ff "("; + print_longname ff f; + print_call_params ff params; + fprintf ff ")" + ); + fprintf ff " <<"; + print_size_exp ff n; + fprintf ff ">>) (@["; + print_list ff print_exp "," e_list; + fprintf ff ")@]"; + (match reset with + | None -> () + | Some r -> fprintf ff " every %s" (name r) + ) + | Efield_update (f, e1, e2) -> + fprintf ff "@["; + print_exp ff e1; + fprintf ff " with ."; + print_longname ff f; + fprintf ff " = "; + print_exp ff e2; + fprintf ff "@]" + end; + if !Misc.full_type_info + then begin + fprintf ff " : %a)" print_type e.e_ty; + if e.e_loc = no_location then fprintf ff " (no loc)" + end + and print_tag_e_list ff tag_e_list = + print_list ff + (fun ff (tag, e) -> + fprintf ff "@[("; + print_longname ff tag; + fprintf ff " -> "; + print_exp ff e; + fprintf ff ")@]@,") "" + tag_e_list + + let print_eq ff { p_lhs = p; p_rhs = e } = + fprintf ff "@["; + print_pat ff p; + (* (\* DEBUG *\) *) + (* fprintf ff " : "; *) + (* print_ck ff e.e_ck; *) + (* (\* END DEBUG *\) *) + fprintf ff " =@ "; + print_exp ff e; + if !Misc.full_type_info + then begin fprintf ff "@ at "; print_ck ff e.e_ck end; + fprintf ff ";@]" + + let print_eqs ff l = + fprintf ff "@["; print_list ff print_eq "" l; fprintf ff "@]" + + let print_open_module ff name = + fprintf ff "@[open "; + print_name ff name; + fprintf ff "@.@]" + + let print_type_def ff { t_name = name; t_desc = tdesc } = + match tdesc with + | Type_abs -> fprintf ff "@[type %s@\n@]" name + | Type_enum(tag_name_list) -> + fprintf ff "@[type %s = " name; + print_list ff print_name "|" tag_name_list; + fprintf ff "@\n@]" + | Type_struct(f_ty_list) -> + fprintf ff "@[type %s = " name; + fprintf ff "@[{"; + print_list ff + (fun ff (field, ty) -> print_name ff field; + fprintf ff ": "; + print_base_type ff ty) ";" f_ty_list; + fprintf ff "}@]@\n@]" + + let print_contract ff {c_local = l; + c_eq = eqs; + c_assume = e_a; + c_enforce = e_g; + c_controllables = cl } = + if l <> [] then begin + fprintf ff "contract\n"; + fprintf ff "@[var "; + print_list ff print_vd ";" l; + fprintf ff ";@]\n" + end; + if eqs <> [] then begin + fprintf ff "@[let @,"; + print_eqs ff eqs; + fprintf ff "@]"; fprintf ff "tel\n" + end; + fprintf ff "assume@ %a@;enforce@ %a with (" + print_exp e_a + print_exp e_g; + print_list ff print_vd ";" cl; + fprintf ff ")" + + let print_node_params ff = function + | [] -> () + | l -> + fprintf ff "<<"; + print_list ff print_name "," l; + fprintf ff ">>" + + let print_node ff + { n_name = n;n_input = ni;n_output = no; + n_contract = contract; + n_local = nl; n_equs = ne; + n_params = params; } = + fprintf ff "@[node %s" n; + print_node_params ff params; + fprintf ff "(@["; + print_list ff print_vd ";" ni; + fprintf ff "@]) returns (@["; + print_list ff print_vd ";" no; + fprintf ff "@])@,"; + optunit (print_contract ff) contract; + if nl <> [] then begin + fprintf ff "@[var "; + print_list ff print_vd ";" nl; + fprintf ff ";@]@," + end; + fprintf ff "@[let @,"; + print_eqs ff ne; + fprintf ff "@]@;"; fprintf ff "tel";fprintf ff "@.@]" + + let print_exp oc e = + let ff = formatter_of_out_channel oc in + print_exp ff e; + fprintf ff "@." + + let print_type oc ty = + let ff = formatter_of_out_channel oc in + print_type ff ty; + fprintf ff "@?" + + let print_clock oc ct = + let ff = formatter_of_out_channel oc in + print_clock ff ct; + fprintf ff "@?" + + let print oc { p_opened = pm; p_types = pt; p_nodes = pn } = + let ff = formatter_of_out_channel oc in + List.iter (print_open_module ff) pm; + List.iter (print_type_def ff) pt; + List.iter (print_node ff) pn; + fprintf ff "@?" +end diff --git a/minils/sequential/c.ml b/minils/sequential/c.ml new file mode 100644 index 0000000..035f0d0 --- /dev/null +++ b/minils/sequential/c.ml @@ -0,0 +1,337 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id$ *) + +open Format +open List +open Modules + + +let rec print_list ff print sep l = + match l with + | [] -> () + | [x] -> print ff x + | x :: l -> + print ff x; + fprintf ff "%s@ " sep; + print_list ff print sep l + + +(******************************) + +(** {2 C abstract syntax tree } *) + +(** Here is the C abstract syntax tree used by MiniLS for its C backend. It does + not try to completly model the C language, only the relatively small part + that were are interested in (e.g. no function pointers or local variable + initialization). *) + +(** C types relevant for Obc. Note the absence of function pointers. *) +type cty = + | Cty_int (** C machine-dependent integer type. *) + | Cty_float (** C machine-dependent single-precision floating-point type. *) + | Cty_char (** C character type. *) + | Cty_id of string (** Previously defined C type, such as an enum or struct. *) + | Cty_ptr of cty (** C points-to-other-type type. *) + | Cty_arr of int * cty (** A static array of the specified size. *) + | Cty_void (** Well, [void] is not really a C type. *) + +(** A C block: declarations and statements. In source code form, it begins with + variable declarations before a list of semicolon-separated statements, the + whole thing being enclosed in curly braces. *) +type cblock = { + (** Variable declarations, where each declaration consists of a variable + name and the associated C type. *) + var_decls : (string * cty) list; + (** The actual statement forming our block. *) + block_body : cstm list; +} + +(* TODO: The following types for C expressions would be better using polymorphic + variants to define LHS expressions as a proper superset of general + expressions. *) + +(** C expressions. *) +and cexpr = + | Cuop of string * cexpr (** Unary operator with its name. *) + | Cbop of string * cexpr * cexpr (** Binary operator. *) + | Cfun_call of string * cexpr list (** Function call with its parameters. *) + | Cconst of cconst (** Constants. *) + | Clhs of clhs (** Left-hand-side expressions are obviously expressions! *) + | Caddrof of clhs (** Take the address of a left-hand-side expression. *) + | Cstructlit of string * cexpr list (** Structure literal "{ f1, f2, ... }". *) + | Carraylit of cexpr list (** Array literal [e1, e2, ...]. *) +and cconst = + | Ccint of int (** Integer constant. *) + | Ccfloat of float (** Floating-point number constant. *) + | Ctag of string (** Tag, member of a previously declared enumeration. *) + | Cstrlit of string (** String literal, enclosed in double-quotes. *) + (** C left-hand-side (ie. affectable) expressions. *) +and clhs = + | Cvar of string (** A local variable. *) + | Cderef of clhs (** Pointer dereference, *ptr. *) + | Cfield of clhs * string (** Field access to left-hand-side. *) + | Carray of clhs * cexpr (** Array access clhs[cexpr] *) + (** C statements. *) +and cstm = + | Csexpr of cexpr (** Expression evaluation, may cause side-effects! *) + | Csblock of cblock (** A local sub-block, can have its own private decls. **) + | Cskip (** A dummy instruction that does nothing and will not be printed. *) + | Caffect of clhs * cexpr (** Affect the result of an expression to a lhs. *) + | Cif of cexpr * cstm list * cstm list (** Alternative *) + | Cswitch of cexpr * (string * cstm list) list (** Case/switch over an enum. *) + | Cwhile of cexpr * cstm list (** While loop. *) + | Cfor of string * int * int * cstm list (** For loop. int <= string < int *) + | Creturn of cexpr (** Ends a procedure/function by returning an expression.*) + +(** C type declarations ; will {b always} correspond to a typedef in emitted + source code. *) +type cdecl = + (** C enum declaration, with associated value tags. *) + | Cdecl_enum of string * string list + (** C structure declaration, with each field's name and type. *) + | Cdecl_struct of string * (string * cty) list + (** C function declaration. *) + | Cdecl_function of string * cty * (string * cty) list + +(** C function definitions *) +type cfundef = { + f_name : string; (** The function's name. *) + f_retty : cty; (** The function's return type. *) + f_args : (string * cty) list; (** Each parameter's name and type. *) + f_body : cblock; (** Actual instructions, in the form of a block. *) +} + +(** C top-level definitions. *) +type cdef = + | Cfundef of cfundef (** Function definition, see [cfundef]. *) + | Cvardef of string * cty (** A variable definition, with its name and type. *) + +(** [cdecl_of_cfundef cfd] returns a declaration for the function def. [cfd]. *) +let cdecl_of_cfundef cfd = match cfd with + | Cfundef cfd -> Cdecl_function (cfd.f_name, cfd.f_retty, cfd.f_args) + | _ -> invalid_arg "cdecl_of_cfundef" + +(** A C file can be a source file, containing definitions, or a header file, + containing declarations. *) +type cfile = string * cfile_desc +and cfile_desc = + | Cheader of string list * cdecl list (** Header dependencies * declaration + list *) + | Csource of cdef list + +(******************************) + +(** {3 Pretty-printing of the C ast.} *) + +(** [pp_list1 f sep fmt l] pretty-prints into the Format.formatter [fmt] elements + of the list [l] via the function [f], separated by [sep] strings and + breakable spaces. *) +let rec pp_list1 f sep fmt l = match l with + | [] -> fprintf fmt "" + | [x] -> fprintf fmt "%a" f x + | h :: t -> fprintf fmt "%a%s@ %a" f h sep (pp_list1 f sep) t + +let rec pp_list f sep fmt l = match l with + | [] -> fprintf fmt "" + | h :: t -> fprintf fmt "@ %a%s%a" f h sep (pp_list f sep) t + +let pp_string fmt s = fprintf fmt "%s" s + +let rec pp_cty fmt cty = match cty with + | Cty_int -> fprintf fmt "int" + | Cty_float -> fprintf fmt "float" + | Cty_char -> fprintf fmt "char" + | Cty_id s -> fprintf fmt "%s" s + | Cty_ptr cty' -> fprintf fmt "%a*" pp_cty cty' + | Cty_arr (n, cty') -> fprintf fmt "%a[%d]" pp_cty cty' n + | Cty_void -> fprintf fmt "void" + +(** [pp_array_decl cty] returns the base type of a (multidimensionnal) array + and the string of indices. *) +let rec pp_array_decl cty = + match cty with + | Cty_arr(n, cty') -> + let ty, s = pp_array_decl cty' in + ty, sprintf "%s[%d]" s n + | _ -> cty, "" + +(* pp_vardecl, featuring an ugly hack coping with C's inconsistent concrete + syntax! *) +let rec pp_vardecl fmt (s, cty) = match cty with + | Cty_arr (n, cty') -> + let base_ty, indices = pp_array_decl cty in + fprintf fmt "%a %s%s" pp_cty base_ty s indices + | _ -> fprintf fmt "%a %s" pp_cty cty s +and pp_paramdecl fmt (s, cty) = match cty with + | Cty_arr (n, cty') -> fprintf fmt "%a* %s" pp_cty cty' s + | _ -> pp_vardecl fmt (s, cty) +and pp_param_list fmt l = pp_list1 pp_paramdecl "," fmt l +and pp_var_list fmt l = pp_list pp_vardecl ";" fmt l + +let rec pp_cblock fmt cb = + let pp_varlist = pp_list pp_vardecl ";" in + fprintf fmt "%a%a" pp_varlist cb.var_decls pp_cstm_list cb.block_body +and pp_cstm_list fmt stml = pp_list pp_cstm ";" fmt stml +and pp_cstm fmt stm = match stm with + | Csexpr e -> fprintf fmt "%a" pp_cexpr e + | Cswitch (e, cl) -> + let pp_clause fmt (tag, stml) = + fprintf fmt "@[case %a:%a@ break;@]" + pp_cexpr (Cconst (Ctag tag)) pp_cstm_list stml in + fprintf fmt "@[@[switch (%a) {%a@]@ }@]" + pp_cexpr e (pp_list pp_clause "") cl + | Caffect (lhs, e) -> + fprintf fmt "%a = %a" pp_clhs lhs pp_cexpr e + | Cif (c, t, []) -> + fprintf fmt "@[@[if (%a) {%a@]@ }@]" + pp_cexpr c pp_cstm_list t + | Cif (c, t, e) -> + fprintf fmt "@[@[if (%a) {%a@]@ @[} else {%a@]@ }@]" + pp_cexpr c pp_cstm_list t pp_cstm_list e + | Cfor(x, lower, upper, e) -> + fprintf fmt "@[@[for (int %s = %d; %s < %d; ++%s) {%a@]@ }@]" + x lower x upper x pp_cstm_list e + | Cwhile (e, b) -> + fprintf fmt "@[@[while (%a) {%a@]@ }@]" pp_cexpr e pp_cstm_list b + | Csblock cb -> pp_cblock fmt cb + | Cskip -> fprintf fmt "" + | Creturn e -> fprintf fmt "return %a" pp_cexpr e +and pp_cexpr fmt ce = match ce with + | Cuop (s, e) -> fprintf fmt "%s(%a)" s pp_cexpr e + | Cbop (s, l, r) -> fprintf fmt "(%a%s%a)" pp_cexpr l s pp_cexpr r + | Cfun_call (s, el) -> fprintf fmt "%s(@[%a@])" s (pp_list1 pp_cexpr ",") el + | Cconst (Ccint i) -> fprintf fmt "%d" i + | Cconst (Ccfloat f) -> fprintf fmt "%f" f + | Cconst (Ctag "true") -> fprintf fmt "TRUE" + | Cconst (Ctag "false") -> fprintf fmt "FALSE" + | Cconst (Ctag t) -> fprintf fmt "%s" t + | Cconst (Cstrlit t) -> fprintf fmt "\"%s\"" t + | Clhs lhs -> fprintf fmt "%a" pp_clhs lhs + | Caddrof lhs -> fprintf fmt "&%a" pp_clhs lhs + | Cstructlit (s, el) -> + fprintf fmt "(%s){@[%a@]}" s (pp_list1 pp_cexpr ",") el + | Carraylit el -> + fprintf fmt "[@[%a@]]" (pp_list1 pp_cexpr ",") el +and pp_clhs fmt lhs = match lhs with + | Cvar s -> fprintf fmt "%s" s + | Cderef lhs' -> fprintf fmt "*%a" pp_clhs lhs' + | Cfield (Cderef lhs, f) -> fprintf fmt "%a->%s" pp_clhs lhs f + | Cfield (lhs, f) -> fprintf fmt "%a.%s" pp_clhs lhs f + | Carray (lhs, e) -> + fprintf fmt "%a[%a]" + pp_clhs lhs + pp_cexpr e + +let pp_cdecl fmt cdecl = match cdecl with + | Cdecl_enum (s, sl) -> + fprintf fmt "@[@[typedef enum {@ %a@]@ } %s;@ @]@\n" + (pp_list1 pp_string ",") sl s + | Cdecl_struct (s, fl) -> + let pp_field fmt (s, cty) = + fprintf fmt "@ %a;" pp_vardecl (s,cty) in + fprintf fmt "@[@[typedef struct %s {" s; + List.iter (pp_field fmt) fl; + fprintf fmt "@]@ } %s;@ @]@\n" s + | Cdecl_function (n, retty, args) -> + fprintf fmt "@[%a %s(@[%a@]);@ @]@\n" + pp_cty retty n pp_param_list args + +let pp_cdef fmt cdef = match cdef with + | Cfundef cfd -> + fprintf fmt + "@[@[%a %s(@[%a@]) {%a@]@ }@ @]@\n" + pp_cty cfd.f_retty cfd.f_name pp_param_list cfd.f_args + pp_cblock cfd.f_body + | Cvardef (s, cty) -> fprintf fmt "%a %s;@\n" pp_cty cty s + +let pp_cfile_desc fmt filen cfile = + (** [filen_wo_ext] is the file's name without the extension. *) + let filen_wo_ext = String.sub filen 0 (String.length filen - 2) in + match cfile with + | Cheader (deps, cdecls) -> + let headern_macro = String.uppercase filen_wo_ext in + Misc.print_header_info fmt "/*" "*/"; + fprintf fmt "#ifndef %s_H@\n" headern_macro; + fprintf fmt "#define %s_H@\n@\n" headern_macro; + (* fprintf fmt "#include \"types.h\"\n"; *) + iter (fun d -> fprintf fmt "#include \"%s.h\"@\n" d) + deps; + iter (pp_cdecl fmt) cdecls; + fprintf fmt "#endif // %s_H@\n" headern_macro + | Csource cdefs -> + let headern = filen_wo_ext ^ ".h" in + Misc.print_header_info fmt "/*" "*/"; + fprintf fmt "#include @\n"; + fprintf fmt "#include @\n"; + fprintf fmt "#include \"%s\"@\n@\n" headern; + fprintf fmt "#define FALSE 0@\n#define TRUE 1@\n@\n"; + iter (pp_cdef fmt) cdefs + +(******************************) + +(** [output_cfile dir cfile] pretty-prints the content of [cfile] to the + corresponding file in the [dir] directory. *) +let output_cfile dir (filen, cfile_desc) = + if !Misc.verbose then Printf.printf "C-NG generating %s/%s\n" dir filen; + let buf = Buffer.create 20000 in + let oc = open_out (Filename.concat dir filen) in + let fmt = Format.formatter_of_buffer buf in + pp_cfile_desc fmt filen cfile_desc; + Buffer.output_buffer oc buf; + close_out oc + +let output dir cprog = + List.iter (output_cfile dir) cprog + +(** { Lexical conversions to C's syntax } *) + +(** [cname_of_name name] translates the string [name] to a valid C identifier. + Copied verbatim from the old C backend. *) +let cname_of_name name = + let buf = Buffer.create (String.length name) in + let rec convert c = + match c with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> + Buffer.add_char buf c + | '\'' -> Buffer.add_string buf "_prime" + | _ -> + Buffer.add_string buf "lex"; + Buffer.add_string buf (string_of_int (Char.code c)); + Buffer.add_string buf "_" in + String.iter convert name; + Buffer.contents buf + +(** Converts an expression to a lhs. *) +let lhs_of_exp e = + match e with + | Clhs e -> e + | _ -> assert false + +(** Returns the type of a pointer to a type, except for + types which are already pointers. *) +let pointer_to ty = + match ty with + | Cty_arr _ | Cty_ptr _ -> ty + | _ -> Cty_ptr ty + +(** Returns whether a type is a pointer. *) +let is_pointer_type = function + | Cty_arr _ | Cty_ptr _ -> true + | _ -> false + +(** [array_base_ctype ty idx_list] returns the base type of an array + type. If idx_list = [i1; ..; ip] and a is a variable of type ty, + then it returns a[i1]..[ip]. *) +let rec array_base_ctype ty idx_list = + match ty, idx_list with + | Cty_arr (n, ty), [i] -> ty + | Cty_arr (n, ty), i::idx_list -> array_base_ctype ty idx_list + | _ -> assert false diff --git a/minils/sequential/c.mli b/minils/sequential/c.mli new file mode 100644 index 0000000..6161601 --- /dev/null +++ b/minils/sequential/c.mli @@ -0,0 +1,131 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id$ *) + +(** Abstract syntax tree for C programs. *) +(** {2 C abstract syntax tree } *) + +(** Here is the C abstract syntax tree used by MiniLS for its C backend. It does + not try to completly model the C language, only the relatively small part + that were are interested in (e.g. no function pointers or local variable + initialization). *) + +(** C types relevant for Obc. Note the absence of function pointers. *) +type cty = + | Cty_int (** C machine-dependent integer type. *) + | Cty_float (** C machine-dependent single-precision floating-point type. *) + | Cty_char (** C character type. *) + | Cty_id of string (** Previously defined C type, such as an enum or struct. *) + | Cty_ptr of cty (** C points-to-other-type type. *) + | Cty_arr of int * cty (** A static array of the specified size. *) + | Cty_void (** Well, [void] is not really a C type. *) + +(** A C block: declarations and statements. In source code form, it begins with + variable declarations before a list of semicolon-separated statements, the + whole thing being enclosed in curly braces. *) +type cblock = { + (** Variable declarations, where each declaration consists of a variable + name and the associated C type. *) + var_decls : (string * cty) list; + (** The actual statement forming our block. *) + block_body : cstm list; +} + +(** C expressions. *) +and cexpr = + | Cuop of string * cexpr (** Unary operator with its name. *) + | Cbop of string * cexpr * cexpr (** Binary operator. *) + | Cfun_call of string * cexpr list (** Function call with its parameters. *) + | Cconst of cconst (** Constants. *) + | Clhs of clhs (** Left-hand-side expressions are obviously expressions! *) + | Caddrof of clhs (** Take the address of a left-hand-side expression. *) + | Cstructlit of string * cexpr list (** Structure literal " \{f1, f2, ... \}". *) + | Carraylit of cexpr list (** Array literal [e1, e2, ...]. *) +and cconst = + | Ccint of int (** Integer constant. *) + | Ccfloat of float (** Floating-point number constant. *) + | Ctag of string (** Tag, member of a previously declared enumeration. *) + | Cstrlit of string (** String literal, enclosed in double-quotes. *) +(** C left-hand-side (ie. affectable) expressions. *) +and clhs = + | Cvar of string (** A local variable. *) + | Cderef of clhs (** Pointer dereference, *ptr. *) + | Cfield of clhs * string (** Field access to left-hand-side. *) + | Carray of clhs * cexpr (** Array access clhs[cexpr] *) +(** C statements. *) +and cstm = + | Csexpr of cexpr (** Expression evaluation, may cause side-effects! *) + | Csblock of cblock (** A local sub-block, can have its own private decls. **) + | Cskip (** A dummy instruction that does nothing and will not be printed. *) + | Caffect of clhs * cexpr (** Affect the result of an expression to a lhs. *) + | Cif of cexpr * cstm list * cstm list (** Alternative *) + | Cswitch of cexpr * (string * cstm list) list (** Case/switch over an enum. *) + | Cwhile of cexpr * cstm list (** While loop. *) + | Cfor of string * int * int * cstm list (** For loop. int <= string < int *) + | Creturn of cexpr (** Ends a procedure/function by returning an expression.*) + +(** C type declarations ; will {b always} correspond to a typedef in emitted + source code. *) +type cdecl = + (** C enum declaration, with associated value tags. *) + | Cdecl_enum of string * string list + (** C structure declaration, with each field's name and type. *) + | Cdecl_struct of string * (string * cty) list + (** C function declaration. *) + | Cdecl_function of string * cty * (string * cty) list + +(** C function definition *) +type cfundef = { + f_name : string; (** The function's name. *) + f_retty : cty; (** The function's return type. *) + f_args : (string * cty) list; (** Each parameter's name and type. *) + f_body : cblock; (** Actual instructions, in the form of a block. *) +} + +(** C top-level definitions. *) +type cdef = + | Cfundef of cfundef (** Function definition, see [cfundef]. *) + | Cvardef of string * cty (** A variable definition, with its name and type. *) + +val cdecl_of_cfundef : cdef -> cdecl + +(** A C file can be a source file, containing definitions, or a header file, + containing declarations. *) +type cfile_desc = + | Cheader of string list * cdecl list (** Header dependencies * declaration + list *) + | Csource of cdef list + +type cfile = string * cfile_desc (** File name * file content *) + +(** [output dir cprog] pretty-prints the C program [cprog] to new files in the + directory [dir]. *) +val output : string -> cfile list -> unit + +(** [cname_of_name name] translates the string [name] to a valid C identifier. + Copied verbatim from the old C backend. *) +val cname_of_name : string -> string + +(** Converts an expression to a lhs. *) +val lhs_of_exp : cexpr -> clhs + +(** Returns the type of a pointer to a type, except for + types which are already pointers. *) +val pointer_to : cty -> cty + +(** Returns whether a type is a pointer. *) +val is_pointer_type : cty -> bool + +(** [array_base_ctype ty idx_list] returns the base type of an array + type. If idx_list = [i1; ..; ip] and a is a variable of type ty, + then it returns a[i1]..[ip]. *) +val array_base_ctype : cty -> int list -> cty + + diff --git a/minils/sequential/cgen.ml b/minils/sequential/cgen.ml new file mode 100644 index 0000000..b0b0a21 --- /dev/null +++ b/minils/sequential/cgen.ml @@ -0,0 +1,1008 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id$ *) + +open Format +open List +open Misc +open Names +open Ident +open Obc +open Modules +open Global +open C +open Location +open Printf + +module Error = +struct + type error = + | Evar of string + | Enode of string + | Eno_unnamed_output + + let message loc kind = + begin match kind with + | Evar name -> + eprintf "%aCode generation : The variable name '%s' is unbound.\n" + output_location loc + name + | Enode name -> + eprintf "%aCode generation : The node name '%s' is unbound.\n" + output_location loc + name + | Eno_unnamed_output -> + eprintf "%aCode generation : Unnamed outputs are not supported. \n" + output_location loc + end; + raise Misc.Error +end + +let struct_name = function + | Heptagon.Tid n -> n + | _ -> assert false + +let cname_of_name' name = match name with + | Name n -> Name (cname_of_name n) + | _ -> name + +let rec print_list ff print sep l = + match l with + | [] -> () + | [x] -> print ff x + | x :: l -> + print ff x; + fprintf ff "%s@ " sep; + print_list ff print sep l + +(* Function to deal with opened modules set. *) +type world = { mutable opened_modules : S.t } +let world = { opened_modules = S.empty } + +let add_opened_module (m:string) = + world.opened_modules <- S.add (String.uncapitalize (cname_of_name m)) world.opened_modules +let get_opened_modules () = + S.elements world.opened_modules +let remove_opened_module (m:string) = + world.opened_modules <- S.remove m world.opened_modules +let reset_opened_modules () = + world.opened_modules <- S.empty + +let shortname = function + | Name(n) -> n + | Modname(q) -> + if q.qual <> "Pervasives" then + add_opened_module q.qual; + q.id + +(** Returns the information concerning a node given by name. *) +let node_info classln = + match classln with + | Modname {qual = modname; id = modname_name } -> + begin try + modname, find_value (Modname({qual = modname; + id = modname_name })) + with Not_found -> + (* name might be of the form Module.name, remove the module name*) + let ind_name = (String.length modname) + 1 in + let name = String.sub modname_name ind_name + ((String.length modname_name)-ind_name) in + begin try + modname, find_value (Modname({qual = modname; + id = name })) + with Not_found -> + Error.message no_location (Error.Enode name) + end + end + | Name n -> + Error.message no_location (Error.Enode n) + +let output_names_list sig_info = + let remove_option ad = match ad.a_name with + | Some n -> n + | None -> Error.message no_location Error.Eno_unnamed_output + in + List.map remove_option sig_info.info.outputs + +(******************************) + +(** {2 Translation from Obc to C using our AST.} *) + +(** [fold_stm_list] is an utility function that transforms a list of statements + into one statements using Cseq constructors. *) + +(** [ctype_of_type mods oty] translates the Obc type [oty] to a C + type. We assume that identified types have already been defined + before use. [mods] is an accumulator for modules to be opened for + each function (i.e., not opened by an "open" declaration). + We have to make a difference between function args and local vars + because of arrays (when used as args, we use a pointer). +*) +let rec ctype_of_otype oty = + match oty with + | Tint -> Cty_int + | Tfloat -> Cty_float + | Tid id -> + begin match shortname id with + (* standard C practice: use int as boolean type. *) + | "bool" -> Cty_int + | "int" -> Cty_int + | "float" -> Cty_float + | id -> Cty_id id + end + | Tarray(ty, n) -> + Cty_arr(n, ctype_of_otype ty) + +let ctype_of_heptty ty = + let ty = Merge.translate_btype ty in + let ty = Translate.translate_base_type NamesEnv.empty ty in + ctype_of_otype ty + +let cvarlist_of_ovarlist vl = + let cvar_of_ovar vd = + let ty = ctype_of_otype vd.v_type in + let ty = if vd.v_pass_by_ref then pointer_to ty else ty in + name vd.v_name, ty + in + List.map cvar_of_ovar vl + +let copname = function + | "=" -> "==" | "<>" -> "!=" | "&" -> "&&" | "or" -> "||" | "+" -> "+" + | "-" -> "-" | "*" -> "*" | "/" -> "/" | "*." -> "*" | "/." -> "/" + | "+." -> "+" | "-." -> "-" | "<" -> "<" | ">" -> ">" | "<=" -> "<=" + | ">=" -> ">=" + | "~-" -> "-" | "not" -> "!" + | op -> op + +(** Translates an Obc var_dec to a tuple (name, cty). *) +let cvar_of_vd vd = + name vd.v_name, ctype_of_otype vd.v_type + +(** If idx_list = [e1;..;ep], returns the lhs e[e1]...[ep] *) +let rec csubscript_of_e_list e idx_list = + match idx_list with + | [] -> e + | idx::idx_list -> + Carray (csubscript_of_e_list e idx_list, idx) + +(** If idx_list = [i1;..;ip], returns the lhs e[i1]...[ip] *) +let csubscript_of_idx_list e idx_list = + csubscript_of_e_list e (List.map (fun i -> Cconst (Ccint i)) idx_list) + +(** Creates the expression that checks that the indices + in idx_list are in the bounds. If idx_list=[e1;..;ep] + and bounds = [n1;..;np], it returns + e1 <= n1 && .. && ep <= np *) +let rec bound_check_expr idx_list bounds = + match idx_list, bounds with + | [idx], [n] -> + Cbop ("<", idx, Cconst (Ccint n)) + | idx::idx_list, n::bounds -> + Cbop ("&", Cbop ("<", idx, Cconst (Ccint n)), + bound_check_expr idx_list bounds) + | _, _ -> assert false + +(** Generate the expression to copy [src] into [dest], where bounds + represents the bounds of these two arrays. *) +let rec copy_array src dest bounds = + match bounds with + | [] -> [Caffect (dest, Clhs src)] + | n::bounds -> + let x = gen_symbol () in + [Cfor(x, 0, n, + copy_array (Carray (src, Clhs (Cvar x))) + (Carray (dest, Clhs (Cvar x))) bounds)] + +(** Returns the type associated with the name [n] + in the environnement [var_env] (which is an association list + mapping strings to cty). *) +let rec assoc_type n var_env = + match var_env with + | [] -> Error.message no_location (Error.Evar n) + | (vn,ty)::var_env -> + if vn = n then + ty + else + assoc_type n var_env + +(** Returns the type associated with the lhs [lhs] + in the environnement [var_env] (which is an association list + mapping strings to cty).*) +let rec assoc_type_lhs lhs var_env = + match lhs with + | Cvar x -> assoc_type x var_env + | Carray (lhs, idx) -> + let ty = assoc_type_lhs lhs var_env in + array_base_ctype ty [1] + | Cderef lhs -> assoc_type_lhs lhs var_env + | Cfield(Cderef (Cvar "self"), x) -> assoc_type x var_env + | Cfield(x, f) -> + let ty = assoc_type_lhs x var_env in + let { info = { arg = ty_arg; } } = find_field (longname f) in + let n = struct_name ty_arg in + let { info = { fields = fields } } = find_struct n in + ctype_of_heptty (List.assoc f fields) + | _ -> Cty_int (*TODO: add more cases*) + +(** Creates the expression dest <- src (copying arrays if necessary). *) +let rec create_affect_stm dest src ty = + match ty with + | Cty_arr (n, bty) -> + let src = lhs_of_exp src in + let x = gen_symbol () in + [Cfor(x, 0, n, + create_affect_stm (Carray (dest, Clhs (Cvar x))) + (Clhs (Carray (src, Clhs (Cvar x)))) bty)] + | _ -> [Caffect (dest, src)] + +(** Returns the expression to use e as an argument of + a function expecting a pointer as argument. *) +let address_of e = + try + let lhs = lhs_of_exp e in + match lhs with + | Carray _ -> Clhs lhs + | Cderef lhs -> Clhs lhs + | _ -> Caddrof lhs + with _ -> + e + +(** [cexpr_of_exp exp] translates the Obj action [exp] to a C expression. *) +let rec cexpr_of_exp var_env exp = + match exp with + (** Obj expressions that form valid C lhs are translated via clhs_of_exp. *) + | Lhs _ | Array_select _ -> + Clhs (clhs_of_exp var_env exp) + (** Constants, the easiest translation. *) + | Const lit -> + begin match lit with + | Cint i -> Cconst (Ccint i) + | Cfloat f -> Cconst (Ccfloat f) + | Cconstr c -> Cconst (Ctag (shortname c)) + | Cconst_array(n,c) -> + let cc = cexpr_of_exp var_env (Const c) in + Carraylit (repeat_list cc n) + end + (** Operators *) + | Op(op, exps) -> + cop_of_op var_env op exps + (** Structure literals. *) + | Struct (tyn, fl) -> + let cexps = List.map (fun (_,e) -> cexpr_of_exp var_env e) fl in + let ctyn = shortname tyn in + Cstructlit (ctyn, cexps) + | Array e_list -> + Carraylit (cexprs_of_exps var_env e_list) + +and cexprs_of_exps var_env exps = + List.map (cexpr_of_exp var_env) exps + +and cop_of_op_aux var_env op_name cexps = + match op_name with + | Modname { qual = "Pervasives"; id = op } -> + begin match op,cexps with + | "~-", [e] -> Cuop ("-", e) + | "not", [e] -> Cuop ("!", e) + | ( + "=" | "<>" + | "&" | "or" + | "+" | "-" | "*" | "/" + | "*." | "/." | "+." | "-." + | "<" | ">" | "<=" | ">="), [el;er] -> + Cbop (copname op, el, er) + | _ -> Cfun_call(op, cexps) + end + | Modname {qual = m; id = op} -> + add_opened_module m; + Cfun_call(op,cexps) + | Name(op) -> + Cfun_call(op,cexps) + +and cop_of_op var_env op_name exps = + let cexps = cexprs_of_exps var_env exps in + cop_of_op_aux var_env op_name cexps + +and clhs_of_lhs var_env = function + (** Each Obc variable corresponds to a real local C variable. *) + | Var v -> + let n = name v in + let ty = assoc_type n var_env in + (match ty with + | Cty_ptr _ -> Cderef (Cvar n) + | _ -> Cvar n + ) + (** Dereference our [self] struct holding the node's memory. *) + | Mem v -> Cfield (Cderef (Cvar "self"), name v) + (** Field access. /!\ Indexed Obj expression should be a valid lhs! *) + | Field (l, fn) -> Cfield(clhs_of_lhs var_env l, shortname fn) + | Array (l, idx) -> + Carray(clhs_of_lhs var_env e, cexpr_of_exp var_env idx) + +and clhss_of_lhss var_env lhss = + List.map (clhs_of_lhs var_env) lhss + +and clhs_of_exp var_env exp = match exp with + | Lhs l -> clhs_of_lhs var_env l + (** We were passed an expression that is not translatable to a valid C lhs?! *) + | _ -> invalid_arg "clhs_of_exp: argument not a Var, Mem or Field" + +let rec assoc_obj instance obj_env = + match obj_env with + | [] -> raise Not_found + | od :: t -> + if od.obj = instance + then od + else assoc_obj instance t + +let assoc_cn instance obj_env = + (assoc_obj instance obj_env).cls + +let is_op = function + | Modname { qual = "Pervasives"; id = _ } -> true + | _ -> false + +(** Creates the list of arguments to call a node. [targeting] is the targeting of + the called node, [mem] represents the node context and [args] the argument list.*) +let step_fun_call sig_info args mem = + let rec add_targeting i l ads = + match l, ads with + | [] ,[] -> [] + | e::l, ad::ads -> + let e = + if ad.a_pass_by_ref then + (*this arg is targeted, use a pointer*) + address_of e + else + e + in + e::(add_targeting (i+1) l ads) + | _ , _ -> assert false + in + (add_targeting 0 args sig_info.inputs)@[Caddrof mem] + +(** Generate the statement to call [objn]. + [outvl] is a list of lhs where to put the results. + [args] is the list of expressions to use as arguments. + [mem] is the lhs where is stored the node's context.*) +let generate_function_call var_env obj_env outvl objn args mem = + (** Class name for the object to step. *) + let classln = assoc_cn objn obj_env in + let classn = shortname classln in + let mod_classn, sig_info = node_info classln in + + let fun_call = + if is_op classln then + cop_of_op_aux var_env classln args + else + (** The step function takes scalar arguments and its own internal memory + holding structure. *) + let args = step_fun_call sig_info.info args mem in + (** Our C expression for the function call. *) + Cfun_call (classn ^ "_step", args) + in + + (** Act according to the length of our list. Step functions with + multiple return values will return a structure, and we care of + assigning each field to the corresponding local variable. *) + match outvl with + | [] -> [Csexpr fun_call] + | [vr] when Heptagon.is_scalar_type (List.hd sig_info.info.outputs).a_type -> + [Caffect (vr, fun_call)] + | _ -> + (* Remove options *) + let out_sig = output_names_list sig_info in + let create_affect outv out_name = + let ty = + match outv with + | Cvar x -> assoc_type x var_env + | Carray(Cvar x, _) -> array_base_ctype (assoc_type x var_env) [1] + | Carray(Cfield(Cderef (Cvar "self"), x), _) -> + array_base_ctype (assoc_type x var_env) [1] + | _ -> Cty_void (*we don't care about the type*) + in + create_affect_stm outv + (Clhs (Cfield (mem, + mod_classn ^ "_" ^ out_name))) ty in + (Csexpr fun_call)::(List.flatten (map2 create_affect outvl out_sig)) + +(** Create the statement dest = c where c = v^n^m... *) +let rec create_affect_const var_env dest c = + match c with + | Cconst_array(n,c) -> + let x = gen_symbol () in + [ Cfor(x, 0, n, + create_affect_const var_env (Carray (dest, Clhs (Cvar x))) c) ] + | _ -> [Caffect (dest, cexpr_of_exp var_env (Const c))] + +let create_field_update x r f v (n,ty) = + let ty = ctype_of_heptty ty in + if n = f then + create_affect_stm (Cfield(x,n)) v ty + else + create_affect_stm (Cfield(x, n)) (Clhs (Cfield(r,n))) ty + +(** [cstm_of_act obj_env mods act] translates the Obj action [act] to a list of C + statements, using the association list [obj_env] to map object names to class + names. *) +let rec cstm_of_act var_env obj_env act = + match act with + (** Case on boolean values are converted to if instead of switch! *) + | Case (c, [(Name "true", te); (Name "false", fe)]) + | Case (c, [(Name "false", fe); (Name "true", te)]) -> + let cc = cexpr_of_exp var_env c in + let cte = cstm_of_act var_env obj_env te in + let cfe = cstm_of_act var_env obj_env fe in + [Cif (cc, cte, cfe)] + (** Translation of case into a C switch statement is simple enough: we just + recursively translate obj expressions and statements to corresponding C + constructs, and cautiously "shortnamize" constructor names. *) + | Case (e, cl) -> + (** [ccl_of_obccl] translates an Obc clause to a C clause. *) + let ccl = + List.map (fun (c,act) -> shortname c, cstm_of_act var_env obj_env act) cl in + [Cswitch (cexpr_of_exp var_env e, ccl)] + (** For composition of statements, just recursively apply our translation + function on sub-statements. *) + | Comp (s1, s2) -> + let cstm1 = cstm_of_act var_env obj_env s1 in + let cstm2 = cstm_of_act var_env obj_env s2 in + cstm1@cstm2 + (** Reinitialization of an object variable, extracting the reset function's + name from our environment [obj_env]. *) + | Reinit on -> + let obj = assoc_obj on obj_env in + let classn = shortname obj.cls in + if obj.n = 1 then + [Csexpr (Cfun_call (classn ^ "_reset", + [Caddrof (Cfield (Cderef (Cvar "self"), on))]))] + else + let x = gen_symbol () in + let field = Cfield (Cderef (Cvar "self"), on) in + let elt = [Caddrof( Carray(field, Clhs (Cvar x)) )] in + [Cfor(x, 0, obj.n, + [Csexpr (Cfun_call (classn ^ "_reset", elt ))] )] + (** Special case for x = 0^n^n...*) + | Assgn (vn, Const c) -> + let vn = clhs_of_lhs var_env vn in + create_affect_const var_env vn c + (** Purely syntactic translation from an Obc local variable to a C local + one, with recursive translation of the rhs expression. *) + | Assgn (vn, e) -> + let vn = clhs_of_lhs var_env vn in + let ty = assoc_type_lhs vn var_env in + let ce = cexpr_of_exp var_env e in + create_affect_stm vn ce ty + (** Step functions applications can return multiple values, so we use a + local structure to hold the results, before allocating to our + variables. *) + | Step_ap (outvl, objn, el) -> + let args = cexprs_of_exps var_env el in + let outvl = clhss_of_lhss var_env outvl in + let mem = Cfield (Cderef (Cvar "self"), objn) in + generate_function_call var_env obj_env outvl objn args mem + + | Array_select_dyn (x, e, idx_list, bounds, defv) -> + let x = clhs_of_lhs var_env x in + let ty = assoc_type_lhs x var_env in + let e = cexpr_of_exp var_env e in + let cexps = cexprs_of_exps var_env idx_list in + let defv = cexpr_of_exp var_env defv in + let c = bound_check_expr cexps bounds in + [Cif (c, + create_affect_stm x + (Clhs (csubscript_of_e_list (lhs_of_exp e) cexps)) ty, + create_affect_stm x defv ty)] + + | Array_select_slice (x, e, idx1, idx2) -> + let x = clhs_of_lhs var_env x in + let ty = assoc_type_lhs x var_env in + let e = clhs_of_exp var_env e in + let y = gen_symbol () in + let index = Cbop ("+", Cconst (Ccint idx1), Clhs (Cvar y)) in + [Cfor(y, 0, idx2 - idx1 + 1, + create_affect_stm (Carray(x, index)) + (Clhs (Carray(e, Clhs (Cvar y)))) + (array_base_ctype ty [1]) )] + + | Array_iterate (outvl, Imap, f, n, e_list) -> + let x = gen_symbol () in + let cexps = cexprs_of_exps var_env e_list in + let cexps = List.map (fun e -> Clhs (Carray(lhs_of_exp e, Clhs (Cvar x)))) cexps in + let outvl = clhss_of_lhss var_env outvl in + let outvl = List.map (fun n -> Carray(n, Clhs (Cvar x))) outvl in + let mem = Carray (Cfield (Cderef (Cvar "self"), f), Clhs (Cvar x)) in + let fcall = generate_function_call var_env obj_env outvl f cexps mem in + [ Cfor (x, 0, n, fcall) ] + + | Array_iterate (outvl, Ifold, f, n, e_list) -> + let x = gen_symbol () in + let cexps = cexprs_of_exps var_env e_list in + (* Use the accumulator as the last arg *) + let cexps, acc_init = split_last cexps in + let cexps = List.map (fun e -> Clhs (Carray(lhs_of_exp e, Clhs (Cvar x)))) cexps in + let outvl = clhss_of_lhss var_env outvl in + let mem = Carray (Cfield (Cderef (Cvar "self"), f), Clhs (Cvar x)) in + (match outvl with + | [] -> + (* the accumulator is targeted, so it does not appear in the result. *) + let cexps = cexps@[acc_init] in + let fcall = generate_function_call var_env obj_env outvl f cexps mem in + [Cfor (x, 0, n, fcall) ] + | outvl -> + let cexps = cexps@[Clhs (List.hd outvl)] in + let fcall = generate_function_call var_env obj_env outvl f cexps mem in + let ty = assoc_type_lhs (List.hd outvl) var_env in + (create_affect_stm (List.hd outvl) acc_init ty) @ [Cfor (x, 0, n, fcall) ] + ) + + | Array_iterate (outvl, Imapfold, f, n, e_list) -> + let x = gen_symbol () in + let cexps = cexprs_of_exps var_env e_list in + (* Use the accumulator as the last arg *) + let cexps, acc_init = split_last cexps in + let cexps = List.map (fun e -> Clhs (Carray(lhs_of_exp e, Clhs (Cvar x)))) cexps in + let outvl = clhss_of_lhss var_env outvl in + let mem = Carray (Cfield (Cderef (Cvar "self"), f), Clhs (Cvar x)) in + + (* Check if the accumulator is targeted and does not appear in the output. *) + let _, sig_info = node_info (assoc_cn f obj_env) in + let acc_is_targeted = (is_empty outvl) + or (last_element sig_info.info.inputs).a_pass_by_ref in + if acc_is_targeted then ( + (* no accumulator in output *) + let outvl = List.map (fun e -> Carray(e, Clhs (Cvar x))) outvl in + let cexps = cexps@[acc_init] in + let fcall = generate_function_call var_env obj_env outvl f cexps mem in + [Cfor (x, 0, n, fcall) ] + ) else ( + (* use the last output as accumulator *) + let outvl = incomplete_map (fun e -> Carray(e, Clhs (Cvar x))) outvl in + let cexps = cexps@[(Clhs (last_element outvl))] in + let ty = assoc_type_lhs (last_element outvl) var_env in + let fcall = generate_function_call var_env obj_env outvl f cexps mem in + (create_affect_stm (last_element outvl) acc_init ty)@[Cfor (x, 0, n, fcall) ] + ) + + | Array_concat (x, e1, e2) -> + let x = clhs_of_lhs var_env x in + let e1 = clhs_of_exp var_env e1 in + let e2 = clhs_of_exp var_env e2 in + let ty1 = assoc_type_lhs e1 var_env in + let ty2 = assoc_type_lhs e2 var_env in + (match ty1, ty2 with + | Cty_arr(n1, t1), Cty_arr(n2, t2) -> + let y1 = gen_symbol () in + let y2 = gen_symbol () in + let index = Cbop ("+", Cconst (Ccint n1), Clhs (Cvar y2)) in + [Cfor(y1, 0, n1, + create_affect_stm (Carray(x, Clhs (Cvar y1))) + (Clhs (Carray(e1, Clhs (Cvar y1)))) + t1 ); + Cfor(y2, 0, n2, + create_affect_stm (Carray(x, index)) + (Clhs (Carray(e2, Clhs (Cvar y2)))) + t2 )] + | _, _ -> assert false + ) + + | Field_update(x, e1, f, e2) -> + (* Find the description of the struct type *) + let { info = { arg = ty_arg; res = ty_res } } = find_field f in + let n = struct_name ty_arg in + let { info = { fields = fields } } = find_struct n in + (* Translate exps *) + let f = shortname f in + let x = clhs_of_lhs var_env x in + let e1 = clhs_of_exp var_env e1 in + let e2 = cexpr_of_exp var_env e2 in + (* create the final exp*) + if x = e1 then ( (* only modify one field *) + let ty = ctype_of_heptty (List.assoc f fields) in + create_affect_stm (Cfield(x, f)) e2 ty + ) else + List.flatten (List.map (create_field_update x e1 f e2) fields) + + (** Well, Nothing translates to no instruction. *) + | Nothing -> [] + +(** [main_def_of_class_def cd] generated a main() function that repeatedly reads + data from standard input and then outputs result of [cd.step]. *) +(* TODO: refactor into something more readable. *) +let main_def_of_class_def cd = + (** Generates scanf statements, conversion to enums and declarations of + buffers needed for reading enum tags. *) + let scanf_and_vardecl_of_param vd = + let (formats, expr, need_buf) = match vd.v_type with + | Tint -> ("%d", Caddrof (Cvar (name vd.v_name)), None) + | Tid (Name "int"| Modname {qual="Pervasives";id="int"}) -> + ("%d", Caddrof (Cvar (name vd.v_name)), None) + | Tid (Name "bool"| Modname {qual="Pervasives";id="bool"}) -> + ("%d", Caddrof (Cvar (name vd.v_name)), None) + | Tfloat -> ("%f", Caddrof (Cvar (name vd.v_name)), None) + (* TODO: distinguish struct and enums AND switch to sscanf *) + | Tid ((Name sid) | + (Modname { id = sid })) -> ("%s", + Clhs (Cvar ((name vd.v_name) ^ "_buf")), + Some ((name vd.v_name) ^ "_buf", sid)) + | Tarray(ty, n) -> assert false + in + let scane = + let puts_arg = Printf.sprintf "%s ? " (name vd.v_name) in + Csblock { var_decls = []; + block_body = [Csexpr (Cfun_call ("printf", + [Cconst (Cstrlit puts_arg)])); + Csexpr (Cfun_call ("scanf", + [Cconst (Cstrlit formats); + expr]));]; } in + match need_buf with + | None -> ([scane], []) + | Some (bufn, tyn) -> ([scane; + Csexpr (Cfun_call (tyn ^ "_of_string", + [Clhs (Cvar bufn)]))], + [(bufn, Cty_arr (20, Cty_char))]) in + let (scanf_calls, scanf_decls) = + split (map scanf_and_vardecl_of_param cd.step.inp) in + (** Generates printf statements and buffer declarations needed for printing + resulting values of enum types. *) + let printf_and_vardecl_of_result f vd = + let (formats, expr, need_buf) = match vd.v_type with + | Tint -> ("%d", f vd.v_name, None) + | Tfloat -> ("%f", f vd.v_name, None) + | Tid (Name "bool"| Modname {qual="Pervasives"; id="bool"}) -> + ("%d", f vd.v_name, None) + | Tid (Name "int"| Modname {qual="Pervasives"; id="int"}) -> + ("%d", f vd.v_name, None) + | Tid (Name sid | Modname {id = sid}) -> + ("%s", Cfun_call ("string_of_" ^ sid, + [f vd.v_name; + Clhs (Cvar ((name vd.v_name) ^ "_buf"))]), Some (sid)) + | Tarray (ty, n) -> assert false + in + (Csexpr (Cfun_call ("printf", + [Cconst (Cstrlit ("=> " ^ formats ^ "\\t")); expr])), + match need_buf with + | None -> [] + | Some id -> [((name vd.v_name) ^ "_buf", Cty_arr (20, Cty_char))]) in + let (printf_calls, printf_decls) = + split (map (printf_and_vardecl_of_result + (fun n -> match cd.step.out with + | [vd] -> Clhs (Cvar "res") + | _ -> Clhs (Cfield (Cvar "res", name n)))) cd.step.out) in + let cinp = cvarlist_of_ovarlist cd.step.inp in + let cout = + begin match cd.step.out with + | [] -> [] + | [vd] -> [("res", ctype_of_otype vd.v_type)] + | _ -> [("res", Cty_id (cd.cl_id ^ "_res"))] + end in + let varlist = + ("mem", Cty_id (cd.cl_id ^ "_mem")) + :: cinp + @ cout + @ concat scanf_decls + @ concat printf_decls in + (** The main function loops (while (1) { ... }) reading arguments for our node + and prints the results. *) + let body = + let funcall = + let args = + map (fun vd -> Clhs (Cvar (name vd.v_name))) cd.step.inp + @ [Caddrof (Cvar ("mem"))] in + Cfun_call (cd.cl_id ^ "_step", args) in + concat scanf_calls + @ [Caffect (Cvar "res", funcall)] + @ printf_calls + @ [Csexpr (Cfun_call ("puts", [Cconst (Cstrlit "")])); + Csexpr (Cfun_call ("fflush", [Clhs (Cvar "stdout")]))] in + (** Do not forget to initialize memory via reset. *) + let init_mem = + Csexpr (Cfun_call (cd.cl_id ^ "_reset", [Caddrof (Cvar "mem")])) in + Cfundef { + f_name = "main"; + f_retty = Cty_int; + f_args = [("argc", Cty_int); ("argv", Cty_ptr (Cty_ptr Cty_char))]; + f_body = { + var_decls = varlist; + block_body = [init_mem; + Cwhile (Cconst (Ccint 1), body)]; + } + } + +(** Builds the argument list of step function*) +let step_fun_args n sf = + let args = cvarlist_of_ovarlist sf.inp in + args + @[("self", Cty_ptr (Cty_id (n ^ "_mem")))] + +(** [fun_def_of_step_fun name obj_env mods sf] returns a C function definition + [name ^ "_out"] corresponding to the Obc step function [sf]. The object name + <-> class name mapping [obj_env] is needed to translate internal steps and + reset calls. A step function can have multiple return values, whereas C does + not allow such functions. When it is the case, we declare a structure with a + field by return value. A scalar result is directly returned. *) +let fun_def_of_step_fun name obj_env mem sf = + let fun_name = name ^ "_step" in + (** Its arguments, translating Obc types to C types and adding our internal + memory structure. *) + let args = step_fun_args name sf in + (** Its normal local variables. *) + let local_vars = List.map cvar_of_vd sf.local in + (** Local variables containing return values. *) + let ret_vars = + if List.length sf.out = 1 && Obc.is_scalar_type (List.hd sf.out) then + List.map cvar_of_vd sf.out + else + [] + in + + (** Return type, depending on the number of return values of our function. *) + let retty = + match sf.out with + | [] -> Cty_void + | [v] -> + if Obc.is_scalar_type v then + ctype_of_otype v.v_type + else + Cty_void + | _ -> Cty_void in + (** Controllable variables valuations *) + let use_ctrlr, ctrlr_calls = + match sf.controllables with + | [] -> false, [] + | c_list -> + let args_inputs_state = + List.map (fun (arg_name,_) -> Clhs(Cvar(arg_name))) args in + let addr_controllables = + List.map (fun { v_name = c_name } -> Caddrof(Cvar(Ident.name c_name))) c_list in + let args_ctrlr = + args_inputs_state @ addr_controllables in + let funname = name ^ "_controller" in + let funcall = Cfun_call(funname,args_ctrlr) in + true, + [Csexpr(funcall)] in + (** The body *) + let mems = List.map cvar_of_vd (mem@sf.out) in + let var_env = args @ mems @ local_vars in + let body = cstm_of_act var_env obj_env sf.bd in + + (** Our epilogue: affect each local variable holding a return value to + the correct structure field. *) + let epilogue = match sf.out with + | [] -> [] + | [vd] when Obc.is_scalar_type (List.hd sf.out) -> + [Creturn (Clhs (Cvar (Ident.name vd.v_name)))] + | out -> [] in + + (** Substitute the return value variables with the corresponding + context field*) + let map = Csubst.assoc_map_for_fun sf in + let body = List.map (Csubst.subst_stm map) (body@epilogue) in + + use_ctrlr, + Cfundef { + f_name = fun_name; + f_retty = retty; + f_args = args; + f_body = { + var_decls = ret_vars @ local_vars; + block_body = ctrlr_calls @ body + } + } + +(** [mem_decl_of_class_def cd] returns a declaration for a C structure holding + internal variables and objects of the Obc class definition [cd]. *) +let mem_decl_of_class_def cd = + (** This one just translates the class name to a struct name following the + convention we described above. *) + let struct_field_of_obj_dec l od = + if is_op od.cls then + l + else + let clsname = shortname od.cls in + let ty = Cty_id ((cname_of_name clsname) ^ "_mem") in + let ty = if od.n <> 1 then Cty_arr (od.n, ty) else ty in + (od.obj, ty)::l + in + + (** Fields corresponding to normal memory variables. *) + let mem_fields = List.map cvar_of_vd cd.mem in + (** Fields corresponding to object variables. *) + let obj_fields = List.fold_left struct_field_of_obj_dec [] cd.objs in + (** Fields corresponding to output variables. *) + let out_fields = + if (List.length cd.step.out) <> 1 or + not (Obc.is_scalar_type (List.hd cd.step.out)) then + List.map cvar_of_vd cd.step.out + else + [] + in + Cdecl_struct (cd.cl_id ^ "_mem", mem_fields @ obj_fields @ out_fields) + +(** [reset_fun_def_of_class_def cd] returns the defintion of the C function + tasked to reset the class [cd]. *) +let reset_fun_def_of_class_def cd = + let var_env = List.map cvar_of_vd cd.mem in + let body = cstm_of_act var_env cd.objs cd.reset in + Cfundef { + f_name = (cd.cl_id ^ "_reset"); + f_retty = Cty_void; + f_args = [("self", Cty_ptr (Cty_id (cd.cl_id ^ "_mem")))]; + f_body = { + var_decls = []; + block_body = body; + } + } + +(** [cdecl_and_cfun_of_class_def cd] translates the class definition [cd] to + a C program. *) +let cdefs_and_cdecls_of_class_def cd = + (** We keep the state of our class in a structure, holding both internal + variables and the state of other nodes. For a class named ["cname"], the + structure will be called ["cname_mem"]. *) + let memory_struct_decl = mem_decl_of_class_def cd in + (** Our main() function will be generated only if the current class definition + corresponds to the simulation_node. *) + let main_def = match !simulation_node with + | Some nn when nn = cd.cl_id -> [main_def_of_class_def cd] + | _ -> [] in + let obj_env = + List.map (fun od -> { od with cls = cname_of_name' od.cls }) cd.objs in + let use_ctrlr,step_fun_def + = fun_def_of_step_fun cd.cl_id obj_env cd.mem cd.step in + (** C function for resetting our memory structure. *) + let reset_fun_def = reset_fun_def_of_class_def cd in + let res_fun_decl = cdecl_of_cfundef reset_fun_def in + let step_fun_decl = cdecl_of_cfundef step_fun_def in + memory_struct_decl, + use_ctrlr, + ([res_fun_decl;step_fun_decl], + reset_fun_def :: step_fun_def :: main_def) + +let decls_of_type_decl otd = + let name = otd.t_name in + match otd.t_desc with + | Type_abs -> [] (*assert false*) + | Type_enum nl -> + [Cdecl_enum (otd.t_name, nl); + Cdecl_function (name ^ "_of_string", + Cty_id name, + [("s", Cty_ptr Cty_char)]); + Cdecl_function ("string_of_" ^ name, + Cty_ptr Cty_char, + [("x", Cty_id name); ("buf", Cty_ptr Cty_char)])] + | Type_struct fl -> + let decls = List.map (fun (n,ty) -> n, ctype_of_otype ty) fl in + [Cdecl_struct (otd.t_name, decls)];; + +(** Translates an Obc type declaration to its C counterpart. *) +let cdefs_and_cdecls_of_type_decl otd = + let name = otd.t_name in + match otd.t_desc with + | Type_abs -> [], [] (*assert false*) + | Type_enum nl -> + let of_string_fun = Cfundef + { f_name = name ^ "_of_string"; + f_retty = Cty_id name; + f_args = [("s", Cty_ptr Cty_char)]; + f_body = + { var_decls = []; + block_body = + let gen_if t = + let funcall = Cfun_call ("strcmp", [Clhs (Cvar "s"); + Cconst (Cstrlit t)]) in + let cond = Cbop ("==", funcall, Cconst (Ccint 0)) in + Cif (cond, [Creturn (Cconst (Ctag t))], []) in + map gen_if nl; } + } + and to_string_fun = Cfundef + { f_name = "string_of_" ^ name; + f_retty = Cty_ptr Cty_char; + f_args = [("x", Cty_id name); ("buf", Cty_ptr Cty_char)]; + f_body = + { var_decls = []; + block_body = + let gen_clause t = + let fun_call = + Cfun_call ("strcpy", [Clhs (Cvar "buf"); + Cconst (Cstrlit t)]) in + (t, [Csexpr fun_call]) in + [Cswitch (Clhs (Cvar "x"), map gen_clause nl); + Creturn (Clhs (Cvar "buf"))]; } + } in + ([of_string_fun; to_string_fun], + [Cdecl_enum (otd.t_name, nl); cdecl_of_cfundef of_string_fun; + cdecl_of_cfundef to_string_fun]) + | Type_struct fl -> + let decls = List.map (fun (n,ty) -> n, ctype_of_otype ty) fl in + let decl = Cdecl_struct (otd.t_name, decls) in + ([], [decl]) + +(** [cfile_list_of_oprog oprog] translates the Obc program [oprog] to a list of + C source and header files. *) +let cfile_list_of_oprog name oprog = + let opened_modules = oprog.o_opened in + + let header_and_source_of_class_def (deps,acc_cfiles) cd = + reset_opened_modules (); + List.iter add_opened_module opened_modules; + List.iter add_opened_module deps; + + let cfile_name = String.uncapitalize cd.cl_id in + let mem_cdecl,use_ctrlr,(cdecls, cdefs) = cdefs_and_cdecls_of_class_def cd in + + let cfile_mem = cfile_name ^ "_mem" in + add_opened_module cfile_mem; + if use_ctrlr then + add_opened_module (cfile_name ^ "_controller"); + remove_opened_module name; + + let acc_cfiles = acc_cfiles @ + [ (cfile_mem ^ ".h", Cheader (get_opened_modules (),[mem_cdecl])); + (cfile_name ^ ".h", Cheader (get_opened_modules (), cdecls)); + (cfile_name ^ ".c", Csource cdefs)] in + deps@[cfile_name],acc_cfiles in + + reset_opened_modules (); + List.iter add_opened_module opened_modules; + let cdefs_and_cdecls = List.map cdefs_and_cdecls_of_type_decl oprog.o_types in + remove_opened_module name; + + let (cty_defs, cty_decls) = List.split (List.rev cdefs_and_cdecls) in + let filename_types = name ^ "_types" in + let types_h = (filename_types ^ ".h", + Cheader (get_opened_modules (), concat cty_decls)) in + let types_c = (filename_types ^ ".c", Csource (concat cty_defs)) in + let _,cfiles = + List.fold_left + header_and_source_of_class_def + ([filename_types],[types_h;types_c]) + oprog.o_defs in + cfiles + +let global_file_header name prog = + let step_fun_decl cd = + let _,s = fun_def_of_step_fun cd.cl_id cd.objs cd.mem cd.step in + cdecl_of_cfundef s + in + reset_opened_modules (); + List.iter add_opened_module prog.o_opened; + + let ty_decls = List.map decls_of_type_decl prog.o_types in + let ty_decls = List.concat ty_decls in + let mem_step_fun_decls = List.map mem_decl_of_class_def prog.o_defs in + let reset_fun_decls = + List.map (fun cd -> cdecl_of_cfundef (reset_fun_def_of_class_def cd)) prog.o_defs in + let step_fun_decls = List.map step_fun_decl prog.o_defs in + + (name ^ ".h", Cheader (get_opened_modules (), + ty_decls + @ mem_step_fun_decls + @ reset_fun_decls + @ step_fun_decls)) + +(******************************) + +let sanitize_identifier modname id = match id with + | "bool" -> "bool" | "int" -> "int" | "float" -> "float" + | "true" -> "true" | "false" -> "false" + | op -> modname ^ "_" ^ cname_of_name op + +let translate name prog = + let modname = (Filename.basename name) in + let prog = + Rename.rename_program (sanitize_identifier (String.capitalize modname)) prog in + begin match !simulation_node with + | None -> () + | Some s -> simulation_node := Some (String.capitalize name ^ "_" ^ s) + end; + let res = + (global_file_header modname prog) :: (cfile_list_of_oprog modname prog) in + if !Misc.verbose then Printf.printf "Translation into C code done.\n"; + res diff --git a/minils/sequential/control.ml b/minils/sequential/control.ml new file mode 100644 index 0000000..980612b --- /dev/null +++ b/minils/sequential/control.ml @@ -0,0 +1,81 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* control optimisation *) + +(* $Id$ *) + +open Minils +open Ident +open Misc + +let var_from_name map x = + begin try + Env.find x map + with + _ -> assert false + end + +let rec find c = function + | [] -> raise Not_found + | (c1, s1) :: h -> + if c = c1 then s1, h else let s, h = find c h in s, (c1, s1) :: h + +let rec control map ck s = + match ck with + | Cbase | Cvar { contents = Cindex _ } -> s + | Cvar { contents = Clink ck } -> control map ck s + | Con(ck, c, n) -> + let e = var_from_name map n in + control map ck (Obc.Case(Obc.Lhs e, [(c, s)])) + +let rec simplify act = + match act with + | Obc.Assgn (lhs, e) -> + (match e with + | Obc.Lhs l when l = lhs -> Obc.Nothing + | _ -> act + ) + | Obc.Case(lhs, h) -> + (match simplify_handlers h with + | [] -> Obc.Nothing + | h -> Obc.Case(lhs, h) + ) + | _ -> act + +and simplify_handlers = function + | [] -> [] + | (n,a)::h -> + let h = simplify_handlers h in + (match simplify a with + | Obc.Nothing -> h + | a -> (n,a)::h + ) + +let rec join s1 s2 = + match simplify s1, simplify s2 with + | Obc.Case(Obc.Lhs(n), h1), Obc.Case(Obc.Lhs(m), h2) when n = m -> + Obc.Case(Obc.Lhs(n), joinhandlers h1 h2) + | s1, Obc.Nothing -> s1 + | Obc.Nothing, s2 -> s2 + | s1, Obc.Comp(s2, s3) -> Obc.Comp(join s1 s2, s3) + | s1, s2 -> Obc.Comp(s1, s2) + +and joinhandlers h1 h2 = + match h1 with + | [] -> h2 + | (c1, s1) :: h1' -> + let s1', h2' = + try let s2, h2'' = find c1 h2 in join s1 s2, h2'' + with Not_found -> simplify s1, h2 in + (c1, s1') :: joinhandlers h1' h2' + +let rec joinlist = function + | [] -> Obc.Nothing + | s :: l -> join s (joinlist l) diff --git a/minils/sequential/csubst.ml b/minils/sequential/csubst.ml new file mode 100644 index 0000000..775be3c --- /dev/null +++ b/minils/sequential/csubst.ml @@ -0,0 +1,65 @@ +open C +open Obc +open Ident +open Names + +let rec subst_stm map stm = + match stm with + | Csexpr e -> Csexpr (subst_exp map e) + | Cskip -> Cskip + | Creturn e -> Creturn (subst_exp map e) + | Csblock cblock -> + Csblock (subst_block map cblock) + | Caffect (lhs, e) -> + Caffect(subst_lhs map lhs, subst_exp map e) + | Cif (e, truel, falsel) -> + Cif (subst_exp map e, subst_stm_list map truel, + subst_stm_list map falsel) + | Cswitch (e, l) -> + Cswitch (subst_exp map e, List.map (fun (s, sl) -> s, subst_stm_list map sl) l) + | Cwhile (e, l) -> + Cwhile (subst_exp map e, subst_stm_list map l) + | Cfor (x, i1, i2, l) -> + Cfor (x, i1, i2, subst_stm_list map l) + +and subst_stm_list map = + List.map (subst_stm map) + +and subst_lhs map lhs = + match lhs with + | Cvar n -> + if NamesEnv.mem n map then + NamesEnv.find n map + else + lhs + | Cfield (lhs, s) -> Cfield (subst_lhs map lhs, s) + | Carray (lhs, n) -> Carray (subst_lhs map lhs, n) + | Cderef lhs -> Cderef (subst_lhs map lhs) + +and subst_exp map = function + | Cuop (op, e) -> Cuop (op, subst_exp map e) + | Cbop (s, l, r) -> Cbop (s, subst_exp map l, subst_exp map r) + | Cfun_call (s, el) -> Cfun_call (s, subst_exp_list map el) + | Cconst x -> Cconst x + | Clhs lhs -> Clhs (subst_lhs map lhs) + | Caddrof lhs -> Caddrof (subst_lhs map lhs) + | Cstructlit (s, el) -> Cstructlit (s, subst_exp_list map el) + | Carraylit el -> Carraylit (subst_exp_list map el) + +and subst_exp_list map = + List.map (subst_exp map) + +and subst_block map b = + {b with block_body = subst_stm_list map b.block_body} + +let assoc_map_for_fun sf = + match sf.out with + | [] -> NamesEnv.empty + | [vd] when Obc.is_scalar_type (List.hd sf.out) -> + NamesEnv.empty + | out -> + let fill_field map vd = + NamesEnv.add (name vd.v_name) (Cfield (Cderef (Cvar "self"), name vd.v_name)) map + in + List.fold_left fill_field NamesEnv.empty out + diff --git a/minils/sequential/java.ml b/minils/sequential/java.ml new file mode 100644 index 0000000..9a540c0 --- /dev/null +++ b/minils/sequential/java.ml @@ -0,0 +1,596 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* $Id$ *) + +open Global +open Modules +open Format +open Obc +open Misc +open Names +open Ident + +let actual_type ty = + match ty with + | Tid(tn) when (shortname tn) = "float" -> Tfloat + | Tid(tn) when (shortname tn) = "int" -> Tint + | _ -> ty + +(******************************) +let rec print_list ff print sep l = + match l with + | [] -> () + | [x] -> print ff x + | x :: l -> + print ff x; + fprintf ff "%s@ " sep; + print_list ff print sep l + +let jname_of_name name = + let b = Buffer.create (String.length name) in + let rec convert c = + match c with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> + Buffer.add_char b c + | '\'' -> Buffer.add_string b "_prime" + | _ -> + Buffer.add_string b "lex"; + Buffer.add_string b (string_of_int (Char.code c)); + Buffer.add_string b "_" in + + String.iter convert name; + Buffer.contents b + +let print_name ff name = + fprintf ff "%s" (jname_of_name name) + +let print_shortname ff longname = + print_name ff (shortname longname) + +let o_types : type_dec list ref = ref [] + +let java_type_default_value = function + | Tint -> "int", "0" + | Tfloat -> "float", "0.0" + | Tid (Name("bool")) + | Tid (Modname({ id = "bool" })) -> + "boolean", "false" + | Tid t when ((shortname t) = "int") -> "int", "0" + | Tid t when ((shortname t) = "float") -> "float", "0.0" + | Tid t -> + begin try + let { info = ty_desc } = find_type (t) in + begin match ty_desc with + | Tenum _ -> + "int", "0" + | _ -> + let t = shortname t in + if t = "bool" + then ("boolean", "false") + else (t, "null") + end + with Not_found -> + begin try + let { t_desc = tdesc } = + List.find (fun {t_name = tn} -> tn = (shortname t)) !o_types in + begin match tdesc with + | Type_enum _ -> + "int", "0" + | _ -> + let t = shortname t in + if t = "bool" + then ("boolean", "false") + else (t, "null") + end + with Not_found -> + let t = shortname t in + if t = "bool" + then ("boolean", "false") + else (t, "null") + end + end + +let print_type ff ty = + let jty,_ = java_type_default_value ty in + print_name ff jty + +let print_field ff (name,ty) = + fprintf ff "%a %a;" + print_type ty + print_name name + +let print_const_field ff (name,ty) = + fprintf ff "%a@ %a" + print_type ty + print_name name + +let print_assgt_field ff (name,_) = + fprintf ff "this.%a = %a;" + print_name name + print_name name + +(* assumes tn is already translated with jname_of_name *) +let print_struct_type ff tn fields = + fprintf ff "@[@[public class %s {@ " tn; + (* fields *) + print_list ff print_field "" fields; + (* constructor *) + let sorted_fields = + List.sort + (fun (n1,_) (n2,_) -> String.compare n1 n2) + fields in + fprintf ff "@ @[public %s(@[" tn; + print_list ff print_const_field "," sorted_fields; + fprintf ff "@]) {@ "; + (* constructor assignments *) + print_list ff print_assgt_field "" fields; + (* constructor end *) + fprintf ff "@]@ }"; + (* class end *) + fprintf ff "@]@ }@]" + + +let rec print_tags ff n = function + | [] -> () + | tg :: tgs' -> + fprintf ff "@ public static final int %a = %d;" + print_name tg + n; + print_tags ff (n+1) tgs' + +(* assumes tn is already translated with jname_of_name *) +let print_enum_type ff tn tgs = + fprintf ff "@[@[public class %s {" tn; + print_tags ff 1 tgs; + fprintf ff "@]@ }@]" + +let print_type_to_file java_dir headers { t_name = tn; t_desc = td} = + let tn = jname_of_name tn in + match td with + | Type_abs -> () + | Type_enum tgs -> + let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in + let ff = formatter_of_out_channel out_ch in + Misc.print_header_info ff "/*" "*/"; + List.iter (fprintf ff "%s") headers; + (* fprintf ff "@[package %s;@\n@\n" headers; *) + print_enum_type ff tn tgs; + fprintf ff "@."; + close_out out_ch + | Type_struct fields -> + let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in + let ff = formatter_of_out_channel out_ch in + Misc.print_header_info ff "/*" "*/"; + List.iter (fprintf ff "%s") headers; + (* fprintf ff "@[package %s;@\n@\n" headers; *) + print_struct_type ff tn fields; + fprintf ff "@."; + close_out out_ch + +let print_types java_dir headers tps = + List.iter (print_type_to_file java_dir headers) tps + +(******************************) + +type answer = + | Sing of var_name + | Mult of var_name list + +let print_const ff c ts = + match c with + | Cint i -> fprintf ff "%d" i + | Cfloat f -> fprintf ff "%f" f + | Cconstr t -> + let s = + match t with + | Name("true") + | Modname({id = "true"}) -> "true" + | Name("false") + | Modname({id = "false"}) -> "false" + | Name(tg) + | Modname({id = tg}) -> + (fst + (List.find + (fun (tn, tgs) -> + List.exists (fun tg' -> tg = tg') tgs) + ts)) + ^ "." ^ (jname_of_name tg) + in + fprintf ff "%s" s + +let position a xs = + let rec walk i = function + | [] -> None + | x :: xs' -> if x = a then Some i else walk (i + 1) xs' + in walk 1 xs + +let print_ident ff id = + print_name ff (name id) + +let print_var ff x avs single = + match (position x avs) with + | None -> print_ident ff x + | Some n -> + if single then print_ident ff (List.hd avs) + else fprintf ff "step_ans.c_%d" n + +let javaop_of_op = function + | "=" -> "==" + | "<>" -> "!=" + | "or" -> "||" + | "&" -> "&&" + | "*." -> "*" + | "/." -> "/" + | "+." -> "+" + | "-." -> "-" + | op -> op + +let priority = function + | "*" | "/" | "*." | "/." -> 5 + | "+" | "-" | "+." | "-." -> 4 + | "=" | "<>" | "<=" | "=>" -> 3 + | "&" -> 2 + | "|" -> 1 + | _ -> 0 + +let rec print_lhs ff e avs single = + match e with + | Var x -> + print_var ff x avs single + | Mem x -> print_ident ff x + | Field(e, field) -> + print_lhs ff e avs single; + fprintf ff ".%s" (jname_of_name (shortname field)) + +let rec print_exp ff e p avs ts single = + match e with + | Lhs l -> print_lhs ff l avs single + | Const c -> print_const ff c ts + | Op (op, es) -> print_op ff op es p avs ts single + | Struct(type_name,fields) -> + let fields = + List.sort + (fun (ln1,_) (ln2,_) -> String.compare (shortname ln1) (shortname ln2)) + fields in + let exps = List.map (fun (_,e) -> e) fields in + fprintf ff "new %a(@[" + print_shortname type_name; + print_exps ff exps 0 avs ts single; + fprintf ff "@])" + +and print_exps ff es p avs ts single = + match es with + | [] -> () + | [e] -> print_exp ff e p avs ts single + | e :: es' -> + print_exp ff e p avs ts single; + fprintf ff ",@ "; + print_exps ff es' p avs ts single + +and print_op ff op es p avs ts single = + match (shortname op), es with + | (("+" | "-" | "*" | "/" + |"+." | "-." | "*." | "/." + | "=" | "<>" | "<" | "<=" + | ">" | ">=" | "&" | "or") as op_name, [e1;e2]) -> + let p' = priority op_name in + if p' < p then fprintf ff "(" else (); + print_exp ff e1 p' avs ts single; + fprintf ff " %s " (javaop_of_op op_name); + print_exp ff e2 p' avs ts single; + if p' < p then fprintf ff ")" else () + | "not", [e] -> + fprintf ff "!"; + print_exp ff e 6 avs ts single; + | "~-", [e] -> + fprintf ff "-"; + print_exp ff e 6 avs ts single; + | _ -> + begin + begin + match op with + | Name(op_name) -> + print_name ff op_name; + | Modname({ qual = mod_name; id = op_name }) -> + fprintf ff "%a.%a" + print_name (String.uncapitalize mod_name) + print_name op_name + end; + fprintf ff "@[("; + print_exps ff es 0 avs ts single; + fprintf ff ")@]" + end + +let rec print_proj ff xs ao avs single = + let rec walk ind = function + | [] -> () + | x :: xs' -> + print_lhs ff x avs single; + fprintf ff " = %s.c_%d;@ " ao ind; + walk (ind + 1) xs' + in walk 1 xs + + +let bool_case = function + | [] -> assert false + | ("true", _) :: _ + | ("false", _) :: _ -> true + | _ -> false + +let rec print_act ff a objs avs ts single = + match a with + | Assgn (x, e) -> + fprintf ff "@["; + print_asgn ff x e avs ts single; + fprintf ff ";@]" + | Step_ap (xs, o, es) -> + (match xs with + | [x] -> + print_lhs ff x avs single; + fprintf ff " = %s.step(" o; + fprintf ff "@["; + print_exps ff es 0 avs ts single; + fprintf ff "@]"; + fprintf ff ");@ " + | xs -> + let cn = (List.find (fun od -> od.obj = o) objs).cls in + let at = (jname_of_name (shortname cn)) ^ "Answer" in + let ao = o ^ "_ans" in + fprintf ff "%s %s = new %s();@ " at ao at; + fprintf ff "%s = %s.step(" ao o; + fprintf ff "@["; + print_exps ff es 0 avs ts single; + fprintf ff "@]"; + fprintf ff ");@ "; + print_proj ff xs ao avs single) + | Comp (a1, a2) -> + print_act ff a1 objs avs ts single; + (match a2 with + | Nothing -> () + | _ -> fprintf ff "@ "); + print_act ff a2 objs avs ts single + | Case (e, grds) -> + let grds = + List.map + (fun (ln,act) -> (shortname ln),act) grds in + if bool_case grds + then print_if ff e grds objs avs ts single + else (fprintf ff "@[@[switch (%a) {@ " + (fun ff e -> print_exp ff e 0 avs ts single) e; + print_grds ff grds objs avs ts single; + fprintf ff "@]@ }@]"); + | Reinit o -> fprintf ff "%s.reset();" o + | Nothing -> () + +and print_grds ff grds objs avs ts single = + match grds with + | [] -> () + | [(tg, act)] -> + (* retrieve class name *) + let cn = (fst + (List.find + (fun (tn, tgs) -> + List.exists (fun tg' -> tg = tg') tgs) + ts)) in + fprintf ff "@[case %a.%a:@ " + print_name cn + print_name tg; + print_act ff act objs avs ts single; + fprintf ff "@ break;@]"; + | (tg, act) :: grds' -> + (* retrieve class name *) + let cn = (fst + (List.find + (fun (tn, tgs) -> + List.exists (fun tg' -> tg = tg') tgs) + ts)) in + fprintf ff "@[case %a.%a:@ " + print_name cn + print_name tg; + print_act ff act objs avs ts single; + fprintf ff "@ break;@ @]@ "; + print_grds ff grds' objs avs ts single + +and print_if ff e grds objs avs ts single = + match grds with + | [("true", a)] -> + fprintf ff "@[@[if (%a) {@ " + (fun ff e -> print_exp ff e 0 avs ts single) e; + print_act ff a objs avs ts single; + fprintf ff "@]@ }@]" + | [("false", a)] -> + fprintf ff "@[@[if (!%a) {@ " + (fun ff e -> print_exp ff e 6 avs ts single) e; + print_act ff a objs avs ts single; + fprintf ff "@]@ }@]" + | [("true", a1); ("false", a2)] -> + fprintf ff "@[@[if (%a) {@ " + (fun ff e -> print_exp ff e 0 avs ts single) e; + print_act ff a1 objs avs ts single; + fprintf ff "@]@ @[} else {@ "; + print_act ff a2 objs avs ts single; + fprintf ff "@]@ }@]" + | [("false", a2); ("true", a1)] -> + fprintf ff "@[@[if (%a) {@ " + (fun ff e -> print_exp ff e 0 avs ts single) e; + print_act ff a1 objs avs ts single; + fprintf ff "@]@ @[} else {@ "; + print_act ff a2 objs avs ts single; + fprintf ff "@]@ }@]" + | _ -> assert false + +and print_asgn ff x e avs ts single = + fprintf ff "@["; + print_lhs ff x avs single; + fprintf ff " = "; + print_exp ff e 0 avs ts single; + fprintf ff "@]" + +let print_vd ff vd = + let jty,jdv = java_type_default_value vd.v_type in + fprintf ff "@["; + print_name ff jty; + fprintf ff " %s = %s;" + (jname_of_name (name vd.v_name)) + jdv; + fprintf ff "@]" + +let print_obj ff od = + fprintf ff "@["; + fprintf ff "%a %a = new %a();" + print_shortname od.cls + print_name od.obj + print_shortname od.cls; + fprintf ff "@]" + +let rec print_objs ff ods = + match ods with + | [] -> () + | od :: ods' -> + print_obj ff od; + fprintf ff "@ "; + print_objs ff ods' + +let print_comps ff fds= + let rec walk n = function + | [] -> () + | fd :: fds' -> + fprintf ff "@ "; + fprintf ff "public "; + print_type ff fd.v_type; + fprintf ff " c_%s;" (string_of_int n); + walk (n + 1) fds' + in walk 1 fds + +let print_ans_struct ff name fields = + fprintf ff "@[@[public class %s {" name; + print_comps ff fields; + fprintf ff "@]@ }@]@ " + +let print_vd' ff vd = + fprintf ff "@["; + print_type ff vd.v_type; + fprintf ff "@ %s" (jname_of_name (name vd.v_name)); + fprintf ff "@]" + +let rec print_in ff = function + | [] -> () + | [vd] -> print_vd' ff vd + | vd :: vds' -> + print_vd' ff vd; + fprintf ff ",@ "; + print_in ff vds' + +let rec print_mem ff = function + | [] -> () + | vd :: m' -> + print_vd ff vd; + fprintf ff "@ "; + print_mem ff m' + +let print_loc ff vds = print_mem ff vds + +let print_step ff n s objs ts single = + let name = jname_of_name n in + fprintf ff "@[@ @[public "; + if single then print_type ff (List.hd s.out).v_type + else fprintf ff "%s" (n ^ "Answer"); + fprintf ff " step(@["; + print_in ff s.inp; + fprintf ff "@]) {@ "; + let loc = if single then (List.hd s.out) :: s.local else s.local in + if loc = [] then () else (print_loc ff loc; fprintf ff "@ "); + if single then fprintf ff "@ " + else fprintf ff "%sAnswer step_ans = new %sAnswer();@ @ " n n; + print_act ff s.bd objs + (List.map (fun vd -> vd.v_name) s.out) ts single; + fprintf ff "@ @ return "; + if single then fprintf ff "%s" (jname_of_name (Ident.name (List.hd s.out).v_name)) + else fprintf ff "step_ans"; + fprintf ff ";@]@ }@ @]" + +let print_reset ff r ts = + fprintf ff "@[@ @[public void reset() {@ "; + print_act ff r [] [] ts false; + fprintf ff "@]@ }@ @]" + +let print_class ff headers ts single opened_mod cl = + let clid = jname_of_name cl.cl_id in + List.iter (fprintf ff "%s") headers; +(* fprintf ff "@[package %s;@\n@\n" headers; *) + (* import opened modules *) + List.iter + (fun m -> + fprintf ff "import %s.*;@\n" (String.uncapitalize m)) + opened_mod; + + fprintf ff "@\n@[public class %s {@ " clid; + if cl.mem = [] then () + else fprintf ff "@[@ "; print_mem ff cl.mem; fprintf ff "@]"; + if cl.objs = [] then () + else fprintf ff "@[@ "; print_objs ff cl.objs; fprintf ff "@]"; + print_reset ff cl.reset ts; + print_step ff clid cl.step cl.objs ts single; + fprintf ff "@]@ }@]" + +let print_class_and_answer_to_file java_dir headers ts opened_mod cl = + let clid = jname_of_name cl.cl_id in + let print_class_to_file single = + let out_ch = open_out (java_dir ^ "/" ^ clid ^ ".java") in + let ff = formatter_of_out_channel out_ch in + Misc.print_header_info ff "/*" "*/"; + print_class ff headers ts single opened_mod cl; + fprintf ff "@."; + close_out out_ch + in + match cl.step.out with + | [_] -> print_class_to_file true + | _ -> + let out_ch = open_out (java_dir ^ "/" ^ clid ^ "Answer.java") in + let ff = formatter_of_out_channel out_ch in + Misc.print_header_info ff "/*" "*/"; + List.iter (fprintf ff "%s") headers; +(* fprintf ff "@[package %s;@\n@\n" headers; *) + List.iter + (fun m -> + fprintf ff "import %s.*;@\n" (String.uncapitalize m)) + opened_mod; + print_ans_struct ff (clid ^ "Answer") cl.step.out; + fprintf ff "@."; + close_out out_ch; + print_class_to_file false + +let print_classes java_dir headers ts opened_mod cls = + List.iter + (print_class_and_answer_to_file java_dir headers ts opened_mod) + cls + +(******************************) +let print java_dir p = + let headers = + List.map snd + (List.filter + (fun (tag,_) -> tag = "java") + p.o_pragmas) in + print_types java_dir headers p.o_types; + o_types := p.o_types; + print_classes + java_dir headers + (List.flatten + (List.map + (function + | { t_desc = Type_abs } -> [] + | { t_name = tn; t_desc = Type_enum tgs } -> [tn, tgs] + | { t_name = tn; t_desc = Type_struct fields } -> + [tn, (List.map fst fields)]) + p.o_types)) + p.o_opened + p.o_defs + +(******************************) diff --git a/minils/sequential/mls2obc.ml b/minils/sequential/mls2obc.ml new file mode 100644 index 0000000..c1b24ff --- /dev/null +++ b/minils/sequential/mls2obc.ml @@ -0,0 +1,414 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* translation from the source language to the target *) + +(* $Id$ *) + +open Misc +open Names +open Ident +open Global +open Obc +open Control +open Normalize +open Memalloc +open Interference +open Static + +(* merge x (C1 -> (merge y (C2 -> e2)) when C1(x)) *) + +(** Targeted inputs should be marked as passed by reference. *) +let update_targeted_inputs targeting inv = + let rec aux i = function + | [] -> [] + | vd::l -> + let vd = + if List.mem_assoc i targeting then (*input is targeted*) + { vd with v_pass_by_ref = true; } + else (*not targeted, leave it*) + vd + in + vd::(aux (i+1) l) + in + aux 0 inv + +let rec encode_name_params n = function + | [] -> n + | p::params -> encode_name_params (n^"__"^(string_of_int p)) params + +let encode_longname_params n params = + match n with + | Name n -> Name (encode_name_params n params) + | Modname { qual = qual; id = id } -> + Modname { qual = qual; id = encode_name_params id params } + +let is_op = function + | Modname { qual = "Pervasives"; id = _ } -> true + | _ -> false + +let rec translate_type const_env = function + | Minils.Tbase(btyp) -> translate_base_type const_env btyp + | Minils.Tprod _ -> assert false + +and translate_base_type const_env = function + | Minils.Tint -> Tint + | Minils.Tfloat -> Tfloat + | Minils.Tid(id) -> Tid(id) + | Minils.Tarray(ty, n) -> Tarray (translate_base_type const_env ty, + int_of_size_exp const_env n) + +let rec translate_const const_env = function + | Minils.Cint(v) -> Cint(v) + | Minils.Cfloat(v) -> Cfloat(v) + | Minils.Cconstr(c) -> Cconstr(c) + | Minils.Cconst_array(n,c) -> + Cconst_array(int_of_size_exp const_env n, translate_const const_env c) + +let rec translate_pat map = function + | Minils.Evarpat(x) -> [var_from_name map x] + | Minils.Etuplepat(pat_list) -> + List.fold_right (fun pat acc -> (translate_pat map pat) @ acc) pat_list [] + +(* [translate e = c] *) +let rec translate const_env map (m, si, j, s) ({ Minils.e_desc = desc } as e) = + match desc with + | Minils.Econst(v) -> Const(translate_const const_env v) + | Minils.Evar(n) -> Lhs (var_from_name map n) + | Minils.Econstvar(n) -> + Const (Cint(int_of_size_exp const_env (SVar n))) + | Minils.Eop(n, _, e_list) -> + Op(n, List.map (translate const_env map (m, si, j, s)) e_list) + | Minils.Ewhen(e, _, _) -> translate const_env map (m, si, j, s) (e) + | Minils.Efield(e, field) -> + let e = translate const_env map (m, si, j, s) e in + Lhs (Field(lhs_of_exp e, field)) + | Minils.Estruct(f_e_list) -> + let type_name = + begin match e.Minils.e_ty with + Minils.Tbase(Minils.Tid(name)) -> name + | _ -> assert false + end in + let f_e_list = List.map + (fun (f, e) -> (f, + translate const_env map (m, si, j, s) e)) f_e_list in + Struct(type_name,f_e_list) +(*Array operators*) + | Minils.Earray e_list -> + Array (List.map (translate const_env map (m, si, j, s)) e_list) + | Minils.Eselect (idx,e) -> + let e = translate const_env map (m, si, j, s) e in + Lhs ( Array (lhs_of_exp e, + List.map (int_of_size_exp const_env) idx) ) + | _ -> Minils.Printer.print_exp stdout e; flush stdout; assert false + +(* [translate pat act = si, j, d, s] *) +and translate_act const_env map ((m,_,_,_) as context) pat ({ Minils.e_desc = desc } as act) = + match pat, desc with + | Minils.Etuplepat(p_list), Minils.Etuple(act_list) -> + comp (List.map2 (translate_act const_env map context) p_list act_list) + | pat, Minils.Ewhen(e, _, _) -> + translate_act const_env map context pat e + | pat, Minils.Emerge(x, c_act_list) -> + let lhs = var_from_name map x in + (Case(Lhs lhs, translate_c_act_list const_env map context pat c_act_list)) + | Minils.Evarpat(n), _ -> + Assgn(var_from_name map n, translate const_env map context act) + | _ -> + Minils.Printer.print_exp stdout act; + assert false + +and translate_c_act_list const_env map context pat c_act_list = + List.map + (fun (c, act) -> (c, translate_act const_env map context pat act)) + c_act_list + +and comp s_list = + List.fold_right (fun s rest -> Comp(s, rest)) s_list Nothing + +let rec translate_eq const_env map { Minils.p_lhs = pat; Minils.p_rhs = e } (m, si, j, s) = + let { Minils.e_desc = desc; Minils.e_ty = ty; Minils.e_ck = ck } = e in + match pat, desc with + | Minils.Evarpat(n), Minils.Efby(opt_c, e) -> + let x = var_from_name map n in + let si = + match opt_c with + | None -> si + | Some(c) -> + if var_name x = n then + (Assgn(x, Const(translate_const const_env c))) :: si + else + si (*this mem is shared, no need to add a reset intruction*) + in + let ty = translate_type const_env ty in + let m = if var_name x = n then (n, ty) :: m else m in + m, si, j, + (control map ck (Assgn(var_from_name map n, translate const_env map (m, si, j, s) e))) :: s + | pat, Minils.Eapp({ Minils.a_op = n }, params, e_list) -> + let sig_info = (Modules.find_value n).info in + let name_list = translate_pat map pat in + let name_list = remove_targeted_outputs sig_info.targeting name_list in + let c_list = List.map (translate const_env map (m, si, j, s)) e_list in + let o = gen_symbol () in + let si = (Reinit(o)) :: si in + let params = List.map (int_of_size_exp const_env) params in + let j = (o, encode_longname_params n params, 1) :: j in + let s = + (control map ck (Step_ap(name_list, o, c_list))) :: s in + (m, si, j, s) + | pat, Minils.Eevery({ Minils.a_op = n }, params, e_list, r ) -> + let name_list = translate_pat map pat in + let c_list = List.map (translate const_env map (m, si, j, s)) e_list in + let o = gen_symbol () in + let si = (Reinit(o)) :: si in + let params = List.map (int_of_size_exp const_env) params in + let j = (o, encode_longname_params n params, 1) :: j in + let s = + (control map (Minils.Con(ck, Name("true"), r)) (Reinit(o))) :: + (control map ck (Step_ap(name_list, o, c_list))) :: s in + (m, si, j, s) + | Minils.Etuplepat(p_list), Minils.Etuple(act_list) -> + List.fold_right2 + (fun pat e -> translate_eq const_env map { Minils.p_lhs = pat; Minils.p_rhs = e } ) + p_list act_list (m, si, j, s) + | Minils.Evarpat(x), Minils.Eselect_slice(idx1, idx2, e) -> + let idx1 = int_of_size_exp const_env idx1 in + let idx2 = int_of_size_exp const_env idx2 in + let idx = + let cpt = name (Ident.fresh "i") in + let e = translate const_env map (m, si, j, s) e in + let action = For( cpt, 0, idx2 - idx1 + 1, + Assgn (Array (var_from_name map x, Var cpt), + Lhs (Array (lhs_of_exp e, idx))) ) + + let action = Array_select_slice (var_from_name map x, + translate const_env map (m, si, j, s) e, + int_of_size_exp const_env idx1, + int_of_size_exp const_env idx2) in + m, si, j, ((control map ck action)::s) + | Minils.Evarpat(x), Minils.Eselect_dyn (idx, bounds, e1, e2) -> + let action = Array_select_dyn (var_from_name map x, + translate const_env map (m, si, j, s) e1, + List.map (translate const_env map (m, si, j, s)) idx, + List.map (int_of_size_exp const_env) bounds, + translate const_env map (m, si, j, s) e2 ) in + m, si, j, ((control map ck action)::s) + | Minils.Evarpat(x), Minils.Eupdate (idx, e1, e2) -> + let x = var_from_name map x in + let copy = Assgn (x, translate const_env map (m, si, j, s) e1) in + let action = Assgn (Array (x, List.map (int_of_size_exp const_env) idx), + translate const_env map (m, si, j, s) e2) in + m, si, j, ((control map ck copy)::(control map ck action)::s) + | Minils.Evarpat(x), Minils.Erepeat (n, e) -> + let cpt = name (Ident.fresh "i") in + let action = For (cpt, 0, int_of_size_exp const_env n, + Assgn(Lhs (var_from_name map x, Var cpt), + translate const_env map (m, si, j, s) e) in + m, si, j, ((control map ck action)::s) + | Minils.Evarpat(x), Minils.Econcat(e1, e2) -> + let action = Array_concat (var_from_name map x, translate const_env map (m, si, j, s) e1, + translate const_env map (m, si, j, s) e2) in + m, si, j, ((control map ck action)::s) + | pat, Minils.Eiterator(it, f, params, n, e_list, reset) -> + let sig_info = (Modules.find_value f).info in + let name_list = translate_pat map pat in + let name_list = remove_targeted_outputs sig_info.targeting name_list in + let c_list = List.map (translate const_env map (m, si, j, s)) e_list in + let o = gen_symbol () in + let n = int_of_size_exp const_env n in + let si = if is_op f then si else (Reinit(o)) :: si in + let params = List.map (int_of_size_exp const_env) params in + let j = (o, encode_longname_params f params, n) :: j in + let action = Array_iterate (name_list, it, o, n, c_list) in + let s = + (match reset with + | None -> (control map ck action)::s + | Some r -> + (control map (Minils.Con(ck, Name("true"), r)) (Reinit(o))) :: + (control map ck action)::s + ) in + m, si, j, s + | Minils.Evarpat(x), Minils.Efield_update (f, e1, e2) -> + let action = Field_update (var_from_name map x, translate const_env map (m,si,j,s) e1, + f, translate const_env map (m,si,j,s) e2) in + m, si, j, ((control map ck action)::s) + | Minils.Etuplepat [], Minils.Ereset_mem(y, v, res) -> + let h = Initial.ptrue, Assgn(var_from_name map y, Const (translate_const const_env v)) in + let action = Case (Lhs (var_from_name map res), [h]) in + (m, si, j, (control map ck action) :: s) + | pat, _ -> + let action = translate_act const_env map (m, si, j, s) pat e in + (m, si, j, (control map ck action) :: s) + +let translate_eq_list const_env map act_list = + List.fold_right (translate_eq const_env map) act_list ([], [], [], []) + +let remove m d_list = + List.filter (fun { Minils.v_name = n } -> not (List.mem_assoc n m)) d_list + +let var_decl l = + List.map (fun (x, t) -> { v_name = x; v_type = t; v_pass_by_ref = false }) l + +let obj_decl l = List.map (fun (x, t, i) -> { obj = x; cls = t; n = i }) l + +let translate_var_dec const_env map l = + let one_var { Minils.v_name = x; Minils.v_type = t } = + { v_name = x; v_type = translate_base_type const_env t; v_pass_by_ref = false } + in + (* remove unused vars *) + let l = List.filter (fun { Minils.v_name = x } -> + var_name (var_from_name map x) = x) l in + List.map one_var l + +let translate_contract const_env map = function + | None -> + [], [], [], [], [], [] + | Some({ Minils.c_eq = eq_list; + Minils.c_local = d_list; + Minils.c_controllables = c_list; + Minils.c_assume = e_a; + Minils.c_enforce = e_c }) -> + let m, si, j, s_list = translate_eq_list const_env map eq_list in + let d_list = remove m d_list in + let d_list = translate_var_dec const_env map d_list in + let c_list = translate_var_dec const_env map c_list in + m, si, j, s_list, d_list, c_list + +let rec choose_record_field m = function + | [IVar x] -> Var x + | [IField(x,f)] -> Field(var_from_name m x,f) + | (IVar x)::l -> choose_record_field m l + | (IField(x,f))::l -> + if var_name (var_from_name m x) <> x then + choose_record_field m l + else + Field(var_from_name m x,f) + +(** Chooses from a list of vars (with the same color in the interference graph) + the one that will be used to store every other. It can be either an input, + an output or any var if there is no input or output in the list. *) +let choose_representative m inputs outputs mems vars = + let ivar_mem x vars = + match x with + | IVar x -> List.mem x vars + | _ -> false + in + + let inputs = List.filter (fun var -> Minils.ivar_vd_mem var inputs) vars in + let outputs = List.filter (fun var -> Minils.ivar_vd_mem var outputs) vars in + let mems = List.filter (fun var -> ivar_mem var mems) vars in + match inputs, outputs, mems with + | [], [], [] -> choose_record_field m vars + | [], [], (IVar m)::_ -> Mem m + | [IVar vin], [], [] -> Var vin + | [], [IVar vout], [] -> Var vout + | [IVar vin], [IVar vout], [] -> Var vin + | _, _, _ -> + Format.printf "Something is wrong with the coloring : "; + List.iter (fun vd -> Format.printf "%s," (ivar_to_string vd)) vars; + Format.printf "\n Inputs : "; + List.iter (fun vd -> Format.printf "%s," (ivar_to_string vd)) inputs; + Format.printf "\n Outputs : "; + List.iter (fun vd -> Format.printf "%s," (ivar_to_string vd)) outputs; + Format.printf "\n Mem : "; + List.iter (fun vd -> Format.printf "%s," (ivar_to_string vd)) mems; + Format.printf "\n"; + assert false (*something went wrong in the coloring*) + +(** Returns a map, mapping variables names to the variables + where they will be stored, as a result of memory allocation. *) +let subst_map_from_coloring subst_lists inputs outputs locals mems = + let rec add_to_map map value = function + | [] -> map + | var::l -> + let m = add_to_map map value l in + (match var with + | IVar x -> Env.add x value m + | _ -> m + ) + in + let map_from_subst_lists m l = + List.fold_left + (fun m (_,l) -> add_to_map m (choose_representative m inputs outputs mems l) l) + m l + in + if !no_mem_alloc then ( + (* Create a map that simply maps each var to itself *) + let m = List.fold_left + (fun m { Minils.v_name = x } -> Env.add x (Var x) m) + Env.empty (inputs @ outputs @ locals) in + List.fold_left (fun m x -> Env.add x (Mem x) m) m mems + ) else ( + let record_lists, other_lists = List.partition + (fun (ty,_) -> Minils.is_record_type ty) subst_lists in + let m = map_from_subst_lists Env.empty record_lists in + map_from_subst_lists m other_lists + ) + +let translate_node_aux const_env + { Minils.n_name = f; Minils.n_input = i_list; Minils.n_output = o_list; + Minils.n_local = d_list; Minils.n_equs = eq_list; + Minils.n_contract = contract ; Minils.n_targeting = targeting; + Minils.n_mem_alloc = mem_alloc; Minils.n_params = params } = + + let mem_vars = List.flatten (List.map InterfRead.memory_vars eq_list) in + let subst_map = subst_map_from_coloring mem_alloc i_list o_list d_list mem_vars in + let m, si, j, s_list = translate_eq_list const_env subst_map eq_list in + let m', si', j', s_list', d_list', c_list = translate_contract const_env subst_map contract in + let d_list = remove m d_list in + let i_list = translate_var_dec const_env subst_map i_list in + let i_list = update_targeted_inputs targeting i_list in + let o_list = translate_var_dec const_env subst_map o_list in + let d_list = translate_var_dec const_env subst_map d_list in + let s = joinlist (s_list@s_list') in + let m = var_decl (m@m') in + let j = obj_decl (j@j') in + let si = joinlist (si@si') in + let step = { inp = i_list; out = o_list; + local = (d_list@d_list'@c_list); + controllables = c_list; + bd = s } in + { cl_id = f; mem = m; objs = j; reset = si; step = step } + +let build_params_list env params_names params_values = + List.fold_left2 (fun env n v -> NamesEnv.add n (SConst v) env) env params_names params_values + +let translate_node const_env n = + let translate_one p = + let const_env = build_params_list const_env n.Minils.n_params p in + let c = translate_node_aux const_env n in + { c with cl_id = encode_name_params c.cl_id p; } + in + match n.Minils.n_params_instances with + | [] -> [translate_node_aux const_env n] + | params_lists -> List.map translate_one params_lists + +let translate_ty_def const_env { Minils.t_name = name; Minils.t_desc = tdesc } = + let tdesc = match tdesc with + | Minils.Type_abs -> Type_abs + | Minils.Type_enum(tag_name_list) -> Type_enum(tag_name_list) + | Minils.Type_struct(field_ty_list) -> + Type_struct + (List.map (fun (f, ty) -> (f, translate_base_type const_env ty)) field_ty_list) + in + { t_name = name; t_desc = tdesc } + +let build_const_env cd_list = + List.fold_left (fun env cd -> NamesEnv.add cd.Minils.c_name cd.Minils.c_value env) NamesEnv.empty cd_list + +let program { Minils.p_pragmas = p_pragmas_list; + Minils.p_opened = p_module_list; + Minils.p_types = p_type_list; + Minils.p_nodes = p_node_list; + Minils.p_consts = p_const_list; } = + let const_env = build_const_env p_const_list in + { o_pragmas = p_pragmas_list; + o_opened = p_module_list; + o_types = List.map (translate_ty_def const_env) p_type_list; + o_defs = List.flatten (List.map (translate_node const_env) p_node_list) } diff --git a/minils/sequential/obc.ml b/minils/sequential/obc.ml new file mode 100644 index 0000000..d927bbc --- /dev/null +++ b/minils/sequential/obc.ml @@ -0,0 +1,433 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* Object code internal representation *) + +(* $Id$ *) + +open Misc +open Names +open Ident + +type var_name = ident +type type_name = longname +type fun_name = longname +type class_name = name +type instance_name = longname +type obj_name = name +type op_name = longname +type field_name = longname + +type ty = + | Tint + | Tfloat + | Tid of type_name + | Tarray of ty * int + +type type_dec = + { t_name : name; + t_desc : tdesc } + +and tdesc = + | Type_abs + | Type_enum of name list + | Type_struct of (name * ty) list + +type const = + | Cint of int + | Cfloat of float + | Cconstr of longname + | Cconst_array of int * const + +type lhs = + | Var of var_name + | Mem of var_name + | Field of lhs * field_name + | Array of lhs * exp + +type exp = + | Lhs of lhs + | Const of const + | Op of op_name * exp list + | Struct of type_name * (field_name * exp) list + | Array of exp list + +type act = + | Assgn of lhs * exp + | Step_ap of lhs list * obj_name * exp list + | Comp of act * act + | Case of exp * (longname * act) list + | For of var_name * int * int * act + | Reinit of obj_name + | Nothing + | Array_select_slice of lhs * exp * int * int + | Array_select_dyn of lhs * exp * exp list * int list * exp (* res, var, indices, bounds, def value*) + | Array_iterate of lhs list * iterator_name * obj_name * int * exp list + | Array_concat of lhs * exp * exp + | Field_update of lhs * exp * longname * exp (* var, record, field, value*) + +type var_dec = + { v_name : var_name; + v_type : ty; + v_pass_by_ref : bool; } + +type obj_dec = + { obj : obj_name; + cls : instance_name; + n : int; } + +type step_fun = + { inp : var_dec list; + out : var_dec list; + local : var_dec list; + controllables : var_dec list; (* GD : ugly patch to delay controllable + variables definition to target code + generation *) + bd : act } + +type reset_fun = act + +type class_def = + { cl_id : class_name; + mem : var_dec list; + objs : obj_dec list; + reset : reset_fun; + step : step_fun; } + +type program = + { o_pragmas: (name * string) list; + o_opened : name list; + o_types : type_dec list; + o_defs : class_def list } + +(** [is_scalar_type vd] returns whether the type corresponding + to this variable declaration is scalar (ie a type that can + be returned by a C function). *) +let is_scalar_type vd = + let pint = Modname({ qual = "Pervasives"; id = "int" }) in + let pfloat = Modname({ qual = "Pervasives"; id = "float" }) in + let pbool = Modname({ qual = "Pervasives"; id = "bool" }) in + match vd.v_type with + | Tint | Tfloat -> true + | Tid name_int when name_int = pint -> true + | Tid name_float when name_float = pfloat -> true + | Tid name_bool when name_bool = pbool -> true + | _ -> false + +let actual_type ty = + match ty with + | Tid(Name("float")) + | Tid(Modname { qual = "Pervasives"; id = "float" }) -> Tfloat + | Tid(Name("int")) + | Tid(Modname { qual = "Pervasives"; id = "int" }) -> Tint + | _ -> ty + +let rec var_name x = + match x with + | Var x -> x + | Mem x -> x + | Field(x,_) -> var_name x + +(** Returns whether an object of name n belongs to + a list of var_dec. *) +let rec vd_mem n = function + | [] -> false + | vd::l -> vd.v_name = n or (vd_mem n l) + +(** Returns the var_dec object corresponding to the name n + in a list of var_dec. *) +let rec vd_find n = function + | [] -> Format.printf "Not found var %s\n" (name n); raise Not_found + | vd::l -> + if vd.v_name = n then vd else vd_find n l + +let lhs_of_exp = function + | Lhs l -> l + | _ -> assert false + +module Printer = +struct + open Format + + let rec print_list ff print sep = function + | [] -> () + | [x] -> print ff x + | x :: l -> + print ff x; + fprintf ff "%s@ " sep; + print_list ff print sep l + + (* Infix chars are surrounded by parenthesis *) + let is_infix = + let module StrSet = Set.Make(String) in + let set_infix = + List.fold_right + StrSet.add + ["or"; "quo"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] + StrSet.empty in + fun s -> StrSet.mem s set_infix + + let print_name ff s = + let c = String.get s 0 in + let s = if is_infix s then "(" ^ s ^ ")" + else match c with + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> s + | '*' -> "( " ^ s ^ " )" + | _ -> if s = "()" then s else "(" ^ s ^ ")" in + fprintf ff "%s" s + + let print_longname ff ln = + let ln = (* currentname ln*) ln in + match ln with + | Name(m) -> print_name ff m + | Modname({ qual = "Pervasives"; id = m }) -> print_name ff m + | Modname({ qual = m1; id = m2 }) -> + fprintf ff "%s." m1; print_name ff m2 + + let print_ident ff id = + fprintf ff "%s" (name id) + + let rec print_type ff = function + | Tint -> fprintf ff "int" + | Tfloat -> fprintf ff "float" + | Tid(id) -> print_longname ff id + | Tarray(ty, n) -> + print_type ff ty; + fprintf ff "^%d" n + + let print_vd ff vd = + fprintf ff "@["; + print_ident ff vd.v_name; + fprintf ff ": "; + if vd.v_pass_by_ref then + fprintf ff "&"; + print_type ff vd.v_type; + fprintf ff "@]" + + let print_obj ff { cls = cls; obj = obj; n = n } = + fprintf ff "@["; print_name ff obj; + fprintf ff " : "; print_longname ff cls; + if n <> 1 then + fprintf ff "[%d]" n; + fprintf ff ";@]" + + let rec print_c ff = function + | Cint i -> fprintf ff "%d" i + | Cfloat f -> fprintf ff "%f" f + | Cconstr(tag) -> print_longname ff tag + | Cconst_array(n,c) -> + print_c ff c; + fprintf ff "^%d" n + + let rec print_lhs ff e = + match e with + | Var x -> print_ident ff x + | Mem x -> fprintf ff "mem("; print_ident ff x; fprintf ff ")" + | Field (l, f) -> print_lhs ff l; fprintf ff ".%s" (shortname f) + + let rec print_exps ff e_list = print_list ff print_exp "," e_list + + and print_exp ff = function + | Lhs lhs -> print_lhs ff lhs + | Const c -> print_c ff c + | Op(op, e_list) -> print_op ff op e_list + | Struct(_,f_e_list) -> + fprintf ff "@[{"; + print_list ff + (fun ff (field, e) -> print_longname ff field;fprintf ff " = "; + print_exp ff e) + ";" f_e_list; + fprintf ff "}@]" + | Array e_list -> + fprintf ff "@[["; + print_list ff print_exp ";" e_list; + fprintf ff "]@]" + | Array_select(x, idx) -> + print_exp ff x; + fprintf ff "["; + print_list ff (fun ff -> fprintf ff "%d") "][" idx; + fprintf ff "]" + + and print_op ff op e_list = + print_longname ff op; + fprintf ff "(@["; print_list ff print_exp ", " e_list; + fprintf ff ")@]" + + let print_asgn ff pref x e = + fprintf ff "@[%s" pref; print_lhs ff x; fprintf ff " = "; + fprintf ff "@["; print_exp ff e; fprintf ff "@]"; + fprintf ff "@]" + + let rec print_act ff a = + match a with + | Assgn (x, e) -> print_asgn ff "" x e + | Comp (a1, a2) -> + fprintf ff "@["; + print_act ff a1; + fprintf ff ";@,"; + print_act ff a2; + fprintf ff "@]" + | Case(e, tag_act_list) -> + fprintf ff "@[@[switch ("; + print_exp ff e; fprintf ff ") {@,"; + print_tag_act_list ff tag_act_list; + fprintf ff "@]@,}@]" + | Step_ap (var_list, o, es) -> + fprintf ff "@[("; + print_list ff print_lhs "," var_list; + fprintf ff "@])"; + fprintf ff " = "; print_name ff o; fprintf ff ".step("; + fprintf ff "@["; print_exps ff es; fprintf ff "@]"; + fprintf ff ")" + | Reinit o -> + print_name ff o; fprintf ff ".reset()" + | Nothing -> fprintf ff "()" + | Array_select_slice (var, e, idx1, idx2) -> + fprintf ff "@["; + print_lhs ff var; + fprintf ff " = "; + print_exp ff e; + fprintf ff "[%d..%d]" idx1 idx2; + fprintf ff "@]" + | Array_select_dyn (var, x, idx, _, defe) -> + fprintf ff "@["; + print_lhs ff var; + fprintf ff " = "; + fprintf ff "@["; + print_exp ff x; + fprintf ff "["; + print_list ff print_exp "][" idx; + fprintf ff "] default "; + print_exp ff defe; + fprintf ff "@]" + | Array_update (x, e1, idx, e2) -> + fprintf ff "@["; + print_lhs ff x; + fprintf ff " = "; + print_exp ff e1; + fprintf ff " with ["; + print_list ff (fun ff -> fprintf ff "%d") "][" idx; + fprintf ff "] = "; + print_exp ff e2; + fprintf ff "@]" + | Array_repeat (x, n, e) -> + fprintf ff "@["; + print_lhs ff x; + fprintf ff " = "; + print_exp ff e; + fprintf ff "^%d" n + | Array_iterate (o_list, it, f, n, e_list) -> + fprintf ff "@[("; + print_list ff print_lhs ", " o_list; + fprintf ff ") = "; + fprintf ff "("; + fprintf ff "%s" (iterator_to_string it); + fprintf ff " "; + print_name ff f; + fprintf ff " <<%d>>) (@[" n; + print_list ff print_exp "," e_list; + fprintf ff ")@]@]" + | Array_concat (x, e1, e2) -> + fprintf ff "@["; + print_lhs ff x; + fprintf ff " = "; + print_exp ff e1; + fprintf ff " @@ "; + print_exp ff e2 + | Field_update (x, e1, f, e2) -> + fprintf ff "@["; + print_lhs ff x; + fprintf ff " = "; + print_exp ff e1; + fprintf ff " with ."; + print_longname ff f; + fprintf ff " = "; + print_exp ff e2; + fprintf ff "@]" + + and print_tag_act_list ff tag_act_list = + print_list ff + (fun ff (tag, a) -> + fprintf ff "@[case@ "; + print_longname ff tag; + fprintf ff ":@ "; + print_act ff a; + fprintf ff "@]") "" tag_act_list + + let print_step ff { inp = inp; out = out; local = nl; bd = bd } = + fprintf ff "@["; + fprintf ff "step(@["; + print_list ff print_vd ";" inp; + fprintf ff "@]) returns (@["; + print_list ff print_vd ";" out; + fprintf ff "@]){@,"; + if nl <> [] then begin + fprintf ff "@[var "; + print_list ff print_vd ";" nl; + fprintf ff ";@]@," + end; + print_act ff bd; + fprintf ff "}@]" + + let print_reset ff act = + fprintf ff "@["; + fprintf ff "reset() {@,"; + print_act ff act; + fprintf ff "}@]" + + let print_def ff + { cl_id = id; mem = mem; objs = objs; reset = reset; step = step } = + fprintf ff "@[machine "; print_name ff id; fprintf ff " =@,"; + if mem <> [] then begin + fprintf ff "@[var "; + print_list ff print_vd ";" mem; + fprintf ff ";@]@," + end; + if objs <> [] then begin + fprintf ff "@[obj "; + print_list ff print_obj ";" objs; + fprintf ff ";@]@," + end; + print_reset ff reset; + fprintf ff "@,"; + print_step ff step; + fprintf ff "@]" + + let print_type_def ff { t_name = name; t_desc = tdesc } = + match tdesc with + | Type_abs -> fprintf ff "@[type %s@\n@]" name + | Type_enum(tag_name_list) -> + fprintf ff "@[type %s = " name; + print_list ff print_name "| " tag_name_list; + fprintf ff "@\n@]" + | Type_struct(f_ty_list) -> + fprintf ff "@[type %s = " name; + fprintf ff "@[{"; + print_list ff + (fun ff (field, ty) -> + print_name ff field; + fprintf ff ": "; + print_type ff ty) ";" f_ty_list; + fprintf ff "}@]@.@]" + + let print_open_module ff name = + fprintf ff "@[open "; + print_name ff name; + fprintf ff "@.@]" + + let print_prog ff { o_opened = modules; o_types = types; o_defs = defs } = + List.iter (print_open_module ff) modules; + List.iter (print_type_def ff) types; + List.iter (fun def -> (print_def ff def; fprintf ff "@ ")) defs + + let print oc p = + let ff = formatter_of_out_channel oc in + fprintf ff "@[-- Code generated by the MiniLucid Compiler@."; + fprintf ff "@["; print_prog ff p; fprintf ff "@]@]@." +end + diff --git a/minils/transformations/callgraph.ml b/minils/transformations/callgraph.ml new file mode 100644 index 0000000..dae310f --- /dev/null +++ b/minils/transformations/callgraph.ml @@ -0,0 +1,127 @@ +open Misc +open Minils +open Names +open Ident +open Format +open Location +open Printf +open Static + +module Error = +struct + type error = + | Emain_node_no_params of name + + let message loc kind = + begin match kind with + | Emain_node_no_params n -> + eprintf "%aThe main node '%s' cannot have parameters.\n" + output_location loc + n + end; + raise Misc.Error +end + +let nodes_instances = ref NamesEnv.empty +let global_env = ref NamesEnv.empty + +let rec string_of_int_list = function + | [] -> "" + | [n] -> (string_of_int n) + | n::l -> (string_of_int n)^", "^(string_of_int_list l) + +let add_node_params n params = + if NamesEnv.mem n !nodes_instances then + nodes_instances := NamesEnv.add n (params::(NamesEnv.find n !nodes_instances)) !nodes_instances + else + nodes_instances := NamesEnv.add n [params] !nodes_instances + +let rec node_by_name s = function + | [] -> raise Not_found + | n::l -> + if n.n_name = s then + n + else + node_by_name s l + +let build env params_names params_values = + List.fold_left2 (fun m n v -> NamesEnv.add n (SConst v) m) env params_names params_values + +let rec collect_exp nodes env e = + match e.e_desc with + | Emerge(_, c_e_list) -> + List.iter (fun (_, e) -> collect_exp nodes env e) c_e_list + | Eifthenelse(e1, e2, e3) -> + collect_exp nodes env e1; + collect_exp nodes env e2; + collect_exp nodes env e3 + | Ewhen(e, _, _) | Efby(_, e) | Efield(e, _) | Erepeat (_,e) + | Eselect (_,e) | Eselect_slice (_ , _, e) -> + collect_exp nodes env e + | Etuple e_list | Earray e_list + | Eop(_, _, e_list) -> + List.iter (collect_exp nodes env) e_list + | Evar _ | Econstvar _ | Econst _ | Ereset_mem _ -> () + | Estruct(f_e_list) -> + List.iter (fun (_, e) -> collect_exp nodes env e) f_e_list + | Eselect_dyn (e_list, _, e1, e2) -> + List.iter (collect_exp nodes env) e_list; + collect_exp nodes env e1; + collect_exp nodes env e2 + | Eupdate (_, e1, e2) | Econcat (e1, e2) | Efield_update(_, e1, e2) -> + collect_exp nodes env e1; + collect_exp nodes env e2 + (* Do the real work: call node *) + | Eevery(ln, params, e_list, _) + | Eapp(ln, params, e_list) -> + List.iter (collect_exp nodes env) e_list; + let params = List.map (int_of_size_exp env) params in + (match params with + | [] -> () + | params -> + let n = node_by_name (shortname ln.a_op) nodes in + node_call nodes n params + ) + | Eiterator (_, ln, params, _, e_list, _) -> + List.iter (collect_exp nodes env) e_list; + let params = List.map (int_of_size_exp env) params in + (match params with + | [] -> () + | params -> + let n = node_by_name (shortname ln) nodes in + node_call nodes n params + ) + +and collect_eqs nodes env eq = + collect_exp nodes env eq.p_rhs + +and node_call nodes n params = + match params with + | [] -> + List.iter (collect_eqs nodes !global_env) n.n_equs + | params -> + add_node_params n.n_name params; + let env = build !global_env n.n_params params in + List.iter (collect_eqs nodes env) n.n_equs + +let node n = + let inst = + if NamesEnv.mem n.n_name !nodes_instances then + NamesEnv.find n.n_name !nodes_instances + else + [] in + { n with n_params_instances = inst } + +let build_const_env cd_list = + List.fold_left (fun env cd -> NamesEnv.add cd.Minils.c_name cd.Minils.c_value env) NamesEnv.empty cd_list + +let program p = + let try_call_node n = + match n.n_params with + | [] -> node_call p.p_nodes n [] + | _ -> () + in + global_env := build_const_env p.p_consts; + List.iter try_call_node p.p_nodes; + { p with p_nodes = List.map node p.p_nodes } + diff --git a/minils/transformations/clocking.ml b/minils/transformations/clocking.ml new file mode 100644 index 0000000..e1ef1a2 --- /dev/null +++ b/minils/transformations/clocking.ml @@ -0,0 +1,295 @@ +(**************************************************************************) +(* *) +(* MiniLustre *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* clock checking *) + +(* $Id$ *) + +open Misc +open Ident +open Minils +open Global +open Location + +type error = | Etypeclash of ct * ct + +exception TypingError of error +exception Unify + +let error kind = raise (TypingError(kind)) + +let message e kind = + begin match kind with + Etypeclash(actual_ct, expected_ct) -> + Printf.eprintf "%aClock Clash: this expression has clock %a, \n\ + but is expected to have clock %a.\n" + Printer.print_exp e + Printer.print_clock actual_ct + Printer.print_clock expected_ct + end; + raise Error + +let index = ref 0 +let gen_index () = incr index; !index +let new_var () = Cvar { contents = Cindex (gen_index ()) } + +let rec repr ck = + match ck with + Cbase | Con _ | Cvar { contents = Cindex _ } -> ck + | Cvar ({ contents = Clink(ck) } as link) -> + let ck = repr ck in + link.contents <- Clink(ck); + ck + +let rec occur_check index ck = + let ck = repr ck in + match ck with + Cbase -> () + | Cvar { contents = Cindex n } when index <> n -> () + | Con(ck, _, _) -> occur_check index ck + | _ -> raise Unify + +let rec ck_value ck = + match ck with + | Cbase | Con _ | Cvar { contents = Cindex _ } -> ck + | Cvar { contents = Clink(ck) } -> + ck_value ck + +let rec unify t1 t2 = + if t1 == t2 then () + else match t1, t2 with + Ck(ck1), Ck(ck2) -> unify_ck ck1 ck2 + | Cprod(ct_list1), Cprod(ct_list2) -> + begin try + List.iter2 unify ct_list1 ct_list2 + with + _ -> raise Unify + end + | _ -> raise Unify + +and unify_ck ck1 ck2 = + let ck1 = repr ck1 in + let ck2 = repr ck2 in + if ck1 == ck2 then () + else match ck1, ck2 with + Cbase, Cbase -> () + | Cvar { contents = Cindex n1 }, Cvar { contents = Cindex n2 } + when n1 = n2 -> () + | Cvar ({ contents = Cindex n1 } as v), _ -> + occur_check n1 ck2; + v.contents <- Clink(ck2) + | _, Cvar ({contents = Cindex n2 } as v) -> + occur_check n2 ck1; + v.contents <- Clink(ck1) + | Con(ck1, c1, n1), Con(ck2, c2, n2) when (c1 = c2) & (n1 = n2) -> + unify_ck ck1 ck2 + | _ -> raise Unify + +let rec eq ck1 ck2 = + match repr ck1, repr ck2 with + | Cbase, Cbase -> true + | Cvar { contents = Cindex n1 }, Cvar { contents = Cindex n2 } -> true + | Con(ck1, _, n1), Con(ck2, _, n2) when (n1 = n2) -> eq ck1 ck2 + | _ -> false + +let rec unify t1 t2 = + match t1, t2 with + Ck(ck1), Ck(ck2) -> unify_ck ck1 ck2 + | Cprod(t1_list), Cprod(t2_list) -> unify_list t1_list t2_list + | _ -> raise Unify + +and unify_list t1_list t2_list = + try + List.iter2 unify t1_list t2_list + with + _ -> raise Unify + +let rec skeleton ck = function + | Tprod(ty_list) -> Cprod(List.map (skeleton ck) ty_list) + | Tbase _ -> Ck(ck) + +let ckofct = function + | Ck(ck) -> repr ck + | Cprod(ct_list) -> Cbase + +let prod = function + | [] -> assert false + | [ty] -> ty + | ty_list -> Tprod(ty_list) + +let typ_of_name h x = Env.find x h + +let rec typing h e = + let ct = match e.e_desc with + | Econst _ | Econstvar _ -> Ck(new_var ()) + | Evar(x) -> Ck(typ_of_name h x) + | Efby(c, e) -> typing h e + | Etuple(e_list) -> + Cprod(List.map (typing h) e_list) + | Eop(_,_, e_list) -> + let ck = new_var () in + List.iter (expect h (Ck(ck))) e_list; + skeleton ck e.e_ty + | Eapp(_,_, e_list) -> + let ck_r = new_var () in + List.iter (expect h (Ck(ck_r))) e_list; + skeleton ck_r e.e_ty + | Eevery(_,_, e_list, n) -> + let ck_r = typ_of_name h n in + List.iter (expect h (Ck(ck_r))) e_list; + skeleton ck_r e.e_ty + | Ewhen(e, c, n) -> + let ck_n = typ_of_name h n in + expect h (skeleton ck_n e.e_ty) e; + skeleton (Con(ck_n, c, n)) e.e_ty + | Eifthenelse(e1, e2, e3) -> + let ck = new_var () in + let ct = skeleton ck e.e_ty in + expect h (Ck(ck)) e1; + expect h ct e2; + expect h ct e3; ct + | Emerge(n, c_e_list) -> + let ck_c = typ_of_name h n in + typing_c_e_list h ck_c n c_e_list; + skeleton ck_c e.e_ty + | Efield(e1,n) -> + let ck = new_var () in + let ct = skeleton ck e1.e_ty in + expect h (Ck(ck)) e1; + ct + | Estruct(l) -> + let ck = new_var () in + List.iter + (fun (n,e) -> + let ct = skeleton ck e.e_ty in + expect h ct e) + l; + Ck(ck) + (*Array operators*) + | Earray e_list -> + let ck = new_var () in + List.iter (expect h (Ck(ck))) e_list; + skeleton ck e.e_ty + | Erepeat (_,e) -> + typing h e + | Eselect (_,e) -> + typing h e + | Eselect_dyn (e_list, _, e, defe) -> + let ck = new_var () in + let ct = skeleton ck e.e_ty in + expect h ct e; + List.iter (expect h ct) e_list; + ct + | Eupdate (_, e1, e2) | Efield_update (_, e1, e2) -> + let ck = new_var () in + let ct = skeleton ck e.e_ty in + expect h (Ck(ck)) e1; + expect h ct e2; + ct + | Eselect_slice (_ , _, e) -> + typing h e + | Econcat (e1, e2) -> + let ck = new_var () in + let ct = skeleton ck e.e_ty in + expect h (Ck(ck)) e1; + expect h ct e2; + ct + | Eiterator (_, f, _, _, e_list, _) -> + let ck_r = new_var () in + List.iter (expect h (Ck(ck_r))) e_list; + skeleton ck_r e.e_ty + | Ereset_mem (_, _, x) -> assert false + in + e.e_ck <- ckofct ct; + ct + +and expect h expected_ty e = + let actual_ty = typing h e in + try unify actual_ty expected_ty + with Unify -> message e (Etypeclash(actual_ty, expected_ty)) + +and typing_c_e_list h ck_c n c_e_list = + let rec typrec = function + | [] -> () + | (c, e) :: c_e_list -> + expect h (skeleton (Con(ck_c, c, n)) e.e_ty) e; + typrec c_e_list in + typrec c_e_list + +let rec typing_pat h = function + | Evarpat(x) -> Ck(typ_of_name h x) + | Etuplepat(pat_list) -> Cprod(List.map (typing_pat h) pat_list) + +let typing_eqs h eq_list = + List.iter + (fun { p_lhs = pat; p_rhs = e } -> + (match e.e_desc with + | Ereset_mem (_, _, x) -> + let ck = typ_of_name h x in + e.e_ck <- ck; + | _ -> + let ty_pat = typing_pat h pat in + try + expect h ty_pat e + with Error -> + (* DEBUG *) + Printf.eprintf "Complete expression: %a\n" + Printer.print_exp e; + Printf.eprintf "Clock pattern: %a\n" + Printer.print_clock ty_pat; + raise Error + ) + ) eq_list + +let build h dec = + List.fold_left (fun h { v_name = n } -> Env.add n (new_var ()) h) h dec + +let sbuild h dec base = + List.fold_left (fun h { v_name = n } -> Env.add n base h) h dec + +let typing_contract h contract base = + match contract with + | None -> h + | Some { c_local = l_list; + c_eq = eq_list; + c_assume = e_a; + c_enforce = e_g; + c_controllables = c_list } -> + let h = sbuild h c_list base in + let h' = build h l_list in + typing_eqs h' eq_list; + (* assumption *) + expect h' (Ck base) e_a; + (* property *) + expect h' (Ck base) e_g; + h + +let typing_node ({ n_name = f; n_input = i_list; n_output = o_list; + n_contract = contract; + n_local = l_list; n_equs = eq_list } as node) = + let base = Cbase in + let h = sbuild Env.empty i_list base in + let h = sbuild h o_list base in + + let h = typing_contract h contract base in + + let h = build h l_list in + typing_eqs h eq_list; + + (*update clock info in variables descriptions *) + let set_clock vd = + { vd with v_clock = ck_value (Env.find vd.v_name h) } in + + { node with n_input = List.map set_clock i_list; + n_output = List.map set_clock o_list; + n_local = List.map set_clock l_list; } + + +let program ({ p_nodes = p_node_list } as p) = + { p with p_nodes = List.map typing_node p_node_list } diff --git a/minils/transformations/init.ml b/minils/transformations/init.ml new file mode 100644 index 0000000..a355e1d --- /dev/null +++ b/minils/transformations/init.ml @@ -0,0 +1,314 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* simple initialization analysis. This is almost trivial since *) +(* input/outputs of a node are forced to be initialized *) +(* add a special treatment of clock state variables whose initial *) +(* values are known. This allows to accept code generated *) +(* for automata *) +(* if [clock c = C fby ec] then [merge c (C -> e) ...] is initialized *) +(* if [e] is initialized only *) + +(* $Id: init.ml 615 2009-11-20 17:43:14Z pouzet $ *) + +open Misc +open Names +open Ident +open Minils +open Location +open Format + +type typ = + | Iproduct of typ list + | Ileaf of init + +and init = + { mutable i_desc: init_desc; + mutable i_index: int } + +and init_desc = + | Izero + | Ione + | Ivar + | Imax of init * init + | Ilink of init + +type typ_env = + { t_init: init; (* its initialisation type *) + t_value: longname option; (* its initial value *) + } + +(* typing errors *) +exception Unify + +let index = ref 0 +let gen_index () = incr index; !index +let new_var () = { i_desc = Ivar; i_index = gen_index () } +let izero = { i_desc = Izero; i_index = gen_index () } +let ione = { i_desc = Ione; i_index = gen_index () } +let imax i1 i2 = { i_desc = Imax(i1, i2); i_index = gen_index () } +let product l = Iproduct(l) +let leaf i = Ileaf(i) + +(* basic operation on initialization values *) +let rec irepr i = + match i.i_desc with + | Ilink(i_son) -> + let i_son = irepr i_son in + i.i_desc <- Ilink(i_son); + i_son + | _ -> i + +(** Simplification rules for max. Nothing fancy here *) +let max i1 i2 = + let i1 = irepr i1 in + let i2 = irepr i2 in + match i1.i_desc, i2.i_desc with + | (Izero, Izero) -> izero + | (Izero, _) -> i2 + | (_, Izero) -> i1 + | (_, Ione) | (Ione, _) -> ione + | _ -> imax i1 i2 + +let rec itype = function + | Iproduct(ty_list) -> itype_list ty_list + | Ileaf(i) -> i + +and itype_list ty_list = + List.fold_left (fun acc ty -> max acc (itype ty)) izero ty_list + +(* saturate an initialization type. Every element must be initialized *) +let rec initialized i = + let i = irepr i in + match i.i_desc with + | Izero -> () + | Ivar -> i.i_desc <- Ilink(izero) + | Imax(i1, i2) -> initialized i1; initialized i2 + | Ilink(i) -> initialized i + | Ione -> raise Unify + +(* build an initialization type from a type *) +let rec skeleton i ty = + match ty with + | Tbase _ -> leaf i + | Tprod(ty_list) -> product (List.map (skeleton i) ty_list) + +(* sub-typing *) +let rec less left_ty right_ty = + if left_ty == right_ty then () + else + match left_ty, right_ty with + | Iproduct(l1), Iproduct(l2) -> List.iter2 less l1 l2 + | Ileaf(i1), Ileaf(i2) -> iless i1 i2 + | _ -> raise Unify + +and iless left_i right_i = + if left_i == right_i then () + else + let left_i = irepr left_i in + let right_i = irepr right_i in + if left_i == right_i then () + else + match left_i.i_desc, right_i.i_desc with + | (Izero, _) | (_, Ione) -> () + | _, Izero -> initialized left_i + | Imax(i1, i2), _ -> + iless i1 right_i; iless i2 right_i + | _, Ivar -> + let left_i = occur_check right_i.i_index left_i in + right_i.i_desc <- Ilink(left_i) + | _, Imax(i1, i2) -> + let i1 = occur_check left_i.i_index i1 in + let i2 = occur_check left_i.i_index i2 in + right_i.i_desc <- Ilink(imax left_i (imax i1 i2)) + | _ -> raise Unify + +(* an inequation [a < t[a]] becomes [a = t[0]] *) +and occur_check index i = + match i.i_desc with + | Izero | Ione -> i + | Ivar -> if i.i_index = index then izero else i + | Imax(i1, i2) -> + max (occur_check index i1) (occur_check index i2) + | Ilink(i) -> occur_check index i + +(* computes the initialization type of a merge *) +let merge opt_c c_i_list = + let rec search c c_i_list = + match c_i_list with + | [] -> izero + | (c0, i) :: c_i_list -> if c = c0 then i else search c c_i_list in + match opt_c with + | None -> List.fold_left (fun acc (_, i) -> max acc i) izero c_i_list + | Some(c) -> search c c_i_list + +module Printer = struct + open Format + + let rec print_list_r print po sep pf ff = function + | [] -> () + | x :: l -> + fprintf ff "@[%s%a" po print x; + List.iter (fprintf ff "%s@]@ @[%a" sep print) l; + fprintf ff "%s@]" pf + + let rec fprint_init ff i = match i.i_desc with + | Izero -> fprintf ff "0" + | Ione -> fprintf ff "1" + | Ivar -> fprintf ff "0" + | Imax(i1, i2) -> fprintf ff "@[%a\\/%a@]" fprint_init i1 fprint_init i2 + | Ilink(i) -> fprint_init ff i + + let rec fprint_typ ff = function + | Ileaf(i) -> fprint_init ff i + | Iproduct(ty_list) -> + fprintf ff "@[%a@]" (print_list_r fprint_typ "("" *"")") ty_list + + let output_typ oc ty = + let ff = formatter_of_out_channel oc in + fprintf ff "@["; + fprint_typ ff ty; + fprintf ff "@?@]" +end + +module Error = struct + open Location + + type error = | Eclash of typ * typ + + exception Error of location * error + + let error loc kind = raise (Error(loc, kind)) + + let message loc kind = + begin match kind with + | Eclash(left_ty, right_ty) -> + Printf.eprintf "%aInitialization error: this expression has type \ + %a, \n\ + but is expected to have type %a\n" + output_location loc + Printer.output_typ left_ty + Printer.output_typ right_ty + end; + raise Misc.Error +end + +let less_exp e actual_ty expected_ty = + try + less actual_ty expected_ty + with | Unify -> Error.message e.e_loc (Error.Eclash(actual_ty, expected_ty)) + +let rec typing h e = + match e.e_desc with + | Econst(c) -> leaf izero + | Evar(x) -> let { t_init = i } = Env.find x h in leaf i + | Efby(None, e) -> + expect h e (skeleton izero e.e_ty); + leaf ione + | Efby(Some _, e) -> + expect h e (skeleton izero e.e_ty); + leaf izero + | Etuple(e_list) -> + product (List.map (typing h) e_list) + | Eop(_, e_list) -> + let i = List.fold_left (fun acc e -> itype (typing h e)) izero e_list in + skeleton i e.e_ty + | Eapp(_, e_list) -> + List.iter (fun e -> expect h e (skeleton izero e.e_ty)) e_list; + skeleton izero e.e_ty + | Eevery(_, e_list, n) -> + List.iter (fun e -> expect h e (skeleton izero e.e_ty)) e_list; + let { t_init = i } = Env.find n h in + skeleton i e.e_ty + | Ewhen(e, c, n) -> + let { t_init = i1 } = Env.find n h in + let i2 = itype (typing h e) in + skeleton (max i1 i2) e.e_ty + | Eifthenelse(e1, e2, e3) -> + let i1 = itype (typing h e1) in + let i2 = itype (typing h e2) in + let i3 = itype (typing h e3) in + let i = max i1 (max i2 i3) in + skeleton i e.e_ty + | Emerge(n, c_e_list) -> + let { t_init = i; t_value = opt_c } = Env.find n h in + let i = + merge opt_c + (List.map (fun (c, e) -> (c, itype (typing h e))) c_e_list) in + skeleton i e.e_ty + | Efield(e1,n) -> + let i = itype (typing h e1) in + skeleton i e.e_ty + | Estruct(l) -> + let i = + List.fold_left + (fun acc (_, e) -> max acc (itype (typing h e))) izero l in + skeleton i e.e_ty + +and expect h e expected_ty = + let actual_ty = typing h e in + less_exp e actual_ty expected_ty + +let rec typing_pat h = function + | Evarpat(x) -> let { t_init = i } = Env.find x h in leaf i + | Etuplepat(pat_list) -> + product (List.map (typing_pat h) pat_list) + +let typing_eqs h eq_list = + List.iter + (fun { p_lhs = pat; p_rhs = e } -> + let ty_pat = typing_pat h pat in + expect h e ty_pat) eq_list + +let build h eq_list = + let rec build_pat h = function + | Evarpat(x) -> Env.add x { t_init = new_var (); t_value = None } h + | Etuplepat(pat_list) -> List.fold_left build_pat h pat_list in + let build_equation h { p_lhs = pat; p_rhs = e } = + match pat, e.e_desc with + | Evarpat(x), Efby(Some(Cconstr c), _) -> + (* we keep the initial value of state variables *) + Env.add x { t_init = new_var (); t_value = Some(c) } h + | _ -> build_pat h pat in + List.fold_left build_equation h eq_list + +let sbuild h dec = + List.fold_left + (fun h { v_name = n } -> Env.add n { t_init = izero; t_value = None } h) + h dec + +let typing_contract h contract = + match contract with + | None -> h + | Some { c_local = l_list; c_eq = eq_list; c_assume = e_a; + c_enforce = e_g; c_controllables = c_list } -> + let h = sbuild h c_list in + let h' = build h eq_list in + typing_eqs h' eq_list; + (* assumption *) + expect h' e_a (skeleton izero e_a.e_ty); + (* property *) + expect h' e_g (skeleton izero e_g.e_ty); + h + +let typing_node { n_name = f; n_input = i_list; n_output = o_list; + n_contract = contract; + n_local = l_list; n_equs = eq_list } = + let h = sbuild Env.empty i_list in + let h = sbuild h o_list in + let h = typing_contract h contract in + + let h = build h eq_list in + typing_eqs h eq_list + +let program ({ p_nodes = p_node_list } as p) = + List.iter typing_node p_node_list; + p + + diff --git a/minils/transformations/normalize.ml b/minils/transformations/normalize.ml new file mode 100644 index 0000000..11e6d74 --- /dev/null +++ b/minils/transformations/normalize.ml @@ -0,0 +1,261 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* $Id$ *) + +open Misc +open Names +open Ident +open Global +open Minils + +let ctrue = Name("true") +and cfalse = Name("false") + +let equation (d_list, eq_list) ({ e_ty = te; e_linearity = l; e_ck = ck } as e) = + let n = Ident.fresh "_v" in + let d_list = { v_name = n; v_copy_of = None; + v_type = base_type te; v_linearity = l; v_clock = ck } :: d_list + and eq_list = { p_lhs = Evarpat(n); p_rhs = e } :: eq_list in + (d_list, eq_list), n + +let intro context e = + match e.e_desc with + Evar(n) -> context, n + | _ -> equation context e + +(* distribution: [(e1,...,ek) when C(n) = (e1 when C(n),...,ek when C(n))] *) +let rec whenc context e c n = + let when_on_c c n e = + { e with e_desc = Ewhen(e, c, n); e_ck = Con(e.e_ck, c, n) } in + + match e.e_desc with + | Etuple(e_list) -> + let context, e_list = + List.fold_right + (fun e (context, e_list) -> let context, e = whenc context e c n in + (context, e :: e_list)) + e_list (context, []) in + context, { e with e_desc = Etuple(e_list); e_ck = Con(e.e_ck, c, n) } + (* | Emerge _ -> let context, x = equation context e in + context, when_on_c c n { e with e_desc = Evar(x) } *) + | _ -> context, when_on_c c n e + +(* transforms [merge x (c1, (e11,...,e1n));...;(ck, (ek1,...,ekn))] into *) +(* [merge x (c1, e11)...(ck, ek1),..., merge x (c1, e1n)...(ck, ekn)] *) +let rec merge e x ci_a_list = + let rec split ci_tas_list = + match ci_tas_list with + | [] | (_, _, []) :: _ -> [], [] + | (ci, b, a :: tas) :: ci_tas_list -> + let ci_ta_list, ci_tas_list = split ci_tas_list in + (ci, a) :: ci_ta_list, (ci, b, tas) :: ci_tas_list in + let rec distribute ci_tas_list = + match ci_tas_list with + | [] | (_, _, []) :: _ -> [] + | (ci, b, (eo :: _)) :: _ -> + let ci_ta_list, ci_tas_list = split ci_tas_list in + let ci_tas_list = distribute ci_tas_list in + (if b then + { eo with e_desc = Emerge(x, ci_ta_list); + e_ck = e.e_ck; e_loc = e.e_loc } + else + merge e x ci_ta_list) + :: ci_tas_list in + let rec erasetuple ci_a_list = + match ci_a_list with + | [] -> [] + | (ci, { e_desc = Etuple(l) }) :: ci_a_list -> + (ci, false, l) :: erasetuple ci_a_list + | (ci, e) :: ci_a_list -> + (ci, true, [e]) :: erasetuple ci_a_list in + let ci_tas_list = erasetuple ci_a_list in + let ci_tas_list = distribute ci_tas_list in + match ci_tas_list with + | [e] -> e + | l -> { e with e_desc = Etuple(l) } + +let ifthenelse context e1 e2 e3 = + let context, n = intro context e1 in + let context, e2 = whenc context e2 ctrue n in + let context, e3 = whenc context e3 cfalse n in + context, merge e1 n [ctrue, e2; cfalse, e3] + +let const e c = + let rec const = function + | Cbase | Cvar { contents = Cindex _ } -> c + | Con(ck_on, tag, x) -> + Ewhen({ e with e_desc = const ck_on; e_ck = ck_on }, tag, x) + | Cvar { contents = Clink ck } -> const ck in + const e.e_ck + +(* normal form for expressions and equations: *) +(* - e ::= op(e,...,e) | x | C | e when C(x) *) +(* - act ::= e | merge x (C1 -> act) ... (Cn -> act) | (act,...,act) *) +(* - eq ::= [x = v fby e] | [pat = act ] | [pat = f(e1,...,en) every n *) +(* - A-normal form: (e1,...,en) when c(x) = (e1 when c(x),...,en when c(x) *) +type kind = VRefCond | VRef | Exp | Act | Any + +let function_args_kind = if !no_mem_alloc then Exp else VRefCond +let merge_kind = if !no_mem_alloc then Act else VRef + +let rec constant e = match e.e_desc with + | Econst _ | Econstvar _ -> true + | Ewhen(e, _, _) -> constant e + | Evar _ -> true + | _ -> false + +let add context expected_kind ({ e_desc = de; e_linearity = l } as e) = + let up = match de, expected_kind with + | (Evar _ | Efield _ ) , VRefCond -> false + | Efby _, VRefCond -> true + | _ , VRefCond -> not (Linearity.is_not_linear l) + | (Evar _ | Efield _ ) , VRef -> false + | _ , VRef -> true + | ( Emerge _ | Etuple _ + | Eapp _ | Eevery _ | Efby _ | Eselect_dyn _ + | Eupdate _ | Econcat _ | Erepeat _ | Eiterator _ + | Eselect_slice _ ), Exp -> true + | ( Eapp _ | Eevery _ | Efby _ ), Act -> true + | _ -> false in + if up then + let context, n = equation context e in + context, { e with e_desc = Evar(n) } + else context, e + +let rec translate kind context e = + let context, e = match e.e_desc with + | Emerge(n, tag_e_list) -> + let context, ta_list = + List.fold_right + (fun (tag, e) (context, ta_list) -> + let context, act = translate merge_kind context e in + context, ((tag, act) :: ta_list)) + tag_e_list (context, []) in + context, merge e n ta_list + | Eifthenelse(e1, e2, e3) -> + let context, e1 = translate Any context e1 in + let context, e2 = translate Act context e2 in + let context, e3 = translate Act context e3 in + ifthenelse context e1 e2 e3 + | Etuple(e_list) -> + let context, e_list = translate_list kind context e_list in + context, { e with e_desc = Etuple(e_list) } + | Ewhen(e1, c, n) -> + let context, e1 = translate kind context e1 in + whenc context e1 c n + | Eop(op, params, e_list) -> + let context, e_list = translate_list function_args_kind context e_list in + context, { e with e_desc = Eop(op, params, e_list) } + | Eapp(app, params, e_list) -> + let context, e_list = translate_list function_args_kind context e_list in + context, { e with e_desc = Eapp(app, params, e_list) } + | Eevery(app, params, e_list, n) -> + let context, e_list = translate_list function_args_kind context e_list in + context, { e with e_desc = Eevery(app, params, e_list, n) } + | Efby(v, e1) -> + let context, e1 = translate Exp context e1 in + let context, e1' = + if constant e1 then context, e1 + else let context, n = equation context e1 in + context, { e1 with e_desc = Evar(n) } in + context, { e with e_desc = Efby(v, e1') } + | Ereset_mem (_, _, _) -> context, e + | Evar _ -> context, e + | Econst(c) -> context, { e with e_desc = const e (Econst c) } + | Econstvar x -> context, { e with e_desc = const e (Econstvar x) } + | Efield(e', field) -> + let context, e' = translate Exp context e' in + context, { e with e_desc = Efield(e', field) } + | Estruct(l) -> + let context, l = + List.fold_right + (fun (field, e) (context, field_desc_list) -> + let context, e = translate Exp context e in + context, ((field, e) :: field_desc_list)) + l (context, []) in + context, { e with e_desc = Estruct(l) } +(*Array operators*) + | Earray(e_list) -> + let context, e_list = translate_list kind context e_list in + context, { e with e_desc = Earray(e_list) } + | Erepeat (n,e') -> + let context, e' = translate VRef context e' in + context, { e with e_desc = Erepeat(n, e') } + | Eselect (idx,e') -> + let context, e' = translate VRef context e' in + context, { e with e_desc = Eselect(idx, e') } + | Eselect_dyn (idx, bounds, e1, e2) -> + let context, e1 = translate VRef context e1 in + let context, idx = translate_list Exp context idx in + let context, e2 = translate Exp context e2 in + context, { e with e_desc = Eselect_dyn(idx, bounds, e1, e2) } + | Eupdate (idx, e1, e2) -> + let context, e1 = translate VRef context e1 in + let context, e2 = translate Exp context e2 in + context, { e with e_desc = Eupdate(idx, e1, e2) } + | Eselect_slice (idx1, idx2, e') -> + let context, e' = translate VRef context e' in + context, { e with e_desc = Eselect_slice(idx1, idx2, e') } + | Econcat (e1, e2) -> + let context, e1 = translate VRef context e1 in + let context, e2 = translate VRef context e2 in + context, { e with e_desc = Econcat(e1, e2) } + | Eiterator (it, f, params, n, e_list, reset) -> + let context, e_list = translate_list function_args_kind context e_list in + context, { e with e_desc = Eiterator(it, f, params, n, e_list, reset) } + | Efield_update (f, e1, e2) -> + let context, e1 = translate VRef context e1 in + let context, e2 = translate Exp context e2 in + context, { e with e_desc = Efield_update(f, e1, e2) } + in add context kind e + +and translate_list kind context e_list = + match e_list with + [] -> context, [] + | e :: e_list -> + let context, e = translate kind context e in + let context, e_list = translate_list kind context e_list in + context, e :: e_list + +let rec translate_eq context pat e = + (* applies distribution rules *) + (* [x = v fby e] should verifies that x is local *) + (* [(p1,...,pn) = (e1,...,en)] into [p1 = e1;...;pn = en] *) + let rec distribute ((d_list, eq_list) as context) pat e = + match pat, e.e_desc with + | Evarpat(x), Efby _ when not (vd_mem x d_list) -> + let (d_list, eq_list), n = equation context e in + d_list, + { p_lhs = pat; p_rhs = { e with e_desc = Evar(n) } } :: eq_list + | Etuplepat(pat_list), Etuple(e_list) -> + List.fold_left2 distribute context pat_list e_list + | _ -> d_list, { p_lhs = pat; p_rhs = e } :: eq_list in + + let context, e = translate Any context e in + distribute context pat e + +let translate_eq_list d_list eq_list = + List.fold_left + (fun context { p_lhs = pat; p_rhs = e } -> translate_eq context pat e) + (d_list, []) eq_list + +let translate_contract ({ c_eq = eq_list; c_local = d_list } as c) = + let d_list,eq_list = translate_eq_list d_list eq_list in + { c with + c_local = d_list; + c_eq = eq_list } + +let translate_node ({ n_contract = contract; + n_local = d_list; n_equs = eq_list } as node) = + let contract = optional translate_contract contract in + let d_list, eq_list = translate_eq_list d_list eq_list in + { node with n_contract = contract; n_local = d_list; n_equs = eq_list } + +let program ({ p_nodes = p_node_list } as p) = + { p with p_nodes = List.map translate_node p_node_list } diff --git a/minils/transformations/schedule.ml b/minils/transformations/schedule.ml new file mode 100644 index 0000000..ad5537b --- /dev/null +++ b/minils/transformations/schedule.ml @@ -0,0 +1,86 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* scheduling of equations *) + +(* $Id$ *) + +open Misc +open Minils +open Graph +open Dep + +(* possible overlapping between clocks *) +let join ck1 ck2 = + let n1 = Vars.head ck1 + and n2 = Vars.head ck2 in + (* C1(x1) on ... on Cn(xn) with C'1(x'1) on ... on C'k(x'k) *) + match n1, n2 with + [], [] -> true + | x1 ::_, x2 ::_ when x1 = x2 -> true + | _ -> false + +let join eq1 eq2 = join (Vars.clock eq1) (Vars.clock eq2) + +(* possible overlapping between nodes *) +(*let head e = + match e with + | Emerge(_, c_e_list) -> List.fold (fun acc e -> Vars.head (clock e) :: acc) + | e -> [Vars.head (clock e)] + +(* e1 define a pieces of control structures with *) + (* paths on clock C1(x1) on ... on Cn(xn) ... *) + (* e1 can be merged if *) +let n1_list = head e1 in + let n2_list = head e2 in +*) + + +(* clever scheduling *) +let schedule eq_list = + let rec recook = function + | [] -> [] + | node :: node_list -> node >> (recook node_list) + + and (>>) node node_list = + try + insert node node_list + with + Not_found -> node :: node_list + + and insert node = function + | [] -> raise Not_found + | node1 :: node_list -> + if linked node node1 then raise Not_found + else + try + node1 :: (insert node node_list) + with + | Not_found -> + if join (containt node) (containt node1) + then node :: node1 :: node_list + else raise Not_found in + + let node_list, _ = DataFlowDep.build eq_list in + let node_list = recook (topological node_list) in + let node_list = List.rev node_list in + let node_list = recook node_list in + let node_list = List.rev node_list in + List.map containt node_list + +let schedule_contract ({ c_eq = eqs } as c) = + let eqs = schedule eqs in + { c with c_eq = eqs } + +let node ({ n_contract = contract; n_equs = eq_list } as node) = + let contract = optional schedule_contract contract in + let eq_list = schedule eq_list in + { node with n_equs = eq_list; n_contract = contract } + +let program ({ p_nodes = p_node_list } as p) = + { p with p_nodes = List.map node p_node_list } diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 0000000..4806e8b --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,26 @@ +open Ocamlbuild_plugin +open Ocamlbuild_plugin.Options + +let sub_dirs = ["global"; "parsing"; "sigali"; "dataflow"; "sequential"; + "analysis"; "translation"; "main"; "simulation"] + +let df = function + | Before_options -> + include_dirs := sub_dirs @ !include_dirs + | After_rules -> + (* Tell ocamlbuild about the camlp4 library. *) + ocaml_lib ~extern:true ~dir:"+camlp4" "camlp4"; + + (* Add preproc.cmo to the ocaml pre-processor when use_preproc is set *) + flag ["ocaml"; "pp"; "use_preproc"] (A "preproc.cmo"); + (* Running ocamldep on ocaml code that is tagged with use_preproc will + require the cmo. Note that you only need this declaration when the + syntax extension is part of the sources to be compiled with + ocamlbuild. *) + dep ["ocaml"; "ocamldep"; "use_preproc"] ["preproc.cmo"]; + + (* LablGTK use for graphical simulator *) + ocaml_lib ~extern:true ~dir:"+lablgtk2" "lablgtk" + | _ -> () + +let _ = dispatch df diff --git a/utilities/dep.ml b/utilities/dep.ml new file mode 100644 index 0000000..e5ea1d7 --- /dev/null +++ b/utilities/dep.ml @@ -0,0 +1,80 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* dependences between equations *) +(* $Id$ *) + +open Graph +open Ident + +module type READ = +sig + type equation + val read: equation -> ident list + val def: ident list -> equation -> ident list + val linear_read : equation -> ident list + val antidep: equation -> bool + val mem_reset : equation -> ident list +end + +module Make (Read:READ) = +struct + let build eqs = + (* associate a graph node for each name declaration *) + let rec nametograph g var_list is_antidep n_to_graph = + let add_node env x = + if Env.mem x env then + let l = Env.find x env in + Env.add x ((g, is_antidep)::l) env + else + Env.add x [(g, is_antidep)] env + in + List.fold_left add_node n_to_graph var_list in + + let rec nametograph_env g var_list node_env = + List.fold_left (fun env x -> Env.add x g env) node_env var_list in + + let rec init_graph eqs g_list n_to_graph node_env = + match eqs with + | [] -> g_list, n_to_graph, node_env + | eq :: eqs -> + let g = make eq in + let node_env = nametograph_env g (Read.def [] eq) node_env in + let n_to_graph = nametograph g (Read.def [] eq) (Read.antidep eq) n_to_graph in + let n_to_graph = nametograph g (Read.linear_read eq) true n_to_graph in + let n_to_graph = nametograph g (Read.mem_reset eq) false n_to_graph in + init_graph eqs (g :: g_list) n_to_graph node_env + in + + let rec make_graph g_list names_to_graph = + let attach_one node (g, is_antidep) = + if is_antidep then + add_depends g node + else + add_depends node g + in + + let attach node n = + try + let l = Env.find n names_to_graph in + List.iter (attach_one node) l + with + | Not_found -> () in + + match g_list with + | [] -> () + | node :: g_list -> + let names = Read.read (containt node) in + List.iter (attach node) names; + make_graph g_list names_to_graph in + + let g_list, names_to_graph, node_env = init_graph eqs [] Env.empty Env.empty in + make_graph g_list names_to_graph; + g_list, node_env +end + diff --git a/utilities/graph.ml b/utilities/graph.ml new file mode 100644 index 0000000..66608b0 --- /dev/null +++ b/utilities/graph.ml @@ -0,0 +1,143 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* graph manipulation *) +(* $Id$ *) +type 'a graph = + { g_top: 'a node list; + g_bot: 'a node list } + +and 'a node = + { g_containt: 'a; + g_tag: int; + mutable g_visited: bool; + mutable g_mark: int; + mutable g_depends_on: 'a node list; + mutable g_depends_by: 'a node list; + } + +exception Cycle of int (* returns the index of the node *) + +let tag = ref 0 +let new_tag () = incr tag; !tag +let containt g = g.g_containt +let linked g1 g2 = + (List.memq g2 g1.g_depends_on) or (List.memq g1 g2.g_depends_on) +let make c = + { g_containt = c; g_tag = new_tag (); g_visited = false; + g_mark = -1; g_depends_on = []; g_depends_by = [] } +let add_depends node1 node2 = + if not (node1.g_tag = node2.g_tag or linked node1 node2) then ( + node1.g_depends_on <- node2 :: node1.g_depends_on; + node2.g_depends_by <- node1 :: node2.g_depends_by + ) + +let remove_depends node1 node2 = + if not (node1.g_tag = node2.g_tag) then ( + node1.g_depends_on <- List.filter (fun n -> n.g_tag <> node2.g_tag) node1.g_depends_on; + node2.g_depends_by <- List.filter (fun n -> n.g_tag <> node1.g_tag) node2.g_depends_by + ) + +let graph top_list bot_list = { g_top = top_list; g_bot = bot_list } + + +let topological g_list = + let rec sortrec g_list seq = + match g_list with + | [] -> seq + | g :: g_list -> + if g.g_visited then sortrec g_list seq + else + begin + g.g_visited <- true; + let seq = sortrec g.g_depends_on seq in + sortrec g_list (g :: seq) + end in + let seq = sortrec g_list [] in + List.iter + (fun ({ g_visited = _ } as node) -> node.g_visited <- false) g_list; + List.rev seq + +(** Detection of cycles *) +(* Mark nodes with: + - -1 initially, for unvisited nodes + - 0 for "opened" nodes, currently visited, while visiting its descendents + - 1 for "closed" nodes, visited once, no circuits found from it. + A circuit is found when a node marked with 0 is visited again. +*) + +let cycle g_list = + (* store nodes in a stack *) + let s = Stack.create () in + (* flush the connected component *) + let rec flush index = + if Stack.is_empty s then [] + else let v = Stack.pop s in + v.g_containt :: flush v.g_tag in + + let rec visit g = + match g.g_mark with + | -1 -> + (* Unvisited yet *) + (* Open node *) + Stack.push g s; + g.g_mark <- 0; + (* Visit descendents *) + List.iter visit g.g_depends_on; + (* Close node *) + ignore (Stack.pop s); + g.g_mark <- 1 + | 0 -> + (* Visit an opened node (visited and not close) : circuit *) + raise (Cycle g.g_tag) + | 1 | _ -> + (* Visit a closed node (no existing circuit) : pass *) + () in + try + List.iter visit g_list; None + with + | Cycle(index) -> Some(flush index) + +(** [accessible useful_nodes g_list] returns the list of + accessible nodes starting from useful_nodes and belonging to + g_list. *) +let accessible useful_nodes g_list = + let rec follow g = + if not g.g_visited then + begin + g.g_visited <- true; + List.iter follow g.g_depends_on + end in + let read acc g = + if g.g_visited then begin g.g_visited <- false; g :: acc end else acc in + List.iter follow useful_nodes; + List.fold_left read [] g_list + +(** [exists_path nodes n1 n2] returns whether there is a path + from n1 to n2 in the graph. nodes is the list of all the nodes + in the graph. *) +let exists_path nodes n1 n2 = + List.mem n2 (accessible [n1] nodes) + +open Format + +let print_node print g = + printf "Node : @["; + print_int g.g_tag; + printf "@]"; + printf " Depends on :@\n"; + printf " @["; + List.iter + (fun node -> + printf "@["; + print_int node.g_tag; + printf "@]@ ") + g.g_depends_on; + printf "@]" + + diff --git a/utilities/misc.ml b/utilities/misc.ml new file mode 100644 index 0000000..9d6438b --- /dev/null +++ b/utilities/misc.ml @@ -0,0 +1,204 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* useful stuff *) +(* $Id$ *) + +(* version of the compiler *) +let version = "0.4" +let interface_format_version = "5" +let date = "DATE" + +(* standard module *) +let pervasives_module = "Pervasives" +let standard_lib = "STDLIB" +let standard_lib = try Sys.getenv "HEPTLIB" with Not_found -> standard_lib + +(* list of modules initially opened *) +let default_used_modules = ref [pervasives_module] +let set_no_pervasives () = default_used_modules := [] + +(* load paths *) +let load_path = ref ([standard_lib]) + +let set_stdlib p = + load_path := [p] +and add_include d = + load_path := d :: !load_path;; + +(* where is the standard library *) +let locate_stdlib () = + let stdlib = try + Sys.getenv "HEPTLIB" + with + Not_found -> standard_lib in + Printf.printf "Standard library in %s\n" stdlib + +let show_version () = + Printf.printf "The Heptagon compiler, version %s (%s)\n" + version date; + locate_stdlib () + +(* other options of the compiler *) +let verbose = ref false +let print_types = ref false + +let simulation = ref false +let simulation_node : string option ref = ref None +let set_simulation_node s = + simulation := true; + simulation_node := Some s + +(* Target languages list for code generation *) +let target_languages : string list ref = ref [] + +let add_target_language s = + target_languages := s :: !target_languages + +(* Optional path for generated files (C or Java) *) +let target_path : string option ref = ref None + +let set_target_path path = + target_path := Some path + +let full_type_info = ref false + +let boolean = ref false + +let deadcode = ref false + +let init = ref true + +let cse = ref false + +let tomato = ref false + +(* Backward compatibility *) +let set_sigali () = add_target_language "z3z";; + +let intermediate = ref false + +let nodes_to_inline : string list ref = ref [] + +let nodes_to_display : string list ref = ref [] + +let node_to_flatten : string option ref = ref None + +let no_mem_alloc = ref false + +let use_interf_scheduler = ref false + +let use_new_reset_encoding = ref false + +let optional f = function + | None -> None + | Some x -> Some (f x) + +let optunit f = function + | None -> () + | Some x -> f x + +(** [split_string s c] splits the string [s] in a list of sub-strings according + to separator [c]. *) +let rec split_string s c = + try + let id = String.index s c in + let rest = String.sub s (id + 1) (String.length s - id - 1) in + String.sub s 0 id :: split_string rest c + with Not_found -> [s] + +(* error during the whole process *) +exception Error + +(* creation of names. Ensure unicity for the whole compilation chain *) +let symbol = ref 0 + +let gen_symbol () = incr symbol; "_"^(string_of_int !symbol) +let reset_symbol () = symbol := (*!min_symbol*) 0 + +open Format +open Unix + +let print_header_info ff cbeg cend = + let tm = Unix.localtime (Unix.time ()) in + fprintf ff "%s --- Generated the %d/%d/%d at %d:%d --- %s@\n" + cbeg tm.tm_mday (tm.tm_mon+1) (tm.tm_year + 1900) tm.tm_hour tm.tm_min cend; + fprintf ff "%s --- heptagon compiler, version %s (compiled %s) --- %s@\n" + cbeg version date cend; + fprintf ff "%s --- Command line: %a--- %s@\n@\n" + cbeg + (fun ff a -> + Array.iter (fun arg -> fprintf ff "%s " arg) a) + Sys.argv + cend + +let unique l = + let tbl = Hashtbl.create 10 in (* You could replace 10 with List.length l *) + List.iter (fun i -> Hashtbl.replace tbl i ()) l; + Hashtbl.fold (fun key data accu -> key :: accu) tbl [] + +type iterator_name = + Imap + | Ifold + | Imapfold + +let iterator_to_string i = + match i with + | Imap -> "map" + | Ifold -> "fold" + | Imapfold -> "mapfold" + +let rec incomplete_map f l = + match l with + | [] -> [] + | [a] -> [a] + | a::l -> (f a)::(incomplete_map f l) + +let rec last_element l = + match l with + | [] -> assert false + | [v] -> v + | v::l -> last_element l + +(** [split_last l] returns l without its last element and + the last element of l. *) +let rec split_last = function + | [] -> assert false + | [a] -> [], a + | v::l -> + let l, a = split_last l in + v::l, a + +let remove x l = + List.filter (fun y -> x <> y) l + +let is_empty = function + | [] -> true + | _ -> false + +(** [repeat_list v n] returns a list with n times the value v. *) +let repeat_list v n = + let rec aux = function + | 0 -> [] + | n -> v::(aux (n-1)) + in + aux n + +(** Same as List.mem_assoc but using the value instead of the key. *) +let rec memd_assoc value = function + | [] -> false + | (k,d)::l -> (d = value) or (memd_assoc value l) + +(** Same as List.assoc but searching for a data and returning the key. *) +let rec assocd value = function + | [] -> raise Not_found + | (k,d)::l -> + if d = value then + k + else + assocd value l diff --git a/utilities/misc.mli b/utilities/misc.mli new file mode 100644 index 0000000..1c8f22c --- /dev/null +++ b/utilities/misc.mli @@ -0,0 +1,158 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id$ *) + +(* Version and date of compilation *) +val version : string +val interface_format_version: string +val date : string + +(* List of modules initially opened *) +val default_used_modules : string list ref + +(* Void the list of modules initially opened *) +val set_no_pervasives : unit -> unit + +(* Path list to libraries *) +val load_path : string list ref + +(* Set path to standard library *) +val set_stdlib : string -> unit + +(* Add path to libraries *) +val add_include : string -> unit + +(* Print the path to standard library *) +val locate_stdlib : unit -> unit + +(* Print the compiler version and its compilation date *) +val show_version : unit -> unit + +(* Verbose option *) +val verbose : bool ref + +(* Print types option *) +val print_types : bool ref + +(* Simulation mode *) +val simulation : bool ref +(* Simulated node *) +val simulation_node : string option ref +(* Set the simulation mode on *) +val set_simulation_node : string -> unit + +(* List of target languages *) +val target_languages : string list ref +(* Add target language to the list *) +val add_target_language : string -> unit + +(* Optional path for generated files (C or Java) *) +val target_path : string option ref +(* Set the optional target path *) +val set_target_path : string -> unit + +(* Print full type information when pretty-printing MiniLS code. *) +val full_type_info : bool ref + +(* Boolean transformation of enumerated types *) +val boolean : bool ref + +(* Deadcode removal *) +val deadcode : bool ref + +(* Initialization analysis (enabled by default) *) +val init : bool ref + +(* Common sub-expression elimination *) +val cse : bool ref + +(* Automata minimization *) +val tomato : bool ref + +(* Z/3Z back-end mode *) +val set_sigali : unit -> unit + +(* Intermediate-equations removal *) +val intermediate : bool ref + +(* Nodes to be inlined *) +val nodes_to_inline : string list ref + +(* Nodes which dependency graphics will be serialized to .dot file. *) +val nodes_to_display : string list ref + +(* Node to flatten *) +val node_to_flatten : string option ref + +(* Disable the memory allocation phase*) +val no_mem_alloc : bool ref + +(* Whether to use the interference aware scheduler*) +val use_interf_scheduler : bool ref + +(* Use the new encoding of resets using reset_mem. *) +val use_new_reset_encoding : bool ref + +(* Misc. functions *) +val optional : ('a -> 'b) -> 'a option -> 'b option +val optunit : ('a -> unit) -> 'a option -> unit +val split_string : string -> char -> string list + +(* Printing header informations (compiler version, generation date...) *) +(* [print_header_info ff cbeg cend] prints header info, where [ff] is + the formatter used, [cbeg] and [cend] the string of begin and end + of commentaries in the target language *) +val print_header_info : Format.formatter -> string -> string -> unit + +(* Error during the whole process *) +exception Error + +(* Generation of unique names. Mandatory call of reset_symbol between + set_min_symbol and gen_symbol *) +(*val set_min_symbol : int -> unit*) +val gen_symbol : unit -> string +val reset_symbol : unit -> unit + +type iterator_name = + Imap + | Ifold + | Imapfold + +val iterator_to_string : iterator_name -> string + +(** [unique l] returns the [l] list without duplicates. O([length l]). *) +val unique : 'a list -> 'a list + +(** [incomplete_map f l] applies f to all the elements of + l except the last element. *) +val incomplete_map : ('a -> 'a) -> 'a list -> 'a list + +(** [last_element l] returns the last element of the list l.*) +val last_element : 'a list -> 'a + +(** [split_last l] returns the list l without its last element + and the last element of the list .*) +val split_last : 'a list -> ('a list * 'a) + +(** [remove x l] removes all occurrences of x from list l.*) +val remove : 'a -> 'a list -> 'a list + +(** [is_empty l] returns whether the list l is empty.*) +val is_empty : 'a list -> bool + +(** [repeat_list v n] returns a list with n times the value v. *) +val repeat_list : 'a -> int -> 'a list + +(** Same as List.mem_assoc but using the value instead of the key. *) +val memd_assoc : 'b -> ('a * 'b) list -> bool + +(** Same as List.assoc but searching for a data and returning the key. *) +val assocd: 'b -> ('a * 'b) list -> 'a +