jeltz/heptagon
1
0
Fork 0
Code Issues Pull requests Releases Activity

Merge branch 'qualified_ast'

Browse source 
Conflicts:
	compiler/obc/c/cgen.ml
This commit is contained in:
Léonard Gérard 2010-09-13 12:50:10 +02:00
commit 3a0429f93f
130 changed files with 9473 additions and 5766 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
.gitignore vendored
View file

@ -8,7 +8,18 @@ _build
*.cmx
*.annot
*.byte
*.native
*.depend
*.swp
.settings
\#*\#
*.mls
*.obc
*.c
*.h
*.o
*.
*.epci
*.epo
*.dot
test/*.ml

2
compiler/_tags
View file

@ -1,4 +1,4 @@
<global> or <utilities> or <minils> or <heptagon> or <main>:include
<global> or <utilities> or <minils> or <heptagon> or <main> or <obc>:include
<**/*.ml>: debug, dtypes
<preproc.ml>: camlp4of, use_camlp4
<**/hept_parser.ml>: use_menhirLib

106
compiler/global/clocks.ml Normal file
View file

@ -0,0 +1,106 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
open Names
open Idents
open Types
type ct =
| Ck of ck
| Cprod of ct list
and ck =
| Cbase
| Cvar of link ref
| Con of ck * constructor_name * var_ident
and link =
| Cindex of int
| Clink of ck
exception Unify
let index = ref 0
let gen_index () = (incr index; !index)
(** returns a new clock variable *)
let new_var () = Cvar { contents = Cindex (gen_index ()); }
(** returns the canonic (short) representant of a [ck]
and update it to this value. *)
let rec ck_repr ck = match ck with
| Cbase | Con _ | Cvar { contents = Cindex _ } -> ck
| Cvar (({ contents = Clink ck } as link)) ->
let ck = ck_repr ck in (link.contents <- Clink ck; ck)
(** verifies that index is fresh in ck. *)
let rec occur_check index ck =
let ck = 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 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) ->
(try List.iter2 unify ct_list1 ct_list2 with | _ -> raise Unify)
| _ -> raise Unify)
and unify_ck ck1 ck2 =
let ck1 = ck_repr ck1 in
let ck2 = ck_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 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 ->
(match ty_list with
| [] -> Format.eprintf "Warning, an exp with void type@."; Ck ck
| _ -> Cprod (List.map (skeleton ck) ty_list))
| Tarray _ | Tid _ -> Ck ck
let ckofct = function | Ck ck -> ck_repr ck | Cprod ct_list -> Cbase

151
compiler/global/global_mapfold.ml Normal file
View file

@ -0,0 +1,151 @@
open Misc
open Types
(*open Clocks*)
open Signature
type 'a global_it_funs = {
static_exp :
'a global_it_funs -> 'a -> static_exp -> static_exp * 'a;
static_exp_desc :
'a global_it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a;
ty : 'a global_it_funs -> 'a -> ty -> ty * 'a;
(* ct : 'a global_it_funs -> 'a -> ct -> ct * 'a;
ck : 'a global_it_funs -> 'a -> ck -> ck * 'a;
link : 'a global_it_funs -> 'a -> link -> link * 'a; *)
param: 'a global_it_funs -> 'a -> param -> param * 'a;
arg: 'a global_it_funs -> 'a -> arg -> arg * 'a;
node : 'a global_it_funs -> 'a -> node -> node * 'a;
structure: 'a global_it_funs -> 'a -> structure -> structure * 'a;
field: 'a global_it_funs -> 'a -> field -> field * 'a; }
let rec static_exp_it funs acc se = funs.static_exp funs acc se
and static_exp funs acc se =
let se_ty, acc = ty_it funs acc se.se_ty in
let se_desc, acc = static_exp_desc_it funs acc se.se_desc in
{ se with se_desc = se_desc; se_ty = se_ty }, acc
and static_exp_desc_it funs acc sd =
try funs.static_exp_desc funs acc sd
with Fallback -> static_exp_desc funs acc sd
and static_exp_desc funs acc sd = match sd with
| Svar _ | Sint _ | Sfloat _ | Sbool _ | Sconstructor _ | Sfield _ -> sd, acc
| Stuple se_l ->
let se_l, acc = mapfold (static_exp_it funs) acc se_l in
Stuple se_l, acc
| Sarray se_l ->
let se_l, acc = mapfold (static_exp_it funs) acc se_l in
Sarray se_l, acc
| Sop (n, se_l) ->
let se_l, acc = mapfold (static_exp_it funs) acc se_l in
Sop (n, se_l), acc
| Sarray_power (se1, se2) ->
let se1, acc = static_exp_it funs acc se1 in
let se2, acc = static_exp_it funs acc se2 in
Sarray_power(se1, se2), acc
| Srecord f_se_l ->
let aux acc (f,se) = let se,acc = static_exp_it funs acc se in
(f, se), acc in
let f_se_l, acc = mapfold aux acc f_se_l in
Srecord f_se_l, acc
and ty_it funs acc t = try funs.ty funs acc t with Fallback -> ty funs acc t
and ty funs acc t = match t with
| Tid _ -> t, acc
| Tprod t_l -> let t_l, acc = mapfold (ty_it funs) acc t_l in Tprod t_l, acc
| Tarray (t, se) ->
let t, acc = ty_it funs acc t in
let se, acc = static_exp_it funs acc se in
Tarray (t, se), acc
(*
and ct_it funs acc c = try funs.ct funs acc c with Fallback -> ct funs acc t
and ct funs acc c = match c with
| Ck(ck) -> let ck, acc = ck_it funs acc ck in Ck ck, acc
| Cprod(ct_l) ->
let ct_l, acc = mapfold (ct_it funs) acc ct_l in Cprod ct_l, acc
and ck_it funs acc c = try funs.ck funs acc c with Fallback -> ck funs acc c
and ck funs acc c = match c with
| Cbase -> c, acc
| Cvar(link_ref) ->
let l, acc = link_it funs acc link_ref.contents in
Cvar {link_ref with contents = l}, acc
| Con(ck, constructor_name, var_ident) ->
let ck, acc = ck_it funs acc ck in
Con (ck, constructor_name, var_ident), acc
and link_it funs acc c =
try funs.link funs acc c with Fallback -> link funs acc c
and link funs acc l = match l with
| Cindex _ -> l, acc
| Clink(ck) -> let ck, acc = ck_it funs acc ck in Clink ck, acc
*)
and structure_it funs acc s = funs.structure funs acc s
and structure funs acc s =
mapfold (field_it funs) acc s
and field_it funs acc f = funs.field funs acc f
and field funs acc f =
let ty, acc = ty_it funs acc f.f_type in
{ f with f_type = ty }, acc
and param_it funs acc p = funs.param funs acc p
and param funs acc p =
let p_type, acc = ty_it funs acc p.p_type in
{ p with p_type = p_type }, acc
and arg_it funs acc a = funs.arg funs acc a
and arg funs acc a =
let a_type, acc = ty_it funs acc a.a_type in
{ a with a_type = a_type }, acc
and node_it funs acc n = funs.node funs acc n
and node funs acc n =
let node_params, acc = mapfold (param_it funs) acc n.node_params in
let node_inputs, acc = mapfold (arg_it funs) acc n.node_inputs in
let node_outputs, acc = mapfold (arg_it funs) acc n.node_outputs in
{ n with node_params = node_params;
node_inputs = node_inputs;
node_outputs = node_outputs }, acc
let defaults = {
static_exp = static_exp;
static_exp_desc = static_exp_desc;
ty = ty;
structure = structure;
field = field;
param = param;
arg = arg;
node = node;
}
(** Is used to stop the pass at this level *)
let stop funs acc x = x, acc
let defaults_stop = {
static_exp = stop;
static_exp_desc = stop;
ty = stop;
structure = stop;
field = stop;
param = stop;
arg = stop;
node = stop;
}
(** [it_gather gather f] will create a function to iterate
over a type using [f] and then use [gather] to combine
the value of the local accumulator with the one
given as argument. *)
let it_gather gather f funs acc e =
let e, new_acc = f funs acc e in
e, gather acc new_acc

109
compiler/global/global_printer.ml Normal file
View file

@ -0,0 +1,109 @@
open Names
open Signature
open Types
open Clocks
open Modules
open Format
open Pp_tools
let print_qualname ff qn = match qn with
| { qual = "Pervasives"; name = n } -> print_name ff n
| { qual = m; name = n } when m = g_env.current_mod -> print_name ff n
| { qual = m; name = n } when m = local_qualname -> print_name ff n
| { qual = m; name = n } -> fprintf ff "%s.%a" m print_name n
let rec print_static_exp ff se = match se.se_desc with
| Sint i -> fprintf ff "%d" i
| Sbool b -> fprintf ff "%b" b
| Sfloat f -> fprintf ff "%f" f
| Sconstructor ln -> print_qualname ff ln
| Sfield ln -> print_qualname ff ln
| Svar id -> fprintf ff "%a" print_qualname id
| Sop (op, se_list) ->
if is_infix (shortname op)
then
let op_s = opname op ^ " " in
fprintf ff "@[%a@]"
(print_list_l print_static_exp "(" op_s ")") se_list
else
fprintf ff "@[<2>%a@,%a@]"
print_qualname op print_static_exp_tuple se_list
| Sarray_power (se, n) ->
fprintf ff "%a^%a" print_static_exp se print_static_exp n
| Sarray se_list ->
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "["";""]") se_list
| Stuple se_list -> print_static_exp_tuple ff se_list
| Srecord f_se_list ->
print_record (print_couple print_qualname
print_static_exp """ = """) ff f_se_list
and print_static_exp_tuple ff l =
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l
and print_type ff = function
| Tprod ty_list ->
fprintf ff "@[<hov2>%a@]" (print_list_r print_type "(" " *" ")") ty_list
| Tid id -> print_qualname ff id
| Tarray (ty, n) ->
fprintf ff "@[<hov2>%a^%a@]" print_type ty print_static_exp n
let print_field ff field =
fprintf ff "@[%a: %a@]" print_qualname field.f_name print_type field.f_type
let print_struct ff field_list = print_record print_field ff field_list
let print_size_constraint ff = function
| Cequal (e1, e2) ->
fprintf ff "@[%a = %a@]" print_static_exp e1 print_static_exp e2
| Clequal (e1, e2) ->
fprintf ff "@[%a <= %a@]" print_static_exp e1 print_static_exp e2
| Cfalse -> fprintf ff "Cfalse"
let print_param ff p =
fprintf ff "%a:%a" Names.print_name p.p_name print_type p.p_type
let print_interface_type ff name tdesc =
match tdesc with
| Tabstract -> fprintf ff "@[type %s@]" name
| Tenum tag_name_list ->
fprintf ff "@[<2>type %s =@ %a@]"
name
(print_list_r print_qualname "" " |" "") tag_name_list;
| Tstruct f_ty_list ->
fprintf ff "@[<2>type %s =@ %a@]" name print_struct f_ty_list
| Talias t -> fprintf ff "@[<2>type %s = %a@]" name print_type t
let print_interface_const ff name c =
fprintf ff "@[<2>const %a : %a = %a@]@."
print_name name
print_type c.Signature.c_type
print_static_exp c.Signature.c_value
let print_interface_value ff name node =
let print_arg ff arg = match arg.a_name with
| None -> print_type ff arg.a_type
| Some(name) ->
fprintf ff "@[%a : %a@]" print_name name print_type arg.a_type in
let print_node_params ff p_list =
print_list_r (fun ff p -> print_name ff p.p_name) "<<" "," ">>" ff p_list
in
fprintf ff "@[<v 2>val %a%a@[%a@] returns @[%a@]@,@[%a@]@]"
print_name name
print_node_params node.node_params
(print_list_r print_arg "(" ";" ")") node.node_inputs
(print_list_r print_arg "(" ";" ")") node.node_outputs
(print_list_r print_size_constraint " with: " "," "")
node.node_params_constraints
let print_interface ff i =
let m = Modules.current_module () in
NamesEnv.iter
(fun key typdesc -> print_interface_type ff key typdesc) m.m_types;
NamesEnv.iter
(fun key constdec -> print_interface_const ff key constdec) m.m_consts;
NamesEnv.iter
(fun key sigtype -> print_interface_value ff key sigtype) m.m_values;
Format.fprintf ff "@."

26
compiler/global/ident.ml → compiler/global/idents.ml
View file

@ -16,6 +16,8 @@ type ident = {
is_generated : bool;
}
type var_ident = ident
let compare id1 id2 = compare id1.num id2.num
let sourcename id = id.source
let name id =
@ -79,5 +81,29 @@ module IdentSet = struct
Format.fprintf ff "}@]";
end
module S = Set.Make (struct type t = string
let compare = Pervasives.compare end)
(** @return a unique string for each identifier. Idents corresponding
to variables defined in the source file have the same name unless
there is a collision. *)
let name =
let used_names = ref S.empty in
let env = ref Env.empty in
let rec fresh_string base =
let base = name (fresh base) in
if S.mem base !used_names then fresh_string base else base
in
let unique_name n =
if Env.mem n !env then
Env.find n !env
else
let s = name n in
let s = if S.mem s !used_names then fresh_string s else s in
used_names := S.add s !used_names;
env := Env.add n s !env;
s
in
unique_name
let print_ident ff id = Format.fprintf ff "%s" (name id)

3
compiler/global/ident.mli → compiler/global/idents.mli
View file

@ -7,6 +7,9 @@
(** The (abstract) type of identifiers*)
type ident
(** Type to be used for local variables *)
type var_ident = 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) *)

28
compiler/global/initial.ml
View file

@ -9,18 +9,32 @@
(* initialization of the typing environment *)
open Names
open Types
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" })
let pbool = { qual = "Pervasives"; name = "bool" }
let ptrue = { qual = "Pervasives"; name = "true" }
let pfalse = { qual = "Pervasives"; name = "false" }
let por = { qual = "Pervasives"; name = "or" }
let pint = { qual = "Pervasives"; name = "int" }
let pfloat = { qual = "Pervasives"; name = "float" }
let mk_pervasives s = { qual = "Pervasives"; name = s }
let mk_static_int_op op args =
mk_static_exp ~ty:(Tid pint) (Sop (op,args))
let mk_static_int i =
mk_static_exp ~ty:(Tid pint) (Sint i)
let mk_static_bool b =
mk_static_exp ~ty:(Tid pbool) (Sbool b)
(* build the initial environment *)
let initialize () =
List.iter (fun (f, ty) -> Modules.add_type f ty) tglobal;
List.iter (fun (f, ty) -> Modules.add_constr f ty) cglobal
List.iter (fun (f, ty) -> Modules.add_constrs f ty) cglobal

228
compiler/global/location.ml
View file

@ -1,154 +1,130 @@
(* Printing a location in the source program *)
(* taken from the source of the Caml Light 0.73 compiler *)
(* inspired from the source of the Caml Light 0.73 compiler *)
open Lexing
open Parsing
open Format
(* 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 *)
Loc of position (* Position of the first character *)
* position (* 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 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 no_location = Loc (dummy_pos, dummy_pos)
let error_prompt = ">"
let current_loc () =
Loc(symbol_start(), symbol_end())
(** Prints [n] times char [c] on [oc]. *)
let prints_n_chars ff n c = for i = 1 to n do pp_print_char ff c done
(** Prints out to [oc] a line designed to be printed under [line] from file [ic]
underlining from char [first] to char [last] with char [ch].
[line] is the index of the first char of line. *)
let underline_line ic ff ch line first last =
let c = ref ' '
and f = ref first
and l = ref (last-first) in
( try
seek_in ic line;
pp_print_string ff error_prompt;
while c := input_char ic; !c != '\n' do
if !f > 0 then begin
f := !f - 1;
pp_print_char ff (if !c == '\t' then !c else ' ')
end
else if !l > 0 then begin
l := !l - 1;
pp_print_char ff (if !c == '\t' then !c else ch)
end
else ()
done
with End_of_file ->
if !f = 0 && !l > 0 then prints_n_chars ff 5 ch )
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 copy_lines nl ic ff prompt =
for i = 1 to nl do
pp_print_string ff prompt;
(try pp_print_string ff (input_line ic)
with End_of_file -> pp_print_string ff "<EOF>");
pp_print_char ff '\n'
done
let copy_chunk p1 p2 ic ff =
try for i = p1 to p2 - 1 do pp_print_char ff (input_char ic) done
with End_of_file -> pp_print_string ff "<EOF>"
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 "<EOF>"
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
let skip_lines n ic =
try for i = 1 to n do
let _ = input_line ic in ()
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
let print_location ff (Loc(p1,p2)) =
let n1 = p1.pos_cnum - p1.pos_bol in (* character number *)
let n2 = p2.pos_cnum - p2.pos_bol in
let np1 = p1.pos_cnum in (* character position *)
let np2 = p2.pos_cnum in
let l1 = p1.pos_lnum in (* line number *)
let l2 = p2.pos_lnum in
let lp1 = p1.pos_bol in (* line position *)
let lp2 = p2.pos_bol in
let f1 = p1.pos_fname in (* file name *)
let f2 = p2.pos_fname in
if f1 != f2 then (* Strange case *)
fprintf ff
"File \"%s\" line %d, character %d, to file \"%s\" line %d, character %d@."
f1 l1 n1 f2 l2 n2
else begin (* Same file *)
if l2 > l1 then
fprintf ff
"File \"%s\", line %d-%d, characters %d-%d:@\n" f1 l1 l2 n1 n2
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 "<EOF>"
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
fprintf ff "File \"%s\", line %d, characters %d-%d:@\n" f1 l1 n1 n2;
(* Output source code *)
try
let ic = open_in f1 in
if l1 == l2 then (
(* Only one line : copy full line and underline *)
seek_in ic lp1;
copy_lines 1 ic ff ">";
underline_line ic ff '^' lp1 n1 n2 )
else (
underline_line ic ff '.' lp1 0 n1; (* dots until n1 *)
seek_in ic np1;
(* copy the end of the line l1 after the dots *)
copy_lines 1 ic ff "";
if l2 - l1 <= 8 then
(* copy the 6 or less middle lines *)
copy_lines (l2-l1-1) ic ff ">"
else (
(* sum up the middle lines to 6 *)
copy_lines 3 ic ff ">";
pp_print_string ff "..........\n";
skip_lines (l2-l1-7) ic; (* skip middle lines *)
copy_lines 3 ic ff ">"
);
pp_print_string ff ">";
copy_chunk lp2 np2 ic ff; (* copy interesting begining of l2 *)
)
with Sys_error _ -> ();
end;
fprintf ff "@."

365
compiler/global/modules.ml
View file

@ -6,152 +6,285 @@
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* global symbol tables *)
(* Module objects and global environnement management *)
open Misc
open Signature
open Names
open Types
open Names
exception Already_defined
exception Cannot_find_file of string
(** Warning: Whenever this type is modified,
interface_format_version in signature.ml should be incremented. *)
type env =
{ mutable name: string;
mutable values: node NamesEnv.t;
mutable types: type_def NamesEnv.t;
mutable constr: ty NamesEnv.t;
mutable structs : structure NamesEnv.t;
mutable fields : name NamesEnv.t;
format_version : string;
}
(** Object serialized in compiled interfaces. *)
type module_object =
{ m_name : string;
m_values : node NamesEnv.t;
m_types : type_def NamesEnv.t;
m_consts : const_def NamesEnv.t;
m_constrs : name NamesEnv.t;
m_fields : name NamesEnv.t;
m_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 *)
}
type env = {
(** Current module name *)
mutable current_mod : module_name;
(** Modules opened and loaded into the env *)
mutable opened_mod : module_name list;
(** Modules loaded into the env *)
mutable loaded_mod : module_name list;
(** Node definitions *)
mutable values : node QualEnv.t;
(** Type definitions *)
mutable types : type_def QualEnv.t;
(** Constants definitions *)
mutable consts : const_def QualEnv.t;
(** Constructors mapped to their corresponding type *)
mutable constrs : qualname QualEnv.t;
(** Fields mapped to their corresponding type *)
mutable fields : qualname QualEnv.t;
(** Accepted compiled interface version *)
format_version : string }
let current =
{ name = ""; values = NamesEnv.empty; types = NamesEnv.empty;
constr = NamesEnv.empty; structs = NamesEnv.empty; fields = NamesEnv.empty;
(** The global environnement *)
let g_env =
{ current_mod = "";
opened_mod = [];
loaded_mod = [];
values = QualEnv.empty;
types = QualEnv.empty;
constrs = QualEnv.empty;
fields = QualEnv.empty;
consts = QualEnv.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)
let is_loaded m = List.mem m g_env.loaded_mod
let is_opened m = List.mem m g_env.opened_mod
(** Append a module to the global environnment *)
let _append_module mo =
(* Transforms a module object NamesEnv into its qualified version *)
let qualify mo_env = (* qualify env keys *)
NamesEnv.fold
(fun x v env -> QualEnv.add { qual = mo.m_name; name = x } v env)
mo_env QualEnv.empty in
let qualify_all mo_env = (* qualify env keys and values *)
NamesEnv.fold
(fun x v env ->
QualEnv.add {qual= mo.m_name; name= x} {qual= mo.m_name; name= v} env)
mo_env QualEnv.empty in
g_env.values <- QualEnv.append (qualify mo.m_values) g_env.values;
g_env.types <- QualEnv.append (qualify mo.m_types) g_env.types;
g_env.constrs <- QualEnv.append (qualify_all mo.m_constrs) g_env.constrs;
g_env.fields <- QualEnv.append (qualify_all mo.m_fields) g_env.fields;
g_env.consts <- QualEnv.append (qualify mo.m_consts) g_env.consts
(** Load a module into the global environnement unless already loaded *)
let _load_module modname =
if is_loaded modname then ()
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
let name = String.uncapitalize modname 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
let filename = Misc.findfile (name ^ ".epci") in
let ic = open_in_bin filename in
let mo:module_object =
try
input_value ic
with
| End_of_file | Failure _ ->
close_in ic;
Format.eprintf "Corrupted compiled interface file %s.@\n\
Please recompile %s.ept first.@." filename name;
raise Error in
if mo.m_format_version <> interface_format_version
then (
Format.eprintf "The file %s was compiled with an older version \
of the compiler.@\nPlease recompile %s.ept first.@."
filename name;
raise Error );
_append_module mo
with
| End_of_file | Failure _ ->
close_in ic;
Printf.eprintf "Corrupted compiled interface file %s.\n\
Please recompile %s.ept first.\n" filename name;
| Misc.Cannot_find_file(f) ->
Format.eprintf "Cannot find the compiled interface file %s.@." f;
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
type 'a info = { qualid : qualident; info : 'a }
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 *)
(** Opens a module unless already opened
by loading it into the global environnement and seting it as opened *)
let open_module modname =
let m = find_module modname in
modules.opened <- m :: modules.opened
if is_opened modname then ()
else
_load_module modname;
g_env.opened_mod <- modname::g_env.opened_mod
(** Initialize the global environnement :
set current module and open default modules *)
let initialize modname =
current.name <- modname;
g_env.current_mod <- modname;
g_env.opened_mod <- [];
g_env.loaded_mod <- [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 type_def =
if NamesEnv.mem f current.types then raise Already_defined;
current.types <- NamesEnv.add f type_def 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_struct f fields =
if NamesEnv.mem f current.structs then raise Already_defined;
current.structs <- NamesEnv.add f fields current.structs
let add_field f n =
if NamesEnv.mem f current.fields then raise Already_defined;
current.fields <- NamesEnv.add f n current.fields
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_struct = find (fun ident m -> NamesEnv.find ident m.structs)
let find_field = find (fun ident m -> NamesEnv.find ident m.fields)
(** { 3 Add functions prevent redefinitions } *)
let replace_value f signature =
current.values <- NamesEnv.remove f current.values;
current.values <- NamesEnv.add f signature current.values
let _check_not_defined env f =
if QualEnv.mem f env then raise Already_defined
let add_value f v =
_check_not_defined g_env.values f;
g_env.values <- QualEnv.add f v g_env.values
let add_type f v =
_check_not_defined g_env.types f;
g_env.types <- QualEnv.add f v g_env.types
let add_constrs f v =
_check_not_defined g_env.constrs f;
g_env.constrs <- QualEnv.add f v g_env.constrs
let add_field f v =
_check_not_defined g_env.fields f;
g_env.fields <- QualEnv.add f v g_env.fields
let add_const f v =
_check_not_defined g_env.consts f;
g_env.consts <- QualEnv.add f v g_env.consts
(** Same as add_value but without checking for redefinition *)
let replace_value f v =
g_env.values <- QualEnv.add f v g_env.values
(** { 3 Find functions look in the global environnement, nothing more } *)
let _find env x = QualEnv.find x env
let find_value x = _find g_env.values x
let find_type x = _find g_env.types x
let find_constrs x = _find g_env.constrs x
let find_field x = _find g_env.fields x
let find_const x = _find g_env.consts x
(** @return the fields of a record type. *)
let find_struct n =
match find_type n with
| Tstruct fields -> fields
| _ -> raise Not_found
(** { 3 Check functions }
Try to load the needed module and then to find it,
return true if in the table, return false if it can't find it. *)
(* NB : we can't factorize this functions since g_env is changed by _load... *)
let check_value q =
_load_module q.qual;
try let _ = QualEnv.find q g_env.values in true with Not_found -> false
let check_type q =
_load_module q.qual;
try let _ = QualEnv.find q g_env.types in true with Not_found -> false
let check_constrs q =
_load_module q.qual;
try let _ = QualEnv.find q g_env.constrs in true with Not_found -> false
let check_field q =
_load_module q.qual;
try let _ = QualEnv.find q g_env.fields in true with Not_found -> false
let check_const q =
_load_module q.qual;
try let _ = QualEnv.find q g_env.consts in true with Not_found -> false
(** { 3 Qualify functions [qualify_* name] return the qualified name
matching [name] in the global env scope (current module :: opened modules).
@raise [Not_found] if not in scope } *)
let _qualify env name =
let tries m =
try
let _ = QualEnv.find { qual = m; name = name } env in
true
with Not_found -> false in
let m = List.find tries (g_env.current_mod::g_env.opened_mod) in
{ qual = m; name = name }
let qualify_value name = _qualify g_env.values name
let qualify_type name = _qualify g_env.types name
let qualify_constrs name = _qualify g_env.constrs name
let qualify_field name = _qualify g_env.fields name
let qualify_const name = _qualify g_env.consts name
(** @return the name as qualified with the current module
(should not be used..)*)
let current_qual n = { qual = g_env.current_mod; name = n }
(** { 3 Fresh functions return a fresh qualname for the current module } *)
let rec fresh_value name =
let q = current_qual ("__" ^ name ^ "_" ^ Misc.gen_symbol()) in
if QualEnv.mem q g_env.values
then fresh_value name
else q
let rec fresh_type name =
let q = current_qual ("__" ^ name ^ "_" ^ Misc.gen_symbol()) in
if QualEnv.mem q g_env.types
then fresh_type name
else q
let rec fresh_const name =
let q = current_qual ("__" ^ name ^ "_" ^ Misc.gen_symbol()) in
if QualEnv.mem q g_env.consts
then fresh_const name
else q
let rec fresh_constr name =
let q = current_qual ("__" ^ name ^ "_" ^ Misc.gen_symbol()) in
if QualEnv.mem q g_env.constrs
then fresh_constr name
else q
exception Undefined_type of qualname
(** @return the unaliased version of a type. @raise Undefined_type *)
let rec unalias_type t = match t with
| Tid ty_name ->
(try
match find_type ty_name with
| Talias ty -> unalias_type ty
| _ -> t
with Not_found -> raise (Undefined_type ty_name))
| Tarray (ty, n) -> Tarray(unalias_type ty, n)
| Tprod ty_list -> Tprod (List.map unalias_type ty_list)
(** Return the current module as a [module_object] *)
let current_module () =
(* Filter and transform a qualified env into the current module object env *)
let unqualify env = (* unqualify and filter env keys *)
QualEnv.fold
(fun x v current ->
if x.qual = g_env.current_mod
then NamesEnv.add x.name v current
else current) env NamesEnv.empty in
let unqualify_all env = (* unqualify and filter env keys and values *)
QualEnv.fold
(fun x v current ->
if x.qual = g_env.current_mod
then NamesEnv.add x.name v.name current
else current) env NamesEnv.empty in
{ m_name = g_env.current_mod;
m_values = unqualify g_env.values;
m_types = unqualify g_env.types;
m_consts = unqualify g_env.consts;
m_constrs = unqualify_all g_env.constrs;
m_fields = unqualify_all g_env.fields;
m_format_version = g_env.format_version }
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

66
compiler/global/names.ml
View file

@ -4,42 +4,47 @@
type name = string
type longname =
| Name of name
| Modname of qualident
and qualname = { qual: string; name: string }
and qualident = { qual: string; id: string }
type type_name = qualname
type fun_name = qualname
type field_name = qualname
type constructor_name = qualname
type constant_name = qualname
type module_name = name
module NamesM = struct
type t = name
let compare = compare
let local_qualname = "$$%local_current_illegal_module_name%$$"
let local_qn name = { qual = local_qualname; name = name }
module NamesEnv = struct
include (Map.Make(struct type t = name let compare = compare end))
let append env0 env = fold (fun key v env -> add key v env) env0 env
end
module NamesEnv =
struct
include (Map.Make(NamesM))
module QualEnv = struct
include (Map.Make(struct type t = qualname let compare = compare end))
let append env0 env =
fold (fun key v env -> add key v env) env0 env
(** [append env' env] appends env' to env *)
let append env' env = fold (fun key v env -> add key v env) env' env
end
module QualSet = Set.Make (struct type t = qualname let compare = compare end)
module S = Set.Make (struct type t = string let compare = compare end)
let shortname = function
| Name s -> s
| Modname { id = id; } -> id
let shortname { name = n; } = n
let fullname = function
| Name s -> s
| Modname { qual = qual; id = id; } -> qual ^ "." ^ id
let fullname { qual = qual; name = n; } = qual ^ "." ^ n
let mk_longname s =
let qualname_of_string 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
if ind = 0 || ind = String.length s - 1
then invalid_arg "mk_longname: ill-formed identifier";
let n = String.sub s (ind + 1) (String.length s - ind - 1) in
{ qual = String.sub s 0 ind; name = n; }
with Not_found -> { qual = ""; name = s }
(** Are infix
[or], [quo], [mod], [land], [lor], [lxor], [lsl], [lsr], [asr]
@ -55,19 +60,18 @@ let is_infix s =
| 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> false
| _ -> true)
open Format
let print_name ff n =
let n = if is_infix n
then "( " ^ (n ^ " )") (* do not remove the space around n, since for example
"(*" would create bugs *)
else n
in Format.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 } ->
Format.fprintf ff "%s." m1;
print_name ff m2
in fprintf ff "%s" n
let print_raw_qualname ff {qual = q; name = n} =
fprintf ff "%s.%a" q print_name n
let opname qn = match qn with
| { qual = "Pervasives"; name = m; } -> m
| { qual = qual; name = n; } -> qual ^ "." ^ n

55
compiler/global/signature.ml
View file

@ -9,30 +9,41 @@
(* global data in the symbol tables *)
open Names
open Types
open Static
(** Warning: Whenever these types are modified,
interface_format_version should be incremented. *)
let interface_format_version = "7"
let interface_format_version = "20"
(** Node argument *)
type arg = { a_name : name option; a_type : ty }
type param = { p_name : name }
(** Node static parameters *)
type param = { p_name : name; p_type : ty }
(** Constraints on size expressions *)
type size_constraint =
| Cequal of static_exp * static_exp (* e1 = e2 *)
| Clequal of static_exp * static_exp (* e1 <= e2 *)
| Cfalse
(** Node signature *)
type node =
{ node_inputs : arg list;
node_outputs : arg list;
node_statefull : bool;
node_params : param list; (** Static parameters *)
node_params_constraints : size_constraint list }
type node = {
node_inputs : arg list;
node_outputs : arg list;
node_statefull : bool;
node_params : param list;
node_params_constraints : size_constraint list }
type field = { f_name : name; f_type : ty }
type field = { f_name : field_name; f_type : ty }
type structure = field list
type type_def = | Tabstract | Tenum of name list | Tstruct of structure
type type_def =
| Tabstract
| Talias of ty
| Tenum of constructor_name list
| Tstruct of structure
type const_def = { c_type : ty; c_value : static_exp }
let names_of_arg_list l = List.map (fun ad -> ad.a_name) l
@ -40,18 +51,24 @@ let types_of_arg_list l = List.map (fun ad -> ad.a_type) l
let mk_arg name ty = { a_type = ty; a_name = name }
let mk_param name = { p_name = name }
let mk_param name ty = { p_name = name; p_type = ty }
let mk_field n ty = { f_name = n; f_type = ty }
let print_param ff p = Names.print_name ff p.p_name
let mk_const_def ty value =
{ c_type = ty; c_value = value }
let mk_field n ty =
{ f_name = n; f_type = ty }
let mk_node ?(constraints = []) ins outs statefull params =
{ node_inputs = ins;
node_outputs = outs;
node_statefull = statefull;
node_params = params;
node_params_constraints = constraints }
let rec field_assoc f = function
| [] -> raise Not_found
| { f_name = n; f_type = ty }::l ->
if shortname f = n then
ty
else
field_assoc f l
if f = n then ty
else field_assoc f l

201
compiler/global/static.ml
View file

@ -8,93 +8,120 @@
(**************************************************************************)
(** This module defines static expressions, used in params and for constants.
const n: int = 3;
var x : int^n; var y : int^(n + 2);
x[n - 1], x[1 + 3],...
*)
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_constraint =
| Cequal of size_exp * size_exp (* e1 = e2*)
| Clequal of size_exp * size_exp (* e1 <= e2 *)
| Cfalse
open Types
open Signature
open Modules
(* unsatisfiable constraint *)
exception Instanciation_failed
exception Partial_instanciation of static_exp
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
let partial_apply_op op se_list =
match se_list with
| [{ se_desc = Sint n1 }; { se_desc = Sint n2 }] ->
(match op with
| { qual = "Pervasives"; name = "+" } ->
Sint (n1 + n2)
| { qual = "Pervasives"; name = "-" } ->
Sint (n1 - n2)
| { qual = "Pervasives"; name = "*" } ->
Sint (n1 * n2)
| { qual = "Pervasives"; name = "/" } ->
let n = if n2 = 0 then raise Instanciation_failed else n1 / n2 in
Sint n
| { qual = "Pervasives"; name = "=" } ->
Sbool (n1 = n2)
| _ -> assert false (*TODO: add missing operators*)
)
| [{ se_desc = Sint n }] ->
(match op with
| { qual = "Pervasives"; name = "~-" } -> Sint (-n)
| _ -> assert false (*TODO: add missing operators*)
)
| _ -> Sop(op, se_list)
let apply_op op se_list =
let se = partial_apply_op op se_list in
match se with
| Sop _ -> raise Not_found
| _ -> se
let eval_core eval apply_op env se = match se.se_desc with
| Sint _ | Sfloat _ | Sbool _ | Sconstructor _ -> se
| Svar ln -> (
try (* first try to find in global const env *)
let cd = find_const ln in
eval env cd.c_value
with Not_found -> (* then try to find in local env *)
eval env (QualEnv.find ln env))
| Sop (op, se_list) ->
let se_list = List.map (eval env) se_list in
{ se with se_desc = apply_op op se_list }
| Sarray se_list ->
{ se with se_desc = Sarray (List.map (eval env) se_list) }
| Sarray_power (se, n) ->
{ se with se_desc = Sarray_power (eval env se, eval env n) }
| Stuple se_list ->
{ se with se_desc = Stuple (List.map (eval env) se_list) }
| Srecord f_se_list ->
{ se with se_desc = Srecord
(List.map (fun (f,se) -> f, eval env se) f_se_list) }
(** [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))
variables values taken from [env] or from the global env with [find_const].
Every operator that can be computed is.
It can return static_exp with uninstanciated variables.*)
let rec simplify env se =
try eval_core simplify partial_apply_op env se
with _ -> se
(** [int_of_size_exp env e] returns the value of the expression
(** [eval env e] does the same as [simplify]
but if it returns, there are no variables nor op left.
@raise [Partial_instanciation] when it cannot fully evaluate *)
let rec eval env se =
try eval_core eval apply_op env se
with Not_found -> raise (Partial_instanciation se)
(** [int_of_static_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
let int_of_static_exp env se =
match (simplify env se).se_desc with
| Sint i -> i
| _ ->
(Format.eprintf "Internal compiler error, \
[eval_int] received the static_exp %a.@."
Global_printer.print_static_exp se;
assert false)
(** [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
| Cequal (e1, e2) when e1 = e2 ->
((Some true), (Cequal (simplify env e1, simplify env e2)))
Some true, Cequal (simplify env e1, simplify env e2)
| Cequal (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)), (Cequal (e1, e2)))
| (_, _) -> (None, (Cequal (e1, e2))))
let e2 = simplify env e2 in
(match e1.se_desc, e2.se_desc with
| Sint n1, Sint n2 -> Some (n1 = n2), Cequal (e1, e2)
| (_, _) -> None, Cequal (e1, e2))
| Clequal (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)), (Clequal (e1, e2)))
| (_, _) -> (None, (Clequal (e1, e2))))
| Cfalse -> (None, Cfalse)
let e2 = simplify env e2 in
(match e1.se_desc, e2.se_desc with
| Sint n1, Sint n2 -> Some (n1 <= n2), Clequal (e1, e2)
| _, _ -> None, Clequal (e1, e2))
| Cfalse -> None, Cfalse
exception Solve_failed of size_constraint
@ -106,48 +133,38 @@ let rec solve const_env =
| [] -> []
| c :: l ->
let l = solve const_env l in
let (res, c) = is_true const_env c
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
let rec static_exp_subst m se =
match se.se_desc with
| Svar qn -> (try QualEnv.find qn m with | Not_found -> se)
| Sop (op, se_list) ->
{ se with se_desc = Sop (op, List.map (static_exp_subst m) se_list) }
| Sarray_power (se, n) ->
{ se with se_desc = Sarray_power (static_exp_subst m se,
static_exp_subst m n) }
| Sarray se_list ->
{ se with se_desc = Sarray (List.map (static_exp_subst m) se_list) }
| Stuple se_list ->
{ se with se_desc = Stuple (List.map (static_exp_subst m) se_list) }
| Srecord f_se_list ->
{ se with se_desc =
Srecord (List.map
(fun (f,se) -> f, static_exp_subst m se) f_se_list) }
| _ -> se
(** 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
| Cequal (e1, e2) -> Cequal (size_exp_subst m e1, size_exp_subst m e2)
| Clequal (e1, e2) -> Clequal (size_exp_subst m e1, size_exp_subst m e2)
| Cfalse -> Cfalse
in List.map (replace_one m) constr
| Cequal (e1, e2) -> Cequal (static_exp_subst m e1, static_exp_subst m e2)
| Clequal (e1, e2) -> Clequal (static_exp_subst m e1, static_exp_subst m e2)
| Cfalse -> Cfalse 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 "@[(%a %s %a)@]"
print_size_exp e1 (op_to_string op) print_size_exp e2
let print_size_constraint ff = function
| Cequal (e1, e2) ->
fprintf ff "@[%a = %a@]" print_size_exp e1 print_size_exp e2
| Clequal (e1, e2) ->
fprintf ff "@[%a <= %a@]" print_size_exp e1 print_size_exp e2
| Cfalse -> fprintf ff "False"
let psize_constraint oc c =
let ff = formatter_of_out_channel oc
in (print_size_constraint ff c; fprintf ff "@?")

42
compiler/global/types.ml
View file

@ -6,22 +6,38 @@
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
open Static
open Names
type ty =
| Tprod of ty list | Tid of longname | Tarray of ty * size_exp
open Names
open Misc
open Location
type static_exp = { se_desc: static_exp_desc; se_ty: ty; se_loc: location }
and static_exp_desc =
| Svar of constant_name
| Sint of int
| Sfloat of float
| Sbool of bool
| Sconstructor of constructor_name
| Sfield of field_name
| Stuple of static_exp list
| Sarray_power of static_exp * static_exp (** power : 0^n : [0,0,0,0,0,..] *)
| Sarray of static_exp list (** [ e1, e2, e3 ] *)
| Srecord of (field_name * static_exp) list (** { f1 = e1; f2 = e2; ... } *)
| Sop of fun_name * static_exp list (** defined ops for now in pervasives *)
and ty = | Tprod of ty list | Tid of type_name | Tarray of ty * static_exp
let invalid_type = Tprod []
let const_array_of ty n = Tarray (ty, Sconst n)
let prod = function
| [] -> assert false
| [ty] -> ty
| ty_list -> Tprod ty_list
(** DO NOT use this after the typing, since it could give invalid_type *)
let mk_static_exp ?(loc = no_location) ?(ty = invalid_type) desc =
{ se_desc = desc; se_ty = ty; se_loc = loc }
open Pp_tools
open Format
let rec print_type ff = function
| Tprod ty_list ->
fprintf ff "@[<hov2>%a@]" (print_list_r print_type "(" " *" ")") ty_list
| Tid id -> print_longname ff id
| Tarray (ty, n) ->
fprintf ff "@[<hov2>%a^%a@]" print_type ty print_size_exp n

77
compiler/heptagon/analysis/causal.ml
View file

@ -9,11 +9,9 @@
(* causality check of scheduling constraints *)
(* $Id: causal.ml 615 2009-11-20 17:43:14Z pouzet $ *)
open Misc
open Names
open Ident
open Idents
open Heptagon
open Location
open Graph
@ -56,27 +54,26 @@ and nc =
| Aempty
let output_ac ff ac =
let rec print priority ff ac =
fprintf ff "@[<hov 0>";
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) ->
print_list_r (print 1) "(" "," ")" ff acs
| Awrite(m) -> fprintf ff "%s" (name m)
| Aread(m) -> fprintf ff "^%s" (name m)
| Alastread(m) -> fprintf ff "last %s" (name m)
end;
fprintf ff "@]" in
fprintf ff "@[%a@]@?" (print 0) ac
let rec print priority ff ac = match ac with
| Aseq(ac1, ac2) -> (* priority 1 *)
(if priority = 1 then fprintf ff "%a@ < %a"
else if priority > 1
then fprintf ff "@[<v 1>(%a@ < %a)@]"
else fprintf ff "@[%a@ < %a@]")
(print 1) ac1 (print 1) ac2
| Aand(ac1, ac2) -> (* priority 0 *)
(if priority = 0 then fprintf ff "%a@ || %a"
else if priority > 0
then fprintf ff "@[<v 1>(%a@ || %a)@]"
else fprintf ff "@[%a@ || %a@]")
(print 0) ac1 (print 0) ac2
| Atuple(acs) ->
fprintf ff "@[%a@]" (print_list_r (print 1) "(" "," ")") acs
| Awrite(m) -> fprintf ff "%s" (name m)
| Aread(m) -> fprintf ff "^%s" (name m)
| Alastread(m) -> fprintf ff "last %s" (name m)
in
fprintf ff "@[<v 1>%a@]@?" (print 0) ac
type error = Ecausality_cycle of ac
@ -86,13 +83,11 @@ 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
eprintf
"%aCausality error: the following constraint is not causal.@\n%a@."
print_location loc
output_ac ac
end;
raise Misc.Error
@ -118,26 +113,22 @@ let rec cand nc1 nc2 =
| Aac(ac1), Aac(ac2) -> Aac(Aand(ac1, ac2))
let rec ctuple l =
let rec conv = function
| Cwrite(n) -> Awrite(n)
| Cread(n) -> Aread(n)
| Clastread(n) -> Alastread(n)
| Ctuple(l) -> Atuple (ctuple l)
| Cand (c1, c2) -> Aand (conv c1, conv c2)
| Cseq _ -> Format.printf "Unexpected seq\n"; assert false
| Cor _ -> Format.printf "Unexpected or\n"; assert false
| _ -> assert false
let rec norm_or l res = match l with
| [] -> Aac (Atuple (List.rev res))
| Aempty::l -> norm_or l res
| Aor (Aempty, nc2)::l -> norm_or (nc2::l) res
| Aor (nc1, Aempty)::l -> norm_or (nc1::l) res
| Aor(nc1, nc2)::l ->
Aor(norm_or (nc1::l) res, norm_or (nc2::l) res)
| (Aac ac)::l -> norm_or l (ac::res)
in
match l with
| [] -> []
| Cempty::l -> ctuple l
| v::l -> (conv v)::(ctuple l)
norm_or l []
and 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))
| Ctuple l -> ctuple (List.map norm l)
| Cwrite(n) -> Aac(Awrite(n))
| Cread(n) -> Aac(Aread(n))
| Clastread(n) -> Aac(Alastread(n))

63
compiler/heptagon/analysis/causality.ml
View file

@ -9,11 +9,9 @@
(* causality check *)
(* $Id: causality.ml 615 2009-11-20 17:43:14Z pouzet $ *)
open Misc
open Names
open Ident
open Idents
open Heptagon
open Location
open Graph
@ -97,54 +95,46 @@ let build dec =
let rec typing e =
match e.e_desc with
| Econst(c) -> cempty
| Econstvar(x) -> cempty
| Evar(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
| Epre (_, e) -> pre (typing e)
| Efby (e1, e2) ->
let t1 = typing e1 in
let t2 = pre (typing e2) in
candlist [t1; t2]
| Eapp({ a_op = op }, e_list, _) -> apply op e_list
| Estruct(l) ->
let l = List.map (fun (_, e) -> typing e) l in
candlist l
| Earray(e_list) ->
candlist (List.map typing e_list)
| Eiterator (_, _, _, e_list, _) ->
ctuplelist (List.map typing e_list)
(** 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]
| Efield, [e1] -> typing e1
| Eifthenelse, [e1; e2; e3] ->
let t1 = typing e1 in
let i2 = typing e2 in
let i3 = typing e3 in
cseq t1 (cor i2 i3)
| Ecall _, e_list ->
| (Eequal | Efun _| Enode _ | Econcat | Eselect_slice
| Eselect_dyn| Eselect _ | Earray_fill), e_list ->
ctuplelist (List.map typing e_list)
| Efield_update _, [e1;e2] ->
| (Earray | Etuple), e_list ->
candlist (List.map typing e_list)
| Efield_update, [e1;e2] ->
let t1 = typing e1 in
let t2 = typing e2 in
cseq t2 t1
| Earray_op op, e_list ->
apply_array_op op e_list
and apply_array_op op e_list =
match op, e_list with
| (Eiterator (_, _, _) | Econcat | Eselect_slice
| Eselect_dyn | Eselect _ | Erepeat), e_list ->
ctuplelist (List.map typing e_list)
| Eupdate _, [e1;e2] ->
| Eupdate , e1::e_list ->
let t1 = typing e1 in
let t2 = typing e2 in
cseq t2 t1
let t2 = ctuplelist (List.map typing e_list) in
cseq t2 t1
let rec typing_pat = function
| Evarpat(x) -> cwrite(x)
@ -161,8 +151,8 @@ and typing_eq eq =
cseq (typing e) (typing_switch handlers)
| Epresent(handlers, b) ->
typing_present handlers b
| Ereset(eq_list, e) ->
cseq (typing e) (typing_eqs eq_list)
| Ereset(b, e) ->
cseq (typing e) (typing_block b)
| Eeq(pat, e) ->
cseq (typing e) (typing_pat pat)
@ -197,20 +187,19 @@ and typing_block { b_local = dec; b_equs = eq_list; b_loc = loc } =
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
| Some { c_block = b; c_assume = e_a;
c_enforce = e_g } ->
let teq = typing_eqs b.b_equs 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
let t_contract = clear (build b.b_local) 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 } =
n_block = b; n_loc = loc } =
let _ = typing_contract loc contract in
let teq = typing_eqs eq_list in
Causal.check loc teq
ignore (typing_block b)
let program ({ p_nodes = p_node_list } as p) =
List.iter typing_node p_node_list;

113
compiler/heptagon/analysis/initialization.ml
View file

@ -14,7 +14,7 @@
open Misc
open Names
open Ident
open Idents
open Heptagon
open Types
open Location
@ -94,6 +94,11 @@ let rec skeleton i ty =
| Tprod(ty_list) -> product (List.map (skeleton i) ty_list)
| _ -> leaf i
let rec const_skeleton i se =
match se.se_desc with
| Stuple l -> product (List.map (const_skeleton i) l)
| _ -> leaf i
(* sub-typing *)
let rec less left_ty right_ty =
if left_ty == right_ty then ()
@ -135,31 +140,20 @@ and occur_check index i =
module Printer = struct
open Format
open Pp_tools
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
let rec print_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
| Imax(i1, i2) -> fprintf ff "@[%a\\/%a@]" print_init i1 print_init i2
| Ilink(i) -> print_init ff i
let rec fprint_typ ff = function
| Ileaf(i) -> fprint_init ff i
let rec print_type ff = function
| Ileaf(i) -> print_init ff i
| Iproduct(ty_list) ->
fprintf ff "@[%a@]" (print_list_r fprint_typ "("" *"")") ty_list
fprintf ff "@[%a@]" (print_list_r print_type "("" *"")") 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
@ -174,12 +168,12 @@ module Error = struct
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
Format.eprintf "%aInitialization error: this expression has type \
%a, @\n\
but is expected to have type %a@."
print_location loc
Printer.print_type left_ty
Printer.print_type right_ty
end;
raise Misc.Error
end
@ -192,51 +186,54 @@ let less_exp e actual_ty expected_ty =
(** Main typing function *)
let rec typing h e =
match e.e_desc with
| Econst _ | Econstvar _ -> leaf izero
| Econst c -> const_skeleton izero c
| Evar(x) | Elast(x) -> let { i_typ = i } = Env.find x h in leaf i
| Etuple(e_list) ->
| Epre(None, e) ->
initialized_exp h e;
skeleton ione e.e_ty
| Epre(Some _, e) ->
initialized_exp h e;
skeleton izero e.e_ty
| Efby (e1, e2) ->
initialized_exp h e2;
skeleton (itype (typing h e1)) e.e_ty
| Eapp({ a_op = Etuple }, e_list, _) ->
product (List.map (typing h) e_list)
| Eapp({a_op = op}, 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) ->
let i =
List.fold_left
(fun acc e -> max acc (itype (typing h e))) izero e_list in
skeleton i e.e_ty
| Eiterator (_, _, _, e_list, _) ->
List.iter (fun e -> initialized_exp h e) e_list;
skeleton izero e.e_ty
(** 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
| Efield, [e1] ->
itype (typing h e1)
| Earray, e_list ->
List.fold_left
(fun acc e -> max acc (itype (typing h e))) izero e_list
| 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)
(* | Ecall ({ op_kind = Efun }, _), e_list ->
List.fold_left (fun acc e -> itype (typing h e)) izero e_list *)
| (Ecall _ | Earray_op _| Efield_update _) , e_list ->
| Etuple, _ -> assert false
(** TODO: init of safe/unsafe nodes
This is a tmp fix so that pre x + 1 works.*)
| (Eequal | Efun (Modname { qual = "Pervasives" })), e_list ->
List.fold_left (fun acc e -> itype (typing h e)) izero e_list
| _ , e_list ->
List.iter (fun e -> initialized_exp h e) e_list; izero
and expect h e expected_ty =
@ -261,8 +258,8 @@ and typing_eq h eq =
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
| Ereset(b, e) ->
initialized_exp h e; ignore (typing_block h b)
| Eeq(pat, e) ->
let ty_pat = typing_pat h pat in
expect h e ty_pat
@ -336,11 +333,10 @@ let sbuild 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;
| Some { c_block = b; c_assume = e_a;
c_enforce = e_g } ->
let h' = build h b.b_local in
typing_eqs h' b.b_equs;
(* assumption *)
expect h' e_a (skeleton izero e_a.e_ty);
(* property *)
@ -348,14 +344,11 @@ let typing_contract h contract =
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 } =
n_contract = contract; n_block = b } =
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
ignore (typing_block h b)
let program ({ p_nodes = p_node_list } as p) =
List.iter typing_node p_node_list;

104
compiler/heptagon/analysis/interface.ml
View file

@ -1,104 +0,0 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Read an interface *)
open Ident
open Names
open Heptagon
open Signature
open Modules
open Typing
open Pp_tools
open Types
module Type =
struct
let sigtype { sig_name = name; sig_inputs = i_list; sig_statefull = statefull;
sig_outputs = o_list; sig_params = params } =
let check_arg a = { a with a_type = check_type a.a_type } in
name, { node_inputs = List.map check_arg i_list;
node_outputs = List.map check_arg o_list;
node_statefull = statefull;
node_params = params;
node_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 Hept_printer
let deftype ff name tdesc =
match tdesc with
| Tabstract -> fprintf ff "@[type %s@.@]" name
| Tenum(tag_name_list) ->
fprintf ff "@[<hov 2>type %s = " name;
print_list_r print_name "" " |" "" ff tag_name_list;
fprintf ff "@.@]"
| Tstruct(f_ty_list) ->
fprintf ff "@[<hov 2>type %s = " name;
fprintf ff "@[<hov 1>";
print_list_r
(fun ff { f_name = field; f_type = ty } -> print_name ff field;
fprintf ff ": ";
print_type ff ty) "{" ";" "}" ff f_ty_list;
fprintf ff "@]@.@]"
let signature ff name { node_inputs = inputs;
node_outputs = outputs;
node_params = params;
node_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
in
let print_node_params ff = function
| [] -> ()
| l -> print_list_r print_name "<<" "," ">>" ff l
in
fprintf ff "@[<v 2>val ";
print_name ff name;
print_node_params ff (List.map (fun p -> p.p_name) params);
fprintf ff "@[";
print_list_r print "(" ";" ")" ff inputs;
fprintf ff "@] returns @[";
print_list_r print "(" ";" ")" ff outputs;
fprintf ff "@]";
(match constr with
| [] -> ()
| constr ->
fprintf ff "\n with: @[";
print_list_r Static.print_size_constraint "" "," "" ff constr;
fprintf ff "@]"
);
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

83
compiler/heptagon/analysis/statefull.ml Normal file
View file

@ -0,0 +1,83 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Checks that a node declared stateless is stateless *)
open Names
open Location
open Misc
open Signature
open Modules
open Heptagon
open Hept_mapfold
type error =
| Eshould_be_a_node
| Eexp_should_be_stateless
let message loc kind =
begin match kind with
| Eshould_be_a_node ->
Format.eprintf "%aThis node is statefull \
but was declared stateless.@."
print_location loc
| Eexp_should_be_stateless ->
Format.eprintf "%aThis expression should be stateless.@."
print_location loc
end;
raise Error
(** @returns whether the exp is statefull. Replaces node calls with
the correct Efun or Enode depending on the node signature. *)
let edesc funs statefull ed =
(* do the recursion on function args *)
let ed, statefull = Hept_mapfold.edesc funs statefull ed in
match ed with
| Efby _ | Epre _ -> ed, true
| Eapp({ a_op = Earrow }, _, _) -> ed, true
| Eapp({ a_op = (Enode f | Efun f) } as app, e_list, r) ->
let ty_desc = find_value f in
let op = if ty_desc.node_statefull then Enode f else Efun f in
Eapp({ app with a_op = op }, e_list, r),
ty_desc.node_statefull or statefull
| _ -> ed, statefull
let eq funs acc eq =
let eq, statefull = Hept_mapfold.eq funs acc eq in
{ eq with eq_statefull = statefull }, statefull
let block funs acc b =
let b, statefull = Hept_mapfold.block funs false b in
{ b with b_statefull = statefull }, acc or statefull
let escape_unless funs acc esc =
let esc, statefull = Hept_mapfold.escape funs false esc in
if statefull then
message esc.e_cond.e_loc Eexp_should_be_stateless;
esc, acc or statefull
let present_handler funs acc ph =
let p_cond, statefull = Hept_mapfold.exp_it funs false ph.p_cond in
if statefull then
message ph.p_cond.e_loc Eexp_should_be_stateless;
let p_block, acc = Hept_mapfold.block_it funs acc ph.p_block in
{ ph with p_cond = p_cond; p_block = p_block }, acc
let node_dec funs _ n =
let n, statefull = Hept_mapfold.node_dec funs false n in
if statefull & not (n.n_statefull) then
message n.n_loc Eshould_be_a_node;
n, false
let program p =
let funs =
{ Hept_mapfold.defaults with edesc = edesc;
escape_unless = escape_unless;
present_handler = present_handler;
eq = eq; block = block; node_dec = node_dec } in
let p, _ = Hept_mapfold.program_it funs false p in
p

1245
compiler/heptagon/analysis/typing.ml
View file

File diff suppressed because it is too large Load diff

331
compiler/heptagon/hept_mapfold.ml Normal file
View file

@ -0,0 +1,331 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Generic mapred over Heptagon AST *)
(* The basic idea is to provide a top-down pass over an Heptagon AST. If you
call [program_it hept_funs_default acc p], with [p] an heptagon program and
[acc] the accumulator of your choice, it will go through the whole AST,
passing the accumulator without touching it, and applying the identity
function on the AST. It'll return [p, acc].
To customize your pass, you need to redefine some functions of the
[hept_funs_default] record. Each field in the record handles one node type,
and the function held in the field will be called when the iterator
encounters the corresponding node type.
You can imitate the default functions defined here, and named corresponding
to the [hep_it_funs] field (corresponding to the Heptagon AST type). There
are two types of functions, the ones handling record types, and the more
special ones handling sum types. If you don't want to deal with every
constructor, you can simply finish your matching with [| _ -> raise
Misc.Fallback]: it will then fall back to the generic handling for these
construtors, defined in this file.
Note that the iterator is a top-down one. If you want to use it in a
bottom-up manner (e.g. visiting expressions before visiting an equation), you
need to manually call the proper recursive function (defined here) in the
beginning of your handler. For example:
[
let eq funs acc eq =
let (eq, acc) = Hept_mapfold.eq funs acc eq in
...
(eq, acc)
]
The record provided here and the functions to iterate over any type
([type_it]) enable lots of different ways to deal with the AST.
Discover it by yourself !*)
(* /!\ Do not EVER put in your funs record one of the generic iterator function
[type_it]. You should always put a custom version or the default version
provided in this file. Trespassers will loop infinitely! /!\ *)
open Misc
open Global_mapfold
open Heptagon
type 'a hept_it_funs = {
app:
'a hept_it_funs -> 'a -> Heptagon.app -> Heptagon.app * 'a;
block:
'a hept_it_funs -> 'a -> Heptagon.block -> Heptagon.block * 'a;
edesc:
'a hept_it_funs -> 'a -> Heptagon.desc -> Heptagon.desc * 'a;
eq:
'a hept_it_funs -> 'a -> Heptagon.eq -> Heptagon.eq * 'a;
eqdesc:
'a hept_it_funs -> 'a -> Heptagon.eqdesc -> Heptagon.eqdesc * 'a;
escape_unless :
'a hept_it_funs -> 'a -> Heptagon.escape -> Heptagon.escape * 'a;
escape_until:
'a hept_it_funs -> 'a -> Heptagon.escape -> Heptagon.escape * 'a;
exp:
'a hept_it_funs -> 'a -> Heptagon.exp -> Heptagon.exp * 'a;
pat:
'a hept_it_funs -> 'a -> pat -> Heptagon.pat * 'a;
present_handler:
'a hept_it_funs -> 'a -> Heptagon.present_handler
-> Heptagon.present_handler * 'a;
state_handler:
'a hept_it_funs -> 'a -> Heptagon.state_handler
-> Heptagon.state_handler * 'a;
switch_handler:
'a hept_it_funs -> 'a -> Heptagon.switch_handler
-> Heptagon.switch_handler * 'a;
var_dec:
'a hept_it_funs -> 'a -> Heptagon.var_dec -> Heptagon.var_dec * 'a;
last:
'a hept_it_funs -> 'a -> Heptagon.last -> Heptagon.last * 'a;
contract:
'a hept_it_funs -> 'a -> Heptagon.contract -> Heptagon.contract * 'a;
node_dec:
'a hept_it_funs -> 'a -> Heptagon.node_dec -> Heptagon.node_dec * 'a;
const_dec:
'a hept_it_funs -> 'a -> Heptagon.const_dec -> Heptagon.const_dec * 'a;
program:
'a hept_it_funs -> 'a -> Heptagon.program -> Heptagon.program * 'a;
global_funs: 'a Global_mapfold.global_it_funs }
let rec exp_it funs acc e = funs.exp funs acc e
and exp funs acc e =
let e_desc, acc = edesc_it funs acc e.e_desc in
let e_ty, acc = ty_it funs.global_funs acc e.e_ty in
{ e with e_desc = e_desc; e_ty = e_ty }, acc
and edesc_it funs acc ed =
try funs.edesc funs acc ed
with Fallback -> edesc funs acc ed
and edesc funs acc ed = match ed with
| Econst se ->
let se, acc = static_exp_it funs.global_funs acc se in
Econst se, acc
| Evar _ | Elast _ -> ed, acc
| Epre (se, e) ->
let se, acc = optional_wacc (static_exp_it funs.global_funs) acc se in
let e, acc = exp_it funs acc e in
Epre (se, e), acc
| Efby (e1, e2) ->
let e1, acc = exp_it funs acc e1 in
let e2, acc = exp_it funs acc e2 in
Efby (e1,e2), acc
| Estruct n_e_list ->
let aux acc (n,e) =
let e, acc = exp_it funs acc e in
(n,e), acc in
let n_e_list, acc = mapfold aux acc n_e_list in
Estruct n_e_list, acc
| Eapp (app, args, reset) ->
let app, acc = app_it funs acc app in
let args, acc = mapfold (exp_it funs) acc args in
let reset, acc = optional_wacc (exp_it funs) acc reset in
Eapp (app, args, reset), acc
| Eiterator (i, app, param, args, reset) ->
let app, acc = app_it funs acc app in
let param, acc = static_exp_it funs.global_funs acc param in
let args, acc = mapfold (exp_it funs) acc args in
let reset, acc = optional_wacc (exp_it funs) acc reset in
Eiterator (i, app, param, args, reset), acc
and app_it funs acc a = funs.app funs acc a
and app funs acc a =
let p, acc = mapfold (static_exp_it funs.global_funs) acc a.a_params in
{ a with a_params = p }, acc
and pat_it funs acc p =
try funs.pat funs acc p
with Fallback -> pat funs acc p
and pat funs acc p = match p with
| Etuplepat pl ->
let pl, acc = mapfold (pat_it funs) acc pl in
Etuplepat pl, acc
| Evarpat _ -> p, acc
and eq_it funs acc eq = funs.eq funs acc eq
and eq funs acc eq =
let eqdesc, acc = eqdesc_it funs acc eq.eq_desc in
{ eq with eq_desc = eqdesc }, acc
and eqdesc_it funs acc eqd =
try funs.eqdesc funs acc eqd
with Fallback -> eqdesc funs acc eqd
and eqdesc funs acc eqd = match eqd with
| Eautomaton st_h_l ->
let st_h_l, acc = mapfold (state_handler_it funs) acc st_h_l in
Eautomaton st_h_l, acc
| Eswitch (e, sw_h_l) ->
let e, acc = exp_it funs acc e in
let sw_h_l, acc = mapfold (switch_handler_it funs) acc sw_h_l in
Eswitch (e, sw_h_l), acc
| Epresent (p_h_l, b) ->
let p_h_l, acc = mapfold (present_handler_it funs) acc p_h_l in
let b, acc = block_it funs acc b in
Epresent (p_h_l, b), acc
| Ereset (b, e) ->
let b, acc = block_it funs acc b in
let e, acc = exp_it funs acc e in
Ereset (b, e), acc
| Eeq (p, e) ->
let p, acc = pat_it funs acc p in
let e, acc = exp_it funs acc e in
Eeq (p, e), acc
and block_it funs acc b = funs.block funs acc b
and block funs acc b =
(* defnames ty ?? *)
let b_local, acc = mapfold (var_dec_it funs) acc b.b_local in
let b_equs, acc = mapfold (eq_it funs) acc b.b_equs in
{ b with b_local = b_local; b_equs = b_equs }, acc
and state_handler_it funs acc s = funs.state_handler funs acc s
and state_handler funs acc s =
let s_unless, acc = mapfold (escape_unless_it funs) acc s.s_unless in
let s_block, acc = block_it funs acc s.s_block in
let s_until, acc = mapfold (escape_until_it funs) acc s.s_until in
{ s with s_block = s_block; s_until = s_until; s_unless = s_unless }, acc
(** escape is a generic function to deal with the automaton state escapes,
still the iterator function record differentiate until and unless
with escape_until_it and escape_unless_it *)
and escape_unless_it funs acc esc = funs.escape_unless funs acc esc
and escape_until_it funs acc esc = funs.escape_until funs acc esc
and escape funs acc esc =
let e_cond, acc = exp_it funs acc esc.e_cond in
{ esc with e_cond = e_cond }, acc
and switch_handler_it funs acc sw = funs.switch_handler funs acc sw
and switch_handler funs acc sw =
let w_block, acc = block_it funs acc sw.w_block in
{ sw with w_block = w_block }, acc
and present_handler_it funs acc ph = funs.present_handler funs acc ph
and present_handler funs acc ph =
let p_cond, acc = exp_it funs acc ph.p_cond in
let p_block, acc = block_it funs acc ph.p_block in
{ ph with p_cond = p_cond; p_block = p_block }, acc
and var_dec_it funs acc vd = funs.var_dec funs acc vd
and var_dec funs acc vd =
(* v_type ??? *)
let v_last, acc = last_it funs acc vd.v_last in
{ vd with v_last = v_last }, acc
and last_it funs acc l =
try funs.last funs acc l
with Fallback -> last funs acc l
and last funs acc l = match l with
| Var -> l, acc
| Last sto ->
let sto, acc = optional_wacc (static_exp_it funs.global_funs) acc sto in
Last sto, acc
and contract_it funs acc c = funs.contract funs acc c
and contract funs acc c =
let c_assume, acc = exp_it funs acc c.c_assume in
let c_enforce, acc = exp_it funs acc c.c_enforce in
let c_block, acc = block_it funs acc c.c_block in
{ c with
c_assume = c_assume; c_enforce = c_enforce; c_block = c_block }
, acc
and param_it funs acc vd = funs.param funs acc vd
and param funs acc vd =
let v_last, acc = last_it funs acc vd.v_last in
{ vd with v_last = v_last }, acc
and node_dec_it funs acc nd = funs.node_dec funs acc nd
and node_dec funs acc nd =
let n_input, acc = mapfold (var_dec_it funs) acc nd.n_input in
let n_output, acc = mapfold (var_dec_it funs) acc nd.n_output in
let n_params, acc = mapfold (param_it funs.global_funs) acc nd.n_params in
let n_contract, acc = optional_wacc (contract_it funs) acc nd.n_contract in
let n_block, acc = block_it funs acc nd.n_block in
{ nd with
n_input = n_input;
n_output = n_output;
n_block = n_block;
n_params = n_params;
n_contract = n_contract }
, acc
and const_dec_it funs acc c = funs.const_dec funs acc c
and const_dec funs acc c =
let c_type, acc = ty_it funs.global_funs acc c.c_type in
let c_value, acc = static_exp_it funs.global_funs acc c.c_value in
{ c with c_value = c_value; c_type = c_type }, acc
and program_it funs acc p = funs.program funs acc p
and program funs acc p =
let cd_list, acc = mapfold (const_dec_it funs) acc p.p_consts in
let nd_list, acc = mapfold (node_dec_it funs) acc p.p_nodes in
{ p with p_consts = cd_list; p_nodes = nd_list }, acc
let defaults = {
app = app;
block = block;
edesc = edesc;
eq = eq;
eqdesc = eqdesc;
escape_unless = escape;
escape_until = escape;
exp = exp;
pat = pat;
present_handler = present_handler;
state_handler = state_handler;
switch_handler = switch_handler;
var_dec = var_dec;
last = last;
contract = contract;
node_dec = node_dec;
const_dec = const_dec;
program = program;
global_funs = Global_mapfold.defaults }
let defaults_stop = {
app = stop;
block = stop;
edesc = stop;
eq = stop;
eqdesc = stop;
escape_unless = stop;
escape_until = stop;
exp = stop;
pat = stop;
present_handler = stop;
state_handler = stop;
switch_handler = stop;
var_dec = stop;
last = stop;
contract = stop;
node_dec = stop;
const_dec = stop;
program = stop;
global_funs = Global_mapfold.defaults_stop }

243
compiler/heptagon/hept_printer.ml
View file

@ -11,19 +11,21 @@
open Location
open Misc
open Names
open Ident
open Heptagon
open Idents
open Modules
open Static
open Format
open Global_printer
open Pp_tools
open Types
open Signature
open Heptagon
let iterator_to_string i =
match i with
| Imap -> "map"
| Ifold -> "fold"
| Ifoldi -> "foldi"
| Imapfold -> "mapfold"
let print_iterator ff it =
@ -34,15 +36,6 @@ let rec print_pat ff = function
| Etuplepat(pat_list) ->
print_list_r print_pat "(" "," ")" ff pat_list
and print_c ff = function
| Cint i -> fprintf ff "%d" i
| Cfloat f -> fprintf ff "%f" f
| Cconstr(tag) -> print_longname ff tag
| Carray (n, c) ->
print_c ff c;
fprintf ff "^";
print_size_exp ff n
and print_vd ff { v_ident = n; v_type = ty; v_last = last } =
fprintf ff "@[<v>";
begin match last with Last _ -> fprintf ff "last " | _ -> () end;
@ -50,7 +43,7 @@ and print_vd ff { v_ident = n; v_type = ty; v_last = last } =
fprintf ff ": ";
print_type ff ty;
begin
match last with Last(Some(v)) -> fprintf ff "= ";print_c ff v
match last with Last(Some(v)) -> fprintf ff "= ";print_static_exp ff v
| _ -> ()
end;
fprintf ff "@]"
@ -62,110 +55,109 @@ 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) -> print_exps ff e_list
| Efield(e, field) ->
print_exp ff e; fprintf ff ".";
print_longname ff field
| Estruct(f_e_list) ->
print_list_r
(fun ff (field, e) -> print_longname ff field;fprintf ff " = ";
print_exp ff e)
"{" ";" "}" ff f_e_list;
fprintf ff "}@]"
| Earray e_list ->
print_list_r print_exp "[" "," "]" ff e_list
end;
if !Misc.full_type_info then fprintf ff " : %a)" print_type e.e_ty
and print_call_params ff = function
| [] -> ()
| l -> print_list_r print_size_exp "<<" "," ">>" ff l
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 "@]"
| Ecall({ op_name = f; op_params = params }, reset), e_list ->
print_longname ff f;
print_call_params ff params;
print_exps ff e_list;
(match reset with
| Econst c -> print_static_exp ff c
| Epre(None, e) -> fprintf ff "pre "; print_exp ff e
| Epre(Some c, e) ->
print_static_exp ff c; fprintf ff " fby "; print_exp ff e
| Efby(e1, e2) -> print_exp ff e1; fprintf ff " fby "; print_exp ff e2
| Eapp({ a_op = op; a_params = params }, e_list, r) ->
print_op ff op params e_list;
(match r with
| None -> ()
| Some r -> fprintf ff " every %a" print_exp 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 ")@]"
| Earray_op op, e_list ->
print_array_op ff op e_list
and print_array_op ff op e_list =
match op, e_list with
| Erepeat, [e1; e2] ->
print_exp ff e1;
fprintf ff "^";
print_exp ff e2
| Eselect idx_list, [e] ->
print_exp ff e;
print_list_r print_size_exp "[" "][" "]" ff idx_list
| Eselect_dyn, e::defe::idx_list ->
fprintf ff "@[(";
print_exp ff e;
print_list_r print_exp "[" "][" "] default " ff idx_list;
print_exp ff defe;
fprintf ff ")@]"
| Eupdate idx_list, [e1;e2] ->
fprintf ff "(@[";
print_exp ff e1;
fprintf ff " with ";
print_list_r print_size_exp "[" "][" "]" ff 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_name = op; op_params = params } , reset), e::e_list ->
| Estruct(f_e_list) ->
print_list_r
(fun ff (field, e) -> print_qualname ff field;fprintf ff " = ";
print_exp ff e)
"{" ";" "}" ff f_e_list;
fprintf ff "}@]"
| Eiterator (it, { a_op = (Efun ln|Enode ln); a_params = params },
n, e_list, reset) ->
fprintf ff "(";
print_iterator ff it;
fprintf ff " ";
(match params with
| [] -> print_longname ff op
| [] -> print_qualname ff ln
| l ->
fprintf ff "(";
print_longname ff op;
print_qualname ff ln;
print_call_params ff params;
fprintf ff ")"
);
fprintf ff " <<";
print_exp ff e;
print_static_exp ff n;
fprintf ff ">>) ";
print_exps ff e_list;
(match reset with
| None -> ()
| Some r -> fprintf ff " every %a" print_exp r
)
| Econcat, [e1;e2] ->
end;
if !Misc.full_type_info then fprintf ff " : %a)" print_type e.e_ty
and print_call_params ff = function
| [] -> ()
| l -> print_list_r print_static_exp "<<" "," ">>" ff l
and print_op ff op params e_list =
match op, params, e_list with
| Eequal, _, [e1; e2] ->
fprintf ff "@[<2>%a@ = %a@]" print_exp e1 print_exp 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 "@]"
| Etuple, _, e_list -> print_exps ff e_list
| Earray, _, e_list ->
print_list_r print_exp "[" "," "]" ff e_list
| (Efun f|Enode f), params, e_list ->
print_qualname ff f;
print_call_params ff params;
print_exps ff e_list
| Efield, [field], [e] ->
print_exp ff e; fprintf ff ".";
print_static_exp ff field
| Efield_update, [se], [e1;e2] ->
fprintf ff "(@[";
print_exp ff e1;
fprintf ff " with .";
print_static_exp ff se;
fprintf ff " = ";
print_exp ff e2;
fprintf ff ")@]"
| Earray_fill, [se], [e] ->
print_exp ff e;
fprintf ff "^";
print_static_exp ff se
| Eselect, idx_list, [e] ->
print_exp ff e;
print_list_r print_static_exp "[" "][" "]" ff idx_list
| Eselect_dyn, _, e::defe::idx_list ->
fprintf ff "@[(";
print_exp ff e;
print_list_r print_exp "[" "][" "] default " ff idx_list;
print_exp ff defe;
fprintf ff ")@]"
| Eupdate, _, e1::e2::idx_list ->
fprintf ff "(@[";
print_exp ff e1;
fprintf ff " with ";
print_list_r print_exp "[" "][" "]" ff idx_list;
fprintf ff " = ";
print_exp ff e2;
fprintf ff ")@]"
| Eselect_slice, [idx1;idx2], [e] ->
print_exp ff e;
fprintf ff "[";
print_static_exp ff idx1;
fprintf ff "..";
print_static_exp ff idx2;
fprintf ff "]"
| Econcat, _, [e1;e2] ->
fprintf ff "@[";
print_exp ff e1;
fprintf ff " @@ ";
@ -202,10 +194,10 @@ let rec print_eq ff eq =
fprintf ff "@]"
end;
fprintf ff "@,end@]"
| Ereset(eq_list, e) ->
| Ereset(b, e) ->
fprintf ff "@[<v>reset@,";
fprintf ff " @[<v>";
print_eq_list ff eq_list;
print_block ff b;
fprintf ff "@]";
fprintf ff "@,every ";
print_exp ff e;
@ -219,7 +211,7 @@ and print_eq_list ff = function
and print_state_handler ff
{ s_state = s; s_block = b; s_until = until; s_unless = unless } =
fprintf ff " @[<v 2>state ";
fprintf ff "%s@," s;
fprintf ff "%a@," print_name s;
print_block ff b;
if until <> [] then
begin
@ -237,7 +229,7 @@ and print_state_handler ff
and print_switch_handler ff { w_name = tag; w_block = b } =
fprintf ff " @[<v 2>| ";
print_longname ff tag;
print_qualname ff tag;
fprintf ff "@,";
print_block ff b;
fprintf ff "@]"
@ -273,50 +265,49 @@ and print_block ff { b_local = v_list; b_equs = eqs; b_defnames = defnames } =
let print_type_def ff { t_name = name; t_desc = tdesc } =
match tdesc with
| Type_abs -> fprintf ff "@[type %s@\n@]" name
| Type_abs -> fprintf ff "@[type %a@.@]" print_qualname name
| Type_alias ty ->
fprintf ff "@[type %a@ = %a@.@]" print_qualname name print_type ty
| Type_enum(tag_name_list) ->
fprintf ff "@[type %s = " name;
print_list_r print_name "" "| " "" ff tag_name_list;
fprintf ff "@\n@]"
fprintf ff "@[<2>type %a = " print_qualname name;
print_list_r print_qualname "" "| " "" ff tag_name_list;
fprintf ff "@.@]"
| Type_struct(f_ty_list) ->
fprintf ff "@[type %s = " name;
fprintf ff "@[type %a = " print_qualname name;
print_list_r
(fun ff { f_name = field; f_type = ty } ->
print_name ff field;
print_qualname ff field;
fprintf ff ": ";
print_type ff ty) "{" ";" "}" ff f_ty_list;
fprintf ff "@.@]"
let print_const_dec ff c =
fprintf ff "@[const ";
print_name ff c.c_name;
print_qualname ff c.c_name;
fprintf ff " : ";
print_type ff c.c_type;
fprintf ff " = ";
print_size_exp ff c.c_value;
print_static_exp ff c.c_value;
fprintf ff "@.@]"
let print_contract ff {c_local = l;
c_eq = eqs;
let print_contract ff {c_block = b;
c_assume = e_a;
c_enforce = e_g;
c_controllables = cl } =
if l <> [] then begin
c_enforce = e_g } =
if b.b_local <> [] then begin
fprintf ff "@[<v 2>contract@\n";
fprintf ff "@[<hov 4>var ";
print_list_r print_vd "" ";" "" ff l;
print_list_r print_vd "" ";" "" ff b.b_local;
fprintf ff ";@]@\n"
end;
if eqs <> [] then begin
if b.b_equs <> [] then begin
fprintf ff "@[<v 2>let @,";
print_eq_list ff eqs;
print_eq_list ff b.b_equs;
fprintf ff "@]"; fprintf ff "tel@\n"
end;
fprintf ff "assume %a@;enforce %a@;with (@[<hov>"
print_exp e_a
print_exp e_g;
print_list_r print_vd "" ";" "" ff cl;
fprintf ff "@])@]@\n"
fprintf ff "@])@]@."
let print_node_params ff = function
| [] -> ()
@ -324,23 +315,23 @@ let print_node_params ff = function
let print_node ff
{ n_name = n; n_input = ni;
n_local = nl; n_output = no; n_contract = contract; n_equs = ne;
n_block = nb; n_output = no; n_contract = contract;
n_params = params; } =
fprintf ff "@[<v 2>node ";
print_name ff n;
print_qualname ff n;
fprintf ff "@[%a@]" print_node_params params;
fprintf ff "@[%a@]" (print_list_r print_vd "(" ";" ")") ni;
fprintf ff " returns ";
fprintf ff "@[%a@]" (print_list_r print_vd "(" ";" ")") no;
fprintf ff "@,";
optunit (print_contract ff) contract;
if nl <> [] then begin
if nb.b_local <> [] then begin
fprintf ff "@[<hov 4>var ";
print_list_r print_vd "" ";" "" ff nl;
print_list_r print_vd "" ";" "" ff nb.b_local;
fprintf ff ";@]@,"
end;
fprintf ff "@[<v 2>let @,";
print_eq_list ff ne;
print_eq_list ff nb.b_equs;
fprintf ff "@]@;"; fprintf ff "tel";fprintf ff "@.@]"
let print_open_module ff name =
@ -348,12 +339,8 @@ let print_open_module ff name =
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
let ff = Format.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;

222
compiler/heptagon/heptagon.ml
View file

@ -1,4 +1,4 @@
(**************************************************************************)
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
@ -10,155 +10,176 @@
open Location
open Misc
open Names
open Ident
open Idents
open Static
open Signature
open Types
open Initial
type state_name = name
type iterator_type =
| Imap
| Ifold
| Ifoldi
| Imapfold
type exp = { e_desc : desc; e_ty : ty; e_loc : location }
type exp = {
e_desc : desc;
e_ty : ty;
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
| Econst of static_exp
| Evar of var_ident
| Elast of var_ident
| Epre of static_exp option * exp
| Efby of exp * exp
| Estruct of (field_name * exp) list
| Eapp of app * exp list * exp option
| Eiterator of iterator_type * app * static_exp * exp list * exp option
and app =
{ a_op : op; }
and app = {
a_op : op;
a_params : static_exp list;
a_unsafe : bool }
and op =
| Epre of const option
| Efby
| Earrow
| Eequal
| Etuple
| Efun of fun_name
| Enode of fun_name
| Eifthenelse
| Earray_op of array_op
| Efield_update of longname
| Ecall of op_desc * exp option (** [op_desc] is the function called [exp
option] is the optional reset condition *)
and array_op =
| Erepeat
| Eselect of size_exp list
| Earrow
| Efield
| Efield_update (* field name args would be [record ; value] *)
| Earray
| Earray_fill
| Eselect
| Eselect_dyn
| Eupdate of size_exp list
| Eselect_slice
| Eupdate
| Econcat
| Eiterator of iterator_type * op_desc * exp option (** [op_desc] node to map
[exp option] reset *)
and op_desc = { op_name : longname; op_params: size_exp list; op_kind: op_kind }
and op_kind = | Efun | Enode
and const =
| Cint of int
| Cfloat of float
| Cconstr of longname
| Carray of size_exp * const
and pat =
| Etuplepat of pat list | Evarpat of ident
| Etuplepat of pat list
| Evarpat of var_ident
type eq =
{ eq_desc : eqdesc; eq_statefull : bool; eq_loc : location }
type eq = {
eq_desc : eqdesc;
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
| Ereset of block * 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
}
b_local : var_dec list;
b_equs : eq list;
b_defnames : ty Env.t;
b_statefull : bool;
b_loc : location }
and state_handler = {
s_state : name; s_block : block; s_until : escape list;
s_unless : escape list
}
s_state : 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
}
e_cond : exp;
e_reset : bool;
e_next_state : state_name }
and switch_handler = {
w_name : longname; w_block : block
}
w_name : constructor_name;
w_block : block }
and present_handler = {
p_cond : exp; p_block : block
}
p_cond : exp;
p_block : block }
and var_dec = {
v_ident : ident; mutable v_type : ty; v_last : last; v_loc : location
}
v_ident : var_ident;
v_type : ty;
v_last : last;
v_loc : location }
and last =
| Var | Last of const option
and last = Var | Last of static_exp option
type type_dec = {
t_name : name; t_desc : type_desc; t_loc : location
}
t_name : qualname;
t_desc : type_dec_desc;
t_loc : location }
and type_desc =
| Type_abs | Type_enum of name list | Type_struct of structure
and type_dec_desc =
| Type_abs
| Type_alias of ty
| Type_enum of constructor_name list
| Type_struct of structure
type contract = {
c_assume : exp; c_enforce : exp; c_controllables : var_dec list;
c_local : var_dec list; c_eq : eq list
}
c_assume : exp;
c_enforce : exp;
c_block : block }
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 : param list;
n_params_constraints : size_constraint list
}
n_name : qualname;
n_statefull : bool;
n_input : var_dec list;
n_output : var_dec list;
n_contract : contract option;
n_block : block;
n_loc : location;
n_params : param list;
n_params_constraints : size_constraint list }
type const_dec = {
c_name : name; c_type : ty; c_value : size_exp; c_loc : location }
c_name : qualname;
c_type : ty;
c_value : static_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
}
p_modname : name;
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 : arg list; sig_statefull : bool;
sig_outputs : arg list; sig_params : param list
}
sig_name : qualname;
sig_inputs : arg list;
sig_statefull : bool;
sig_outputs : arg list;
sig_params : param list;
sig_loc : location }
type interface =
interface_decl list
type interface = interface_decl list
and interface_decl = {
interf_desc : interface_desc; interf_loc : location
}
interf_desc : interface_desc;
interf_loc : location }
and interface_desc =
| Iopen of name | Itypedef of type_dec | Isignature of signature
| Iopen of name
| Itypedef of type_dec
| Iconstdef of const_dec
| Isignature of signature
(* Helper functions to create AST. *)
let mk_exp desc ty =
{ e_desc = desc; e_ty = ty; e_loc = no_location; }
let mk_op op = { a_op = op; }
let mk_op ?(params=[]) ?(unsafe=false) op =
{ a_op = op; a_params = params; a_unsafe = unsafe }
let mk_op_desc ln params kind =
{ op_name = ln; op_params = params; op_kind = kind }
let mk_op_app ?(params=[]) ?(unsafe=false) ?(reset=None) op args =
Eapp(mk_op ~params:params ~unsafe:unsafe op, args, reset)
let mk_type_dec name desc =
{ t_name = name; t_desc = desc; t_loc = no_location; }
@ -170,15 +191,15 @@ let mk_var_dec ?(last = Var) name ty =
{ v_ident = name; v_type = ty;
v_last = last; v_loc = no_location }
let mk_block ?(statefull = true) defnames eqs =
let mk_block ?(statefull = true) ?(defnames = Env.empty) eqs =
{ b_local = []; b_equs = eqs; b_defnames = defnames;
b_statefull = statefull; b_loc = no_location }
let dfalse = mk_exp (Econst (Cconstr Initial.pfalse)) (Tid Initial.pbool)
let dtrue = mk_exp (Econst (Cconstr Initial.ptrue)) (Tid Initial.pbool)
let dfalse = mk_exp (Econst (mk_static_bool false)) (Tid Initial.pbool)
let dtrue = mk_exp (Econst (mk_static_bool true)) (Tid Initial.pbool)
let mk_ifthenelse e1 e2 e3 =
{ e3 with e_desc = Eapp(mk_op Eifthenelse, [e1; e2; e3]) }
{ e3 with e_desc = mk_op_app Eifthenelse [e1; e2; e3] }
let mk_simple_equation pat e =
mk_equation ~statefull:false (Eeq(pat, e))
@ -186,21 +207,14 @@ let mk_simple_equation pat e =
let mk_switch_equation ?(statefull = true) e l =
mk_equation ~statefull:statefull (Eswitch (e, l))
(** @return a size exp operator from a Heptagon operator. *)
let op_from_app app =
match app.a_op with
| Ecall ( { op_name = op; op_kind = Efun }, _) -> op_from_app_name op
| _ -> raise Not_static
let mk_signature name ins outs statefull params loc =
{ sig_name = name;
sig_inputs = ins;
sig_statefull = statefull;
sig_outputs = outs;
sig_params = params;
sig_loc = loc }
(** Translates a Heptagon exp into a static size exp. *)
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
(** @return the set of variables defined in [pat]. *)
let vars_pat pat =

59
compiler/heptagon/main/hept_compiler.ml
View file

@ -11,6 +11,7 @@
open Misc
open Compiler_utils
open Location
open Global_printer
let pp p = if !verbose then Hept_printer.print stdout p
@ -18,16 +19,17 @@ let parse parsing_fun lexing_fun lexbuf =
try
parsing_fun lexing_fun lexbuf
with
| Hept_lexer.Lexical_error(err, pos1, pos2) ->
lexical_error err (Loc(pos1, pos2))
| Hept_lexer.Lexical_error(err, l) ->
lexical_error err l
| Hept_parser.Error ->
let pos1 = Lexing.lexeme_start lexbuf
and pos2 = Lexing.lexeme_end lexbuf in
let pos1 = Lexing.lexeme_start_p lexbuf
and pos2 = Lexing.lexeme_end_p lexbuf in
let l = Loc(pos1,pos2) in
syntax_error l
let parse_implementation lexbuf =
parse Hept_parser.program Hept_lexer.token lexbuf
let parse_implementation modname lexbuf =
let p = parse Hept_parser.program Hept_lexer.token lexbuf in
{ p with Hept_parsetree.p_modname = modname }
let parse_interface lexbuf =
parse Hept_parser.interface Hept_lexer.token lexbuf
@ -35,34 +37,39 @@ let parse_interface lexbuf =
let compile_impl pp p =
(* Typing *)
let p = do_pass Typing.program "Typing" p pp true in
let p = pass "Typing" true Typing.program p pp in
let p = silent_pass "Statefullness check" true Statefull.program p in
if !print_types then Interface.Printer.print stdout;
if !print_types then print_interface Format.std_formatter p;
(* Causality check *)
let p = do_silent_pass Causality.program "Causality check" p true in
let p = silent_pass "Causality check" true Causality.program p in
(* Initialization check *)
let p =
do_silent_pass Initialization.program "Initialization check" p !init in
(* Initialization check *)(*
let p = silent_pass "Initialization check" !init Initialization.program p in*)
(* Completion of partial definitions *)
let p = do_pass Completion.program "Completion" p pp true in
let p = pass "Completion" true Completion.program p pp in
(* Inlining *)(*
let p =
let call_inline_pass = (List.length !inline > 0) || !Misc.flatten in
pass "Inlining" call_inline_pass Inline.program p pp in *)
(* Automata *)
let p = do_pass Automata.program "Automata" p pp true in
let p = pass "Automata" true Automata.program p pp in
(* Present *)
let p = do_pass Present.program "Present" p pp true in
let p = pass "Present" true Present.program p pp in
(* Shared variables (last) *)
let p = do_pass Last.program "Last" p pp true in
let p = pass "Last" true Last.program p pp in
(* Reset *)
let p = do_pass Reset.program "Reset" p pp true in
let p = pass "Reset" true Reset.program p pp in
(* Every *)
let p = do_pass Every.program "Every" p pp true in
let p = pass "Every" true Every.program p pp in
(* Return the transformed AST *)
p
@ -72,28 +79,24 @@ let compile_interface modname filename =
let source_name = filename ^ ".epi" in
let obj_interf_name = filename ^ ".epci" in
let ic = open_in source_name in
let ic, lexbuf = lexbuf_from_file source_name in
let itc = open_out_bin obj_interf_name in
let close_all_files () =
close_in ic;
close_out itc in
try
init_compiler modname source_name ic;
init_compiler modname;
(* Parsing of the file *)
let lexbuf = Lexing.from_channel ic in
let l = parse_interface lexbuf in
let l = do_silent_pass "Parsing" parse_interface lexbuf in
(* Convert the parse tree to Heptagon AST *)
let l = Scoping.translate_interface l in
(* Compile*)
Interface.Type.main l;
if !print_types then Interface.Printer.print stdout;
let l = do_silent_pass "Scoping" Hept_scoping.translate_interface l in
if !print_types then print_interface Format.std_formatter l;
Modules.write itc;
output_value itc (Modules.current_module ());
close_all_files ()
with

14
compiler/heptagon/main/heptcheck.ml
View file

@ -19,26 +19,22 @@ let check_implementation modname filename =
(* input and output files *)
let source_name = filename ^ ".ept" in
let ic = open_in source_name in
let ic, lexbuf = lexbuf_from_file source_name in
let close_all_files () =
close_in ic
in
try
init_compiler modname source_name ic;
init_compiler modname;
(* Parsing of the file *)
let lexbuf = Lexing.from_channel ic in
let p = parse_implementation lexbuf in
let p = do_silent_pass parse_implementation "Parsing" lexbuf true in
(* Convert the parse tree to Heptagon AST *)
let p = Scoping.translate_program p in
comment "Parsing";
pp p;
let p = do_pass Hept_scoping.translate_program "Scoping" p pp true in
(* Call the compiler*)
let p = Hept_compiler.compile_impl pp p in
comment "Checking";
let p = do_silent_pass Hept_compiler.compile_impl "Checking" p true in
close_all_files ()

80
compiler/heptagon/parsing/hept_lexer.mll
View file

@ -3,15 +3,17 @@
{
open Lexing
open Location
open Hept_parser
type lexical_error =
Illegal_character
| Unterminated_comment
| Bad_char_constant
| Unterminated_string;;
exception Lexical_error of lexical_error * int * int;;
exception Lexical_error of lexical_error * location;;
let comment_depth = ref 0
@ -57,12 +59,13 @@ List.iter (fun (str,tok) -> Hashtbl.add keyword_table str tok) [
"with", WITH;
"map", MAP;
"fold", FOLD;
"foldi", FOLDI;
"mapfold", MAPFOLD;
"quo", INFIX3("quo");
"mod", INFIX3("mod");
"land", INFIX3("land");
"lor", INFIX2("lor");
"lxor", INFIX2("lxor");
"xor", INFIX2("xor");
"lsl", INFIX4("lsl");
"lsr", INFIX4("lsr");
"asr", INFIX4("asr")
@ -80,14 +83,6 @@ let reset_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
@ -118,11 +113,14 @@ let char_for_decimal_code lexbuf i =
(int_of_char(Lexing.lexeme_char lexbuf (i+2)) - 48) in
char_of_int(c land 0xFF)
}
let newline = '\n' | '\r' '\n'
rule token = parse
| [' ' '\010' '\013' '\009' '\012'] + { token lexbuf }
| newline { new_line lexbuf; token lexbuf }
| [' ' '\t'] + { token lexbuf }
| "." {DOT}
| "(" {LPAREN}
| ")" {RPAREN}
@ -133,6 +131,7 @@ rule token = parse
| ";" {SEMICOL}
| "=" {EQUAL}
| "==" {EQUALEQUAL}
| "<>" {LESS_GREATER}
| "&" {AMPERSAND}
| "&&" {AMPERAMPER}
| "||" {BARBAR}
@ -141,7 +140,7 @@ rule token = parse
| "|" {BAR}
| "-" {SUBTRACTIVE "-"}
| "-." {SUBTRACTIVE "-."}
| "^" {POWER}
| "^" {POWER}
| "[" {LBRACKET}
| "]" {RBRACKET}
| "@" {AROBASE}
@ -154,9 +153,9 @@ rule token = parse
{ let s = Lexing.lexeme lexbuf in
begin try
Hashtbl.find keyword_table s
with
with
Not_found -> IDENT id
end
end
}
| ['0'-'9']+
| '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+
@ -168,23 +167,22 @@ rule token = parse
| "(*@ " (['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
let l1 = lexbuf.lex_curr_p in
begin try
pragma lexbuf
with Lexical_error(Unterminated_comment, _, pragma_end) ->
raise(Lexical_error(Unterminated_comment, pragma_start, pragma_end))
with Lexical_error(Unterminated_comment, Loc(_, l2)) ->
raise(Lexical_error(Unterminated_comment, Loc (l1, l2)))
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
{ let comment_start = lexbuf.lex_curr_p in
comment_depth := 1;
begin try
comment lexbuf
with Lexical_error(Unterminated_comment, _, comment_end) ->
with Lexical_error(Unterminated_comment, (Loc (_, comment_end))) ->
raise(Lexical_error(Unterminated_comment,
comment_start, comment_end))
Loc (comment_start, comment_end)))
end;
token lexbuf }
| ['!' '?' '~']
@ -213,43 +211,46 @@ rule token = parse
{ INFIX3(Lexing.lexeme lexbuf) }
| eof {EOF}
| _ {raise (Lexical_error (Illegal_character,
Lexing.lexeme_start lexbuf,
Lexing.lexeme_end lexbuf))}
Loc (Lexing.lexeme_start_p lexbuf,
Lexing.lexeme_end_p lexbuf)))}
and pragma = parse
"(*"
{ let comment_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in
| newline { new_line lexbuf; pragma lexbuf }
| "(*"
{ let comment_start = lexbuf.lex_curr_p in
comment_depth := 1;
begin try
comment lexbuf
with Lexical_error(Unterminated_comment, _, comment_end) ->
with Lexical_error(Unterminated_comment, Loc (_, comment_end)) ->
raise(Lexical_error(Unterminated_comment,
comment_start, comment_end))
Loc (comment_start, comment_end)))
end;
pragma lexbuf }
| "@*)"
{ }
| eof
{ raise(Lexical_error(Unterminated_comment,0,
Lexing.lexeme_start lexbuf)) }
{ raise(Lexical_error(Unterminated_comment, Loc (dummy_pos,
Lexing.lexeme_start_p lexbuf))) }
| _
{ store_string_char(Lexing.lexeme_char lexbuf 0);
pragma lexbuf }
and comment = parse
"(*"
| newline { new_line lexbuf; comment lexbuf }
| "(*"
{ 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
let string_start = lexbuf.lex_curr_p in
begin try
string lexbuf
with Lexical_error(Unterminated_string, _, string_end) ->
raise(Lexical_error(Unterminated_string, string_start, string_end))
with Lexical_error(Unterminated_string, Loc (_, string_end)) ->
raise(Lexical_error
(Unterminated_string, Loc (string_start, string_end)))
end;
comment lexbuf }
| "''"
@ -261,13 +262,14 @@ and comment = parse
| "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
{ comment lexbuf }
| eof
{ raise(Lexical_error(Unterminated_comment,0,
Lexing.lexeme_start lexbuf)) }
{ raise(Lexical_error(Unterminated_comment, Loc(dummy_pos,
Lexing.lexeme_start_p lexbuf))) }
| _
{ comment lexbuf }
and string = parse
'"'
| newline { new_line lexbuf; string lexbuf }
| '"'
{ () }
| '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] *
{ string lexbuf }
@ -278,8 +280,8 @@ and string = parse
{ store_string_char(char_for_decimal_code lexbuf 1);
string lexbuf }
| eof
{ raise (Lexical_error
(Unterminated_string, 0, Lexing.lexeme_start lexbuf)) }
{ raise (Lexical_error(Unterminated_string, Loc (dummy_pos,
Lexing.lexeme_start_p lexbuf))) }
| _
{ store_string_char(Lexing.lexeme_char lexbuf 0);
string lexbuf }

282
compiler/heptagon/parsing/hept_parser.mly
View file

@ -3,12 +3,14 @@
open Signature
open Location
open Names
open Parsetree
open Types
open Hept_parsetree
%}
%token DOT LPAREN RPAREN LBRACE RBRACE COLON SEMICOL
%token EQUAL EQUALEQUAL BARBAR COMMA BAR ARROW LET TEL
%token EQUAL EQUALEQUAL LESS_GREATER BARBAR COMMA BAR ARROW LET TEL
%token <string> Constructor
%token <string> IDENT
%token <int> INT
@ -43,7 +45,7 @@ open Parsetree
%token DOUBLE_DOT
%token AROBASE
%token DOUBLE_LESS DOUBLE_GREATER
%token MAP FOLD MAPFOLD
%token MAP FOLD FOLDI MAPFOLD
%token <string> PREFIX
%token <string> INFIX0
%token <string> INFIX1
@ -61,7 +63,7 @@ open Parsetree
%right ARROW
%left OR
%left AMPERSAND
%left INFIX0 EQUAL
%left INFIX0 EQUAL LESS_GREATER
%right INFIX1
%left INFIX2 SUBTRACTIVE
%left STAR INFIX3
@ -75,20 +77,21 @@ open Parsetree
%left DOT
%start program
%type <Parsetree.program> program
%type <Hept_parsetree.program> program
%start interface
%type <Parsetree.interface> interface
%type <Hept_parsetree.interface> interface
%%
program:
| pragma_headers open_modules const_decs type_decs node_decs EOF
{{ p_pragmas = $1;
p_opened = List.rev $2;
{{ p_modname = "";
p_pragmas = $1;
p_opened = List.rev $2;
p_types = $4;
p_nodes = $5;
p_consts = $3; }}
p_consts = $3; }}
;
pragma_headers:
@ -107,7 +110,7 @@ const_decs:
const_dec:
| CONST IDENT COLON ty_ident EQUAL exp
{ mk_const_dec $2 $4 $6 }
{ mk_const_dec $2 $4 $6 (Loc($startpos,$endpos)) }
;
type_decs:
@ -116,9 +119,14 @@ type_decs:
;
type_dec:
| TYPE IDENT { mk_type_dec $2 Type_abs }
| TYPE IDENT EQUAL enum_ty_desc { mk_type_dec $2 (Type_enum ($4)) }
| TYPE IDENT EQUAL struct_ty_desc { mk_type_dec $2 (Type_struct ($4)) }
| TYPE IDENT
{ mk_type_dec $2 Type_abs (Loc($startpos,$endpos)) }
| TYPE IDENT EQUAL ty_ident
{ mk_type_dec $2 (Type_alias $4) (Loc($startpos,$endpos)) }
| TYPE IDENT EQUAL enum_ty_desc
{ mk_type_dec $2 (Type_enum ($4)) (Loc($startpos,$endpos)) }
| TYPE IDENT EQUAL struct_ty_desc
{ mk_type_dec $2 (Type_struct ($4)) (Loc($startpos,$endpos)) }
;
enum_ty_desc:
@ -138,7 +146,7 @@ label_ty_list:
;
label_ty:
IDENT COLON ty_ident { ($1, $3) }
IDENT COLON ty_ident { $1, $3 }
;
node_decs:
@ -149,16 +157,15 @@ node_decs:
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.current_loc () }}
contract b=block(LET) TEL
{{ n_name = $2;
n_statefull = $1;
n_input = $5;
n_output = $9;
n_contract = $11;
n_block = b;
n_params = $3;
n_loc = (Loc($startpos,$endpos)) }}
;
node_or_fun:
@ -182,7 +189,7 @@ nonmt_params:
param:
| ident_list COLON ty_ident
{ List.map (fun id -> mk_var_dec id $3 Var) $1 }
{ List.map (fun id -> mk_var_dec id $3 Var (Loc($startpos,$endpos))) $1 }
;
out_params:
@ -197,26 +204,19 @@ nonmt_out_params:
node_params:
| /* empty */ { [] }
| DOUBLE_LESS ident_list DOUBLE_GREATER { $2 }
| DOUBLE_LESS nonmt_params 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 }
| CONTRACT b=block(LET) TEL? opt_assume enforce
{ Some{ c_block = b;
c_assume = $4;
c_enforce = $5 } }
;
opt_assume:
| /* empty */ { mk_exp (Econst (Cconstr Initial.ptrue)) }
| /* empty */ { mk_constructor_exp ptrue (Loc($startpos,$endpos)) }
| ASSUME exp { $2 }
;
@ -224,11 +224,6 @@ enforce:
| ENFORCE exp { $2 }
;
opt_with:
| /* empty */ { [] }
| WITH LPAREN params RPAREN { $3 }
;
loc_vars:
| /* empty */ { [] }
| VAR loc_params { $2 }
@ -239,13 +234,14 @@ loc_params:
| var_last SEMICOL loc_params { $1 @ $3 }
;
var_last:
| ident_list COLON ty_ident
{ List.map (fun id -> mk_var_dec id $3 Var) $1 }
| LAST IDENT COLON ty_ident EQUAL const
{ [ mk_var_dec $2 $4 (Last(Some($6))) ] }
{ List.map (fun id -> mk_var_dec id $3 Var (Loc($startpos,$endpos))) $1 }
| LAST IDENT COLON ty_ident EQUAL exp
{ [ mk_var_dec $2 $4 (Last(Some($6))) (Loc($startpos,$endpos)) ] }
| LAST IDENT COLON ty_ident
{ [ mk_var_dec $2 $4 (Last(None)) ] }
{ [ mk_var_dec $2 $4 (Last(None)) (Loc($startpos,$endpos)) ] }
;
ident_list:
@ -254,8 +250,8 @@ ident_list:
;
ty_ident:
| IDENT
{ Tid(Name($1)) }
| qualname
{ Tid $1 }
| ty_ident POWER simple_exp
{ Tarray ($1, $3) }
;
@ -280,28 +276,32 @@ opt_bar:
| BAR {}
;
equ:
| pat EQUAL exp { mk_equation (Eeq($1, $3)) }
block(S):
| l=loc_vars S eq=equs { mk_block l eq (Loc($startpos,$endpos)) }
| l=loc_vars { mk_block l [] (Loc($startpos,$endpos)) }
equ: eq=_equ { mk_equation eq (Loc($startpos,$endpos)) }
_equ:
| pat EQUAL exp { Eeq($1, $3) }
| AUTOMATON automaton_handlers END
{ mk_equation (Eautomaton(List.rev $2)) }
{ Eautomaton(List.rev $2) }
| SWITCH exp opt_bar switch_handlers END
{ mk_equation (Eswitch($2, List.rev $4)) }
{ Eswitch($2, List.rev $4) }
| PRESENT opt_bar present_handlers END
{ mk_equation (Epresent(List.rev $3, mk_block [] [])) }
| PRESENT opt_bar present_handlers DEFAULT loc_vars DO equs END
{ mk_equation (Epresent(List.rev $3, mk_block $5 $7)) }
| IF exp THEN loc_vars DO equs ELSE loc_vars DO equs END
{ mk_equation (Eswitch($2,
[{ w_name = Name("true"); w_block = mk_block $4 $6};
{ w_name = Name("false"); w_block = mk_block $8 $10 }])) }
{ Epresent(List.rev $3, mk_block [] [] (Loc($startpos,$endpos))) }
| PRESENT opt_bar present_handlers DEFAULT b=block(DO) END
{ Epresent(List.rev $3, b) }
| IF exp THEN tb=block(DO) ELSE fb=block(DO) END
{ Eswitch($2,
[{ w_name = ptrue; w_block = tb };
{ w_name = pfalse; w_block = fb }]) }
| RESET equs EVERY exp
{ mk_equation (Ereset($2, $4)) }
{ Ereset(mk_block [] $2 (Loc($startpos,$endpos)), $4) }
;
automaton_handler:
| STATE Constructor loc_vars DO equs opt_until_escapes opt_unless_escapes
{ { s_state = $2; s_block = mk_block $3 $5;
s_until = $6; s_unless = $7 } }
| STATE Constructor b=block(DO) ut=opt_until_escapes ul=opt_unless_escapes
{ { s_state = $2; s_block = b; s_until = ut; s_unless = ul } }
;
automaton_handlers:
@ -338,10 +338,14 @@ escapes:
;
switch_handler:
| constructor loc_vars DO equs
{ { w_name = $1; w_block = mk_block $2 $4 } }
| constructor_or_bool b=block(DO)
{ { w_name = $1; w_block = b } }
;
constructor_or_bool:
| BOOL { if $1 then Q Initial.ptrue else Q Initial.pfalse }
| constructor { $1 }
switch_handlers:
| switch_handler
{ [$1] }
@ -350,8 +354,8 @@ switch_handlers:
;
present_handler:
| exp loc_vars DO equs
{ { p_cond = $1; p_block = mk_block $2 $4 } }
| exp b=block(DO)
{ { p_cond = $1; p_block = b } }
;
present_handlers:
@ -382,86 +386,91 @@ exps:
;
simple_exp:
| IDENT { mk_exp (Evar $1) }
| const { mk_exp (Econst $1) }
| LBRACE field_exp_list RBRACE
{ mk_exp (Estruct $2) }
| LBRACKET array_exp_list RBRACKET
{ mk_exp (Earray $2) }
| LPAREN tuple_exp RPAREN
{ mk_exp (Etuple $2) }
| LPAREN exp RPAREN
{ $2 }
| e=_simple_exp { mk_exp e (Loc($startpos,$endpos)) }
| LPAREN exp RPAREN { $2 }
_simple_exp:
| IDENT { Evar $1 }
| const { Econst $1 }
| LBRACE field_exp_list RBRACE { Estruct $2 }
| LBRACKET array_exp_list RBRACKET { mk_call Earray $2 }
| LPAREN tuple_exp RPAREN { mk_call Etuple $2 }
| simple_exp DOT c=qualname
{ mk_call ~params:[mk_field_exp c (Loc($startpos(c),$endpos(c)))]
Efield [$1] }
;
node_name:
| longname call_params
{ mk_op_desc $1 $2 Enode }
| qualname call_params { mk_app (Enode $1) $2 }
exp:
| simple_exp { $1 }
| e=simple_exp { e }
| e=_exp { mk_exp e (Loc($startpos,$endpos)) }
_exp:
| simple_exp FBY exp
{ mk_exp (Eapp(mk_app Efby, [$1; $3])) }
{ Efby ($1, $3) }
| PRE exp
{ mk_exp (Eapp(mk_app (Epre None), [$2])) }
{ Epre (None, $2) }
| node_name LPAREN exps RPAREN
{ mk_exp (mk_call $1 $3) }
{ Eapp($1, $3) }
| NOT exp
{ mk_exp (mk_op_call "not" [] [$2]) }
{ mk_op_call "not" [$2] }
| exp INFIX4 exp
{ mk_exp (mk_op_call $2 [] [$1; $3]) }
{ mk_op_call $2 [$1; $3] }
| exp INFIX3 exp
{ mk_exp (mk_op_call $2 [] [$1; $3]) }
{ mk_op_call $2 [$1; $3] }
| exp INFIX2 exp
{ mk_exp (mk_op_call $2 [] [$1; $3]) }
{ mk_op_call $2 [$1; $3] }
| exp INFIX1 exp
{ mk_exp (mk_op_call $2 [] [$1; $3]) }
{ mk_op_call $2 [$1; $3] }
| exp INFIX0 exp
{ mk_exp (mk_op_call $2 [] [$1; $3]) }
{ mk_op_call $2 [$1; $3] }
| exp EQUAL exp
{ mk_exp (mk_op_call "=" [] [$1; $3]) }
{ mk_call Eequal [$1; $3] }
| exp LESS_GREATER exp
{ let e = mk_exp (mk_call Eequal [$1; $3]) (Loc($startpos,$endpos)) in
mk_op_call "not" [e] }
| exp OR exp
{ mk_exp (mk_op_call "or" [] [$1; $3]) }
{ mk_op_call "or" [$1; $3] }
| exp STAR exp
{ mk_exp (mk_op_call "*" [] [$1; $3]) }
{ mk_op_call "*" [$1; $3] }
| exp AMPERSAND exp
{ mk_exp (mk_op_call "&" [] [$1; $3]) }
{ mk_op_call "&" [$1; $3] }
| exp SUBTRACTIVE exp
{ mk_exp (mk_op_call $2 [] [$1; $3]) }
{ mk_op_call $2 [$1; $3] }
| PREFIX exp
{ mk_exp (mk_op_call $1 [] [$2]) }
{ mk_op_call $1 [$2] }
| SUBTRACTIVE exp %prec prec_uminus
{ mk_exp (mk_op_call ("~"^$1) [] [$2]) }
{ mk_op_call ("~"^$1) [$2] }
| IF exp THEN exp ELSE exp
{ mk_exp (Eapp(mk_app Eifthenelse, [$2; $4; $6])) }
{ mk_call Eifthenelse [$2; $4; $6] }
| simple_exp ARROW exp
{ mk_exp (Eapp(mk_app Earrow, [$1; $3])) }
{ mk_call Earrow [$1; $3] }
| LAST IDENT
{ mk_exp (Elast $2) }
| simple_exp DOT longname
{ mk_exp (Efield ($1, $3)) }
{ Elast $2 }
/*Array operations*/
| exp POWER simple_exp
{ mk_exp (mk_array_op_call Erepeat [$1; $3]) }
{ mk_call ~params:[$3] Earray_fill [$1] }
| simple_exp indexes
{ mk_exp (mk_array_op_call (Eselect $2) [$1]) }
{ mk_call ~params:$2 Eselect [$1] }
| simple_exp DOT indexes DEFAULT exp
{ mk_exp (mk_array_op_call Eselect_dyn ([$1; $5]@$3)) }
{ mk_call Eselect_dyn ([$1; $5]@$3) }
| LBRACKET exp WITH indexes EQUAL exp RBRACKET
{ mk_exp (mk_array_op_call (Eupdate $4) [$2; $6]) }
{ mk_call Eupdate ($2::$6::$4) }
| simple_exp LBRACKET exp DOUBLE_DOT exp RBRACKET
{ mk_exp (mk_array_op_call Eselect_slice [$1; $3; $5]) }
{ mk_call ~params:[$3; $5] Eselect_slice [$1] }
| exp AROBASE exp
{ mk_exp (mk_array_op_call Econcat [$1; $3]) }
{ mk_call Econcat [$1; $3] }
/*Iterators*/
| iterator longname DOUBLE_LESS simple_exp DOUBLE_GREATER LPAREN exps RPAREN
{ mk_exp (mk_iterator_call $1 $2 [] ($4::$7)) }
| iterator LPAREN longname DOUBLE_LESS array_exp_list DOUBLE_GREATER
| iterator qualname DOUBLE_LESS simple_exp DOUBLE_GREATER LPAREN exps RPAREN
{ mk_iterator_call $1 $2 [] $4 $7 }
| iterator LPAREN qualname DOUBLE_LESS array_exp_list DOUBLE_GREATER
RPAREN DOUBLE_LESS simple_exp DOUBLE_GREATER LPAREN exps RPAREN
{ mk_exp (mk_iterator_call $1 $3 $5 ($9::$12)) }
{ mk_iterator_call $1 $3 $5 $9 $12 }
/*Records operators */
| LBRACE e=simple_exp WITH DOT ln=longname EQUAL nv=exp RBRACE
{ mk_exp (Eapp (mk_app (Efield_update ln), [e; nv])) }
| LBRACE simple_exp WITH DOT c=qualname EQUAL exp RBRACE
{ mk_call ~params:[mk_field_exp c (Loc($startpos(c),$endpos(c)))]
Efield_update [$2; $7] }
;
call_params:
@ -472,6 +481,7 @@ call_params:
iterator:
| MAP { Imap }
| FOLD { Ifold }
| FOLDI { Ifoldi }
| MAPFOLD { Imapfold }
;
@ -481,20 +491,24 @@ indexes:
;
constructor:
| Constructor { Name($1) } %prec prec_ident
| Constructor DOT Constructor { Modname({qual = $1; id = $3}) }
| BOOL { Name(if $1 then "true" else "false") }
| Constructor { ToQ $1 } %prec prec_ident
| Constructor DOT Constructor { Q {qual = $1; name = $3} }
;
longname:
| ident { Name($1) }
| Constructor DOT ident { Modname({qual = $1; id = $3}) }
qualname:
| ident { ToQ $1 }
| Constructor DOT ident { Q {qual = $1; name = $3} }
;
const:
| INT { Cint($1) }
| FLOAT { Cfloat($1) }
| constructor { Cconstr($1) }
const: c=_const { mk_static_exp c (Loc($startpos,$endpos)) }
_const:
| INT { Sint $1 }
| FLOAT { Sfloat $1 }
| BOOL { Sbool $1 }
| constructor { Sconstructor $1 }
| Constructor DOT ident
{ Svar (Q {qual = $1; name = $3}) }
;
tuple_exp:
@ -513,7 +527,7 @@ array_exp_list:
;
field_exp:
| longname EQUAL exp { ($1, $3) }
| qualname EQUAL exp { ($1, $3) }
;
/* identifiers */
@ -547,15 +561,19 @@ interface_decls:
;
interface_decl:
| type_dec { mk_interface_decl (Itypedef $1) }
| OPEN Constructor { mk_interface_decl (Iopen $2) }
| id=_interface_decl { mk_interface_decl id (Loc($startpos,$endpos)) }
_interface_decl:
| type_dec { Itypedef $1 }
| const_dec { Iconstdef $1 }
| OPEN Constructor { Iopen $2 }
| VAL node_or_fun ident node_params LPAREN params_signature RPAREN
RETURNS LPAREN params_signature RPAREN
{ mk_interface_decl (Isignature({ sig_name = $3;
sig_inputs = $6;
sig_statefull = $2;
sig_outputs = $10;
sig_params = $4; })) }
{ Isignature({ sig_name = $3;
sig_inputs = $6;
sig_statefull = $2;
sig_outputs = $10;
sig_params = $4;
sig_loc = (Loc($startpos,$endpos)) }) }
;
params_signature:

248
compiler/heptagon/parsing/hept_parsetree.ml Normal file
View file

@ -0,0 +1,248 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
open Names
open Location
open Signature
open Types
type qualname =
| Q of Names.qualname (* already qualified name *)
| ToQ of name (* name to qualify in the scoping process *)
type type_name = qualname
type fun_name = qualname
type field_name = qualname
type constructor_name = qualname
type constant_name = qualname
type module_name = name
type static_exp = { se_desc: static_exp_desc; se_ty: ty; se_loc: location }
and static_exp_desc =
| Svar of constant_name
| Sint of int
| Sfloat of float
| Sbool of bool
| Sconstructor of constructor_name
| Sfield of field_name
| Stuple of static_exp list
| Sarray_power of static_exp * static_exp (** power : 0^n : [0,0,0,0,0,..] *)
| Sarray of static_exp list (** [ e1, e2, e3 ] *)
| Srecord of (field_name * static_exp) list (** { f1 = e1; f2 = e2; ... } *)
| Sop of fun_name * static_exp list (** defined ops for now in pervasives *)
type iterator_type =
| Imap
| Ifold
| Ifoldi
| Imapfold
type ty =
| Tprod of ty list
| Tid of qualname
| Tarray of ty * exp
and exp =
{ e_desc: desc;
e_loc: location }
and desc =
| Econst of static_exp
| Evar of name
| Elast of name
| Epre of exp option * exp
| Efby of exp * exp
| Estruct of (qualname * exp) list
| Eapp of app * exp list
| Eiterator of iterator_type * app * exp * exp list
and app = { a_op: op; a_params: exp list; }
and op =
| Eequal
| Etuple
| Enode of qualname
| Efun of qualname
| Eifthenelse
| Earrow
| Efield
| Efield_update (* field name args would be [record ; value] *)
| Earray
| Earray_fill
| Eselect
| Eselect_dyn
| Eselect_slice
| Eupdate
| Econcat
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 block * 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 : constructor_name;
w_block : block; }
and present_handler =
{ p_cond : exp;
p_block : block; }
and var_dec =
{ v_name : name;
v_type : ty;
v_last : last;
v_loc : location; }
and last = Var | Last of exp option
type type_dec =
{ t_name : name;
t_desc : type_desc;
t_loc : location }
and type_desc =
| Type_abs
| Type_alias of ty
| Type_enum of name list
| Type_struct of (name * ty) list
type contract =
{ c_assume : exp;
c_enforce : exp;
c_block : block
}
type node_dec =
{ n_name : name;
n_statefull : bool;
n_input : var_dec list;
n_output : var_dec list;
n_contract : contract option;
n_block : block;
n_loc : location;
n_params : var_dec list; }
type const_dec =
{ c_name : name;
c_type : ty;
c_value : exp;
c_loc : location; }
type program =
{ p_modname : name;
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 arg = { a_type : ty; a_name : name option }
type signature =
{ sig_name : name;
sig_inputs : arg list;
sig_statefull : bool;
sig_outputs : arg list;
sig_params : var_dec list;
sig_loc : location }
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
| Iconstdef of const_dec
| Isignature of signature
(* Helper functions to create AST. *)
let mk_exp desc loc =
{ e_desc = desc; e_loc = loc }
let mk_app op params =
{ a_op = op; a_params = params }
let mk_call ?(params=[]) op exps =
Eapp (mk_app op params, exps)
let mk_op_call ?(params=[]) s exps =
mk_call ~params:params
(Efun (Q { qual = "Pervasives"; name = s })) exps
let mk_iterator_call it ln params n exps =
Eiterator (it, mk_app (Enode ln) params, n, exps)
let mk_static_exp ?(ty = invalid_type) desc loc =
{ se_desc = desc; se_ty = ty; se_loc = loc }
let mk_constructor_exp f loc =
mk_exp (Econst (mk_static_exp (Sconstructor f) loc)) loc
let mk_field_exp f loc =
mk_exp (Econst (mk_static_exp (Sfield f) loc)) loc
let mk_type_dec name desc loc =
{ t_name = name; t_desc = desc; t_loc = loc }
let mk_equation desc loc =
{ eq_desc = desc; eq_loc = loc }
let mk_interface_decl desc loc =
{ interf_desc = desc; interf_loc = loc }
let mk_var_dec name ty last loc =
{ v_name = name; v_type = ty;
v_last = last; v_loc = loc }
let mk_block locals eqs loc =
{ b_local = locals; b_equs = eqs;
b_loc = loc }
let mk_const_dec id ty e loc =
{ c_name = id; c_type = ty; c_value = e; c_loc = loc }
let mk_arg name ty =
{ a_type = ty; a_name = name }
let ptrue = Q Initial.ptrue
let pfalse = Q Initial.pfalse

305
compiler/heptagon/parsing/hept_parsetree_mapfold.ml Normal file
View file

@ -0,0 +1,305 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Generic mapred over Heptagon Parsetree AST *)
open Misc
open Global_mapfold
open Hept_parsetree
type 'a hept_it_funs = {
ty : 'a hept_it_funs -> 'a -> Hept_parsetree.ty -> Hept_parsetree.ty * 'a;
app:
'a hept_it_funs -> 'a -> Hept_parsetree.app -> Hept_parsetree.app * 'a;
block:
'a hept_it_funs -> 'a -> Hept_parsetree.block -> Hept_parsetree.block * 'a;
edesc:
'a hept_it_funs -> 'a -> Hept_parsetree.desc -> Hept_parsetree.desc * 'a;
eq:
'a hept_it_funs -> 'a -> Hept_parsetree.eq -> Hept_parsetree.eq * 'a;
eqdesc:
'a hept_it_funs -> 'a -> Hept_parsetree.eqdesc ->
Hept_parsetree.eqdesc * 'a;
escape_unless :
'a hept_it_funs -> 'a -> Hept_parsetree.escape ->
Hept_parsetree.escape * 'a;
escape_until:
'a hept_it_funs -> 'a -> Hept_parsetree.escape ->
Hept_parsetree.escape * 'a;
exp:
'a hept_it_funs -> 'a -> Hept_parsetree.exp -> Hept_parsetree.exp * 'a;
pat:
'a hept_it_funs -> 'a -> pat -> Hept_parsetree.pat * 'a;
present_handler:
'a hept_it_funs -> 'a -> Hept_parsetree.present_handler
-> Hept_parsetree.present_handler * 'a;
state_handler:
'a hept_it_funs -> 'a -> Hept_parsetree.state_handler
-> Hept_parsetree.state_handler * 'a;
switch_handler:
'a hept_it_funs -> 'a -> Hept_parsetree.switch_handler
-> Hept_parsetree.switch_handler * 'a;
var_dec:
'a hept_it_funs -> 'a -> Hept_parsetree.var_dec ->
Hept_parsetree.var_dec * 'a;
last:
'a hept_it_funs -> 'a -> Hept_parsetree.last -> Hept_parsetree.last * 'a;
contract:
'a hept_it_funs -> 'a -> Hept_parsetree.contract ->
Hept_parsetree.contract * 'a;
node_dec:
'a hept_it_funs -> 'a -> Hept_parsetree.node_dec ->
Hept_parsetree.node_dec * 'a;
const_dec:
'a hept_it_funs -> 'a -> Hept_parsetree.const_dec ->
Hept_parsetree.const_dec * 'a;
program:
'a hept_it_funs -> 'a -> Hept_parsetree.program ->
Hept_parsetree.program * 'a;
global_funs: 'a Global_mapfold.global_it_funs }
let rec exp_it funs acc e = funs.exp funs acc e
and exp funs acc e =
let e_desc, acc = edesc_it funs acc e.e_desc in
{ e with e_desc = e_desc }, acc
and edesc_it funs acc ed =
try funs.edesc funs acc ed
with Fallback -> edesc funs acc ed
and edesc funs acc ed = match ed with
| Econst se ->
let se, acc = static_exp_it funs.global_funs acc se in
Econst se, acc
| Evar _ | Elast _ -> ed, acc
| Epre (se, e) ->
let se, acc = optional_wacc (exp_it funs) acc se in
let e, acc = exp_it funs acc e in
Epre (se, e), acc
| Efby (e1, e2) ->
let e1, acc = exp_it funs acc e1 in
let e2, acc = exp_it funs acc e2 in
Efby (e1,e2), acc
| Estruct n_e_list ->
let aux acc (n,e) =
let e, acc = exp_it funs acc e in
(n,e), acc in
let n_e_list, acc = mapfold aux acc n_e_list in
Estruct n_e_list, acc
| Eapp (app, args) ->
let app, acc = app_it funs acc app in
let args, acc = mapfold (exp_it funs) acc args in
Eapp (app, args), acc
| Eiterator (i, app, param, args) ->
let app, acc = app_it funs acc app in
let param, acc = exp_it funs acc param in
let args, acc = mapfold (exp_it funs) acc args in
Eiterator (i, app, param, args), acc
and app_it funs acc a = funs.app funs acc a
and app funs acc a =
let p, acc = mapfold (exp_it funs) acc a.a_params in
{ a with a_params = p }, acc
and pat_it funs acc p =
try funs.pat funs acc p
with Fallback -> pat funs acc p
and pat funs acc p = match p with
| Etuplepat pl ->
let pl, acc = mapfold (pat_it funs) acc pl in
Etuplepat pl, acc
| Evarpat _ -> p, acc
and eq_it funs acc eq = funs.eq funs acc eq
and eq funs acc eq =
let eqdesc, acc = eqdesc_it funs acc eq.eq_desc in
{ eq with eq_desc = eqdesc }, acc
and eqdesc_it funs acc eqd =
try funs.eqdesc funs acc eqd
with Fallback -> eqdesc funs acc eqd
and eqdesc funs acc eqd = match eqd with
| Eautomaton st_h_l ->
let st_h_l, acc = mapfold (state_handler_it funs) acc st_h_l in
Eautomaton st_h_l, acc
| Eswitch (e, sw_h_l) ->
let e, acc = exp_it funs acc e in
let sw_h_l, acc = mapfold (switch_handler_it funs) acc sw_h_l in
Eswitch (e, sw_h_l), acc
| Epresent (p_h_l, b) ->
let p_h_l, acc = mapfold (present_handler_it funs) acc p_h_l in
let b, acc = block_it funs acc b in
Epresent (p_h_l, b), acc
| Ereset (b, e) ->
let b, acc = block_it funs acc b in
let e, acc = exp_it funs acc e in
Ereset (b, e), acc
| Eeq (p, e) ->
let p, acc = pat_it funs acc p in
let e, acc = exp_it funs acc e in
Eeq (p, e), acc
and block_it funs acc b = funs.block funs acc b
and block funs acc b =
(* defnames ty ?? *)
let b_local, acc = mapfold (var_dec_it funs) acc b.b_local in
let b_equs, acc = mapfold (eq_it funs) acc b.b_equs in
{ b with b_local = b_local; b_equs = b_equs }, acc
and state_handler_it funs acc s = funs.state_handler funs acc s
and state_handler funs acc s =
let s_unless, acc = mapfold (escape_unless_it funs) acc s.s_unless in
let s_block, acc = block_it funs acc s.s_block in
let s_until, acc = mapfold (escape_until_it funs) acc s.s_until in
{ s with s_block = s_block; s_until = s_until; s_unless = s_unless }, acc
(** escape is a generic function to deal with the automaton state escapes,
still the iterator function record differentiate until and unless
with escape_until_it and escape_unless_it *)
and escape_unless_it funs acc esc = funs.escape_unless funs acc esc
and escape_until_it funs acc esc = funs.escape_until funs acc esc
and escape funs acc esc =
let e_cond, acc = exp_it funs acc esc.e_cond in
{ esc with e_cond = e_cond }, acc
and switch_handler_it funs acc sw = funs.switch_handler funs acc sw
and switch_handler funs acc sw =
let w_block, acc = block_it funs acc sw.w_block in
{ sw with w_block = w_block }, acc
and present_handler_it funs acc ph = funs.present_handler funs acc ph
and present_handler funs acc ph =
let p_cond, acc = exp_it funs acc ph.p_cond in
let p_block, acc = block_it funs acc ph.p_block in
{ ph with p_cond = p_cond; p_block = p_block }, acc
and var_dec_it funs acc vd = funs.var_dec funs acc vd
and var_dec funs acc vd =
(* v_type ??? *)
let v_last, acc = last_it funs acc vd.v_last in
{ vd with v_last = v_last }, acc
and last_it funs acc l =
try funs.last funs acc l
with Fallback -> last funs acc l
and last funs acc l = match l with
| Var -> l, acc
| Last sto ->
let sto, acc = optional_wacc (exp_it funs) acc sto in
Last sto, acc
and contract_it funs acc c = funs.contract funs acc c
and contract funs acc c =
let c_assume, acc = exp_it funs acc c.c_assume in
let c_enforce, acc = exp_it funs acc c.c_enforce in
let c_block, acc = block_it funs acc c.c_block in
{ c with
c_assume = c_assume; c_enforce = c_enforce; c_block = c_block }
, acc
and param_it funs acc vd = funs.param funs acc vd
and param funs acc vd =
let v_last, acc = last_it funs acc vd.v_last in
{ vd with v_last = v_last }, acc
and node_dec_it funs acc nd = funs.node_dec funs acc nd
and node_dec funs acc nd =
let n_input, acc = mapfold (var_dec_it funs) acc nd.n_input in
let n_output, acc = mapfold (var_dec_it funs) acc nd.n_output in
let n_params, acc = mapfold (var_dec_it funs) acc nd.n_params in
let n_contract, acc = optional_wacc (contract_it funs) acc nd.n_contract in
let n_block, acc = block_it funs acc nd.n_block in
{ nd with
n_input = n_input;
n_output = n_output;
n_block = n_block;
n_params = n_params;
n_contract = n_contract }
, acc
and ty_it funs acc t = try funs.ty funs acc t with Fallback -> ty funs acc t
and ty funs acc t = match t with
| Tid _ -> t, acc
| Tprod t_l -> let t_l, acc = mapfold (ty_it funs) acc t_l in Tprod t_l, acc
| Tarray (t, e) ->
let t, acc = ty_it funs acc t in
let e, acc = exp_it funs acc e in
Tarray (t, e), acc
and const_dec_it funs acc c = funs.const_dec funs acc c
and const_dec funs acc c =
let c_type, acc = ty_it funs acc c.c_type in
let c_value, acc = exp_it funs acc c.c_value in
{ c with c_value = c_value; c_type = c_type }, acc
and program_it funs acc p = funs.program funs acc p
and program funs acc p =
let cd_list, acc = mapfold (const_dec_it funs) acc p.p_consts in
let nd_list, acc = mapfold (node_dec_it funs) acc p.p_nodes in
{ p with p_consts = cd_list; p_nodes = nd_list }, acc
let defaults = {
ty = ty;
app = app;
block = block;
edesc = edesc;
eq = eq;
eqdesc = eqdesc;
escape_unless = escape;
escape_until = escape;
exp = exp;
pat = pat;
present_handler = present_handler;
state_handler = state_handler;
switch_handler = switch_handler;
var_dec = var_dec;
last = last;
contract = contract;
node_dec = node_dec;
const_dec = const_dec;
program = program;
global_funs = Global_mapfold.defaults }
let defaults_stop = {
ty = stop;
app = stop;
block = stop;
edesc = stop;
eq = stop;
eqdesc = stop;
escape_unless = stop;
escape_until = stop;
exp = stop;
pat = stop;
present_handler = stop;
state_handler = stop;
switch_handler = stop;
var_dec = stop;
last = stop;
contract = stop;
node_dec = stop;
const_dec = stop;
program = stop;
global_funs = Global_mapfold.defaults_stop }

495
compiler/heptagon/parsing/hept_scoping.ml Normal file
View file

@ -0,0 +1,495 @@
(** Scoping. Introduces unique indexes for local names and replace global
names by qualified names *)
(* [local_const] is the environnement with local constant variables,
that is for now only the statics node parameters.
It is built with [build_const].
When qualifying a constant var,
it is first check in the local_const env, so qualified with [local_qn]
if not found we try to qualify with the global env. *)
(* The global environement is initialized by the scoping pass.
This allow at the same time
to qualify types, constants, constructors, fields and node calls,
according to the current module definitions and opened modules. *)
(* [env] of type Rename.t is the renaming environnement
used to map a var name to a var ident.
It is initialized at node declaration level with the inputs and outputs,
and then appended with the local var declarations at each block level
with the [build] function. *)
(* convention : static params are set as the first static args,
op<a1,a2> (a3) == op <a1> (a2,a3) == op (a1,a2,a3) *)
open Location
open Types
open Hept_parsetree
open Names
open Idents
open Format
open Static
open Global_printer
open Modules
module Error =
struct
type error =
| Evar_unbound of name
| Equal_notfound of name*qualname
| Equal_unbound of name*name
| Enot_last of name
| Evariable_already_defined of name
| Econst_variable_already_defined of name
| Estatic_exp_expected
let message loc kind =
begin match kind with
| Evar_unbound name ->
eprintf "%aThe variable %s is unbound.@."
print_location loc
name
| Equal_notfound (s,q) ->
eprintf "%aThe qualified %s %a can't be found.@."
print_location loc
s print_qualname q
| Equal_unbound (s,n) ->
eprintf "%aUnbound %s %a.@."
print_location loc
s print_name n
| Enot_last name ->
eprintf "%aThe variable %s should be declared as a last.@."
print_location loc
name
| Evariable_already_defined name ->
eprintf "%aThe variable %s is already defined.@."
print_location loc
name
| Econst_variable_already_defined name ->
eprintf "%aThe const variable %s is already defined.@."
print_location loc
name
| Estatic_exp_expected ->
eprintf "%aA static expression was expected.@."
print_location loc
end;
raise Misc.Error
exception ScopingError of error
let error kind = raise (ScopingError(kind))
end
open Error
(** {3 Qualify when ToQ and check when Q according to the global env } *)
let _qualify_with_error s qfun cqfun q = match q with
| ToQ name ->
(try qfun name with Not_found -> error (Equal_unbound (s,name)))
| Q q ->
if cqfun q then q else error (Equal_notfound (s,q))
let qualify_value = _qualify_with_error "value" qualify_value check_value
let qualify_type = _qualify_with_error "type" qualify_type check_type
let qualify_constrs =
_qualify_with_error "constructor" qualify_constrs check_constrs
let qualify_field = _qualify_with_error "field" qualify_field check_field
(** Qualify a var name as a constant variable,
if not in local_const or global_const then raise Not_found *)
let qualify_var_as_const local_const c =
if S.mem c local_const
then local_qn c
else qualify_const c
(** Qualify with [Names.local_qualname] when in local_const,
otherwise qualify according to the global env *)
let qualify_const local_const c = match c with
| ToQ c -> (try qualify_var_as_const local_const c
with Not_found -> error (Equal_unbound ("constant",c )))
| Q q -> if check_const q then q else raise Not_static
module Rename =
struct
open Error
include
(Map.Make (struct type t = string let compare = String.compare end))
(** Rename a var *)
let var loc env n =
try fst (find n env)
with Not_found -> message loc (Evar_unbound n)
(** Rename a last *)
let last loc env n =
try
let id, last = find n env in
if not last then message loc (Enot_last n) else id
with Not_found -> message loc (Evar_unbound n)
(** Add a var *)
let add_var loc env n =
if mem n env then message loc (Evariable_already_defined n)
else
add n (ident_of_name n, false) env
(** Add a last *)
let add_last loc env n =
if mem n env then message loc (Evariable_already_defined n)
else
add n (ident_of_name n, true) env
(** Add a var dec *)
let add env vd =
let add = match vd.v_last with
| Var -> add_var
| Last _ -> add_last in
add vd.v_loc env vd.v_name
(** Append a list of var dec *)
let append env vd_list = List.fold_left add env vd_list
end
(** Function to build the defined static parameters set *)
let build_const loc vd_list =
let _add_const_var loc c local_const =
if S.mem c local_const
then Error.message loc (Error.Econst_variable_already_defined c)
else S.add c local_const in
let build local_const vd =
_add_const_var loc vd.v_name local_const in
List.fold_left build S.empty vd_list
(** { 3 Translate the AST into Heptagon. } *)
let translate_iterator_type = function
| Imap -> Heptagon.Imap
| Ifold -> Heptagon.Ifold
| Ifoldi -> Heptagon.Ifoldi
| Imapfold -> Heptagon.Imapfold
(** convention : static params are set as the first static args,
op<a1,a2> (a3) == op <a1> (a2,a3) == op (a1,a2,a3) *)
let static_app_from_app app args=
match app.a_op with
| Efun (Q ({ qual = "Pervasives" } as q))
| Enode (Q ({ qual = "Pervasives" } as q)) ->
q, (app.a_params @ args)
| _ -> raise Not_static
let rec translate_static_exp local_const se =
try
let se_d = translate_static_exp_desc local_const se.se_desc in
Types.mk_static_exp ~loc:se.se_loc se_d
with
| ScopingError err -> message se.se_loc err
and translate_static_exp_desc local_const ed =
let t = translate_static_exp local_const in
match ed with
| Svar q -> Types.Svar (qualify_const local_const q)
| Sint i -> Types.Sint i
| Sfloat f -> Types.Sfloat f
| Sbool b -> Types.Sbool b
| Sconstructor c -> Types.Sconstructor (qualify_constrs c)
| Sfield c -> Types.Sfield (qualify_field c)
| Stuple se_list -> Types.Stuple (List.map t se_list)
| Sarray_power (se,sn) -> Types.Sarray_power (t se, t sn)
| Sarray se_list -> Types.Sarray (List.map t se_list)
| Srecord se_f_list ->
let qualf (f, se) = (qualify_field f, t se) in
Types.Srecord (List.map qualf se_f_list)
| Sop (fn, se_list) -> Types.Sop (qualify_value fn, List.map t se_list)
let rec static_exp_of_exp local_const e =
try
let t = static_exp_of_exp local_const in
let desc = match e.e_desc with
| Evar n -> Types.Svar (qualify_const local_const (ToQ n))
| Econst se -> translate_static_exp_desc local_const se.se_desc
| Eapp({ a_op = Earray_fill; a_params = [n] }, [e]) ->
Types.Sarray_power (t e, t n)
| Eapp({ a_op = Earray }, e_list) ->
Types.Sarray (List.map t e_list)
| Eapp({ a_op = Etuple }, e_list) ->
Types.Stuple (List.map t e_list)
| Eapp(app, e_list) ->
let op, args = static_app_from_app app e_list in
Types.Sop (op, List.map t args)
| Estruct e_list ->
Types.Srecord (List.map (fun (f,e) -> qualify_field f, t e) e_list)
| _ -> raise Not_static in
Types.mk_static_exp ~loc:e.e_loc desc
with
| ScopingError err -> message e.e_loc err
let expect_static_exp local_const e =
try static_exp_of_exp local_const e
with Not_static -> message e.e_loc Estatic_exp_expected
let rec translate_type loc local_const ty =
try
(match ty with
| Tprod ty_list ->
Types.Tprod(List.map (translate_type loc local_const) ty_list)
| Tid ln -> Types.Tid (qualify_type ln)
| Tarray (ty, e) ->
let ty = translate_type loc local_const ty in
Types.Tarray (ty, expect_static_exp local_const e))
with
| ScopingError err -> message loc err
and translate_exp local_const env e =
let desc =
(*try (* try to see if the exp is a constant *)
Heptagon.Econst (static_exp_of_exp local_const e)
with
Not_static -> *) translate_desc e.e_loc local_const env e.e_desc in
{ Heptagon.e_desc = desc;
Heptagon.e_ty = Types.invalid_type;
Heptagon.e_loc = e.e_loc }
and translate_desc loc local_const env = function
| Econst c -> Heptagon.Econst (translate_static_exp local_const c)
| Evar x -> (
try (* First check if it is a const var *)
Heptagon.Econst
(Types.mk_static_exp
~loc:loc (Types.Svar (qualify_var_as_const local_const x)))
with Not_found -> Heptagon.Evar (Rename.var loc env x))
| Elast x -> Heptagon.Elast (Rename.last loc env x)
| Epre (None, e) -> Heptagon.Epre (None, translate_exp local_const env e)
| Epre (Some c, e) ->
Heptagon.Epre (Some (expect_static_exp local_const c),
translate_exp local_const env e)
| Efby (e1, e2) -> Heptagon.Efby (translate_exp local_const env e1,
translate_exp local_const env e2)
| Estruct f_e_list ->
let f_e_list =
List.map (fun (f,e) -> qualify_field f, translate_exp local_const env e)
f_e_list in
Heptagon.Estruct f_e_list
| Eapp ({ a_op = op; a_params = params }, e_list) ->
let e_list = List.map (translate_exp local_const env) e_list in
let params = List.map (expect_static_exp local_const) params in
let app = Heptagon.mk_op ~params:params (translate_op op) in
Heptagon.Eapp (app, e_list, None)
| Eiterator (it, { a_op = op; a_params = params }, n, e_list) ->
let e_list = List.map (translate_exp local_const env) e_list in
let n = expect_static_exp local_const n in
let params = List.map (expect_static_exp local_const) params in
let app = Heptagon.mk_op ~params:params (translate_op op) in
Heptagon.Eiterator (translate_iterator_type it,
app, n, e_list, None)
and translate_op = function
| Eequal -> Heptagon.Eequal
| Earrow -> Heptagon.Earrow
| Eifthenelse -> Heptagon.Eifthenelse
| Efield -> Heptagon.Efield
| Efield_update -> Heptagon.Efield_update
| Etuple -> Heptagon.Etuple
| Earray -> Heptagon.Earray
| Eselect -> Heptagon.Eselect
| Eupdate -> Heptagon.Eupdate
| Earray_fill -> Heptagon.Earray_fill
| Eselect_slice -> Heptagon.Eselect_slice
| Econcat -> Heptagon.Econcat
| Eselect_dyn -> Heptagon.Eselect_dyn
| Efun ln -> Heptagon.Efun (qualify_value ln)
| Enode ln -> Heptagon.Enode (qualify_value ln)
and translate_pat loc env = function
| Evarpat x -> Heptagon.Evarpat (Rename.var loc env x)
| Etuplepat l -> Heptagon.Etuplepat (List.map (translate_pat loc env) l)
let rec translate_eq local_const env eq =
{ Heptagon.eq_desc = translate_eq_desc eq.eq_loc local_const env eq.eq_desc ;
Heptagon.eq_statefull = false;
Heptagon.eq_loc = eq.eq_loc }
and translate_eq_desc loc local_const env = function
| Eswitch(e, switch_handlers) ->
let sh = List.map
(translate_switch_handler loc local_const env)
switch_handlers in
Heptagon.Eswitch (translate_exp local_const env e, sh)
| Eeq(p, e) ->
Heptagon.Eeq (translate_pat loc env p, translate_exp local_const env e)
| Epresent (present_handlers, b) ->
Heptagon.Epresent
(List.map (translate_present_handler local_const env) present_handlers
, fst (translate_block local_const env b))
| Eautomaton state_handlers ->
Heptagon.Eautomaton (List.map (translate_state_handler local_const env)
state_handlers)
| Ereset (b, e) ->
let b, _ = translate_block local_const env b in
Heptagon.Ereset (b, translate_exp local_const env e)
and translate_block local_const env b =
let env = Rename.append env b.b_local in
{ Heptagon.b_local = translate_vd_list local_const env b.b_local;
Heptagon.b_equs = List.map (translate_eq local_const env) b.b_equs;
Heptagon.b_defnames = Env.empty;
Heptagon.b_statefull = false;
Heptagon.b_loc = b.b_loc }, env
and translate_state_handler local_const env sh =
let b, env = translate_block local_const env sh.s_block in
{ Heptagon.s_state = sh.s_state;
Heptagon.s_block = b;
Heptagon.s_until = List.map (translate_escape local_const env) sh.s_until;
Heptagon.s_unless =
List.map (translate_escape local_const env) sh.s_unless; }
and translate_escape local_const env esc =
{ Heptagon.e_cond = translate_exp local_const env esc.e_cond;
Heptagon.e_reset = esc.e_reset;
Heptagon.e_next_state = esc.e_next_state }
and translate_present_handler local_const env ph =
{ Heptagon.p_cond = translate_exp local_const env ph.p_cond;
Heptagon.p_block = fst (translate_block local_const env ph.p_block) }
and translate_switch_handler loc local_const env sh =
try
{ Heptagon.w_name = qualify_constrs sh.w_name;
Heptagon.w_block = fst (translate_block local_const env sh.w_block) }
with
| ScopingError err -> message loc err
and translate_var_dec local_const env vd =
(* env is initialized with the declared vars before their translation *)
{ Heptagon.v_ident = Rename.var vd.v_loc env vd.v_name;
Heptagon.v_type = translate_type vd.v_loc local_const vd.v_type;
Heptagon.v_last = translate_last local_const vd.v_last;
Heptagon.v_loc = vd.v_loc }
and translate_vd_list local_const env =
List.map (translate_var_dec local_const env)
and translate_last local_const = function
| Var -> Heptagon.Var
| Last (None) -> Heptagon.Last None
| Last (Some e) -> Heptagon.Last (Some (expect_static_exp local_const e))
let translate_contract local_const env ct =
let b, _ = translate_block local_const env ct.c_block in
{ Heptagon.c_assume = translate_exp local_const env ct.c_assume;
Heptagon.c_enforce = translate_exp local_const env ct.c_enforce;
Heptagon.c_block = b }
let params_of_var_decs local_const =
List.map (fun vd -> Signature.mk_param
vd.v_name
(translate_type vd.v_loc local_const vd.v_type))
let args_of_var_decs local_const =
List.map (fun vd -> Signature.mk_arg
(Some vd.v_name)
(translate_type vd.v_loc local_const vd.v_type))
let translate_node node =
(* Node's params go to local_const env *)
let local_const = build_const node.n_loc node.n_params in
(* Inputs and outputs define the initial local env *)
let env0 = Rename.append Rename.empty (node.n_input @ node.n_output) in
let params = params_of_var_decs local_const node.n_params in
let inputs = translate_vd_list local_const env0 node.n_input in
let outputs = translate_vd_list local_const env0 node.n_output in
let b, env = translate_block local_const env0 node.n_block in
let contract =
Misc.optional (translate_contract local_const env) node.n_contract in
(* the env of the block is used in the contract translation *)
let n = current_qual node.n_name in
(* add the node signature to the environment *)
let i = args_of_var_decs local_const node.n_input in
let o = args_of_var_decs local_const node.n_output in
let p = params_of_var_decs local_const node.n_params in
add_value n (Signature.mk_node i o node.n_statefull p);
{ Heptagon.n_name = n;
Heptagon.n_statefull = node.n_statefull;
Heptagon.n_input = inputs;
Heptagon.n_output = outputs;
Heptagon.n_contract = contract;
Heptagon.n_block = b;
Heptagon.n_loc = node.n_loc;
Heptagon.n_params = params;
Heptagon.n_params_constraints = []; }
let translate_typedec ty =
let n = current_qual ty.t_name in
let tydesc = match ty.t_desc with
| Type_abs ->
add_type n Signature.Tabstract;
Heptagon.Type_abs
| Type_alias t ->
let t = translate_type ty.t_loc S.empty t in
add_type n (Signature.Talias t);
Heptagon.Type_alias t
| Type_enum(tag_list) ->
let tag_list = List.map current_qual tag_list in
List.iter (fun tag -> add_constrs tag n) tag_list;
add_type n (Signature.Tenum tag_list);
Heptagon.Type_enum tag_list
| Type_struct(field_ty_list) ->
let translate_field_type (f,t) =
let f = current_qual f in
let t = translate_type ty.t_loc S.empty t in
add_field f n;
Signature.mk_field f t in
let field_list = List.map translate_field_type field_ty_list in
add_type n (Signature.Tstruct field_list);
Heptagon.Type_struct field_list in
{ Heptagon.t_name = n;
Heptagon.t_desc = tydesc;
Heptagon.t_loc = ty.t_loc }
let translate_const_dec cd =
let c_name = current_qual cd.c_name in
let c_type = translate_type cd.c_loc S.empty cd.c_type in
let c_value = expect_static_exp S.empty cd.c_value in
add_const c_name (Signature.mk_const_def c_type c_value);
{ Heptagon.c_name = c_name;
Heptagon.c_type = c_type;
Heptagon.c_value = c_value;
Heptagon.c_loc = cd.c_loc; }
let translate_program p =
List.iter open_module p.p_opened;
let consts = List.map translate_const_dec p.p_consts in
let types = List.map translate_typedec p.p_types in
let nodes = List.map translate_node p.p_nodes in
{ Heptagon.p_modname = p.p_modname;
Heptagon.p_opened = p.p_opened;
Heptagon.p_types = types;
Heptagon.p_nodes = nodes;
Heptagon.p_consts = consts; }
let translate_signature s =
let local_const = build_const s.sig_loc s.sig_params in
let translate_arg a =
Signature.mk_arg a.a_name (translate_type s.sig_loc local_const a.a_type) in
let n = current_qual s.sig_name in
let i = List.map translate_arg s.sig_inputs in
let o = List.map translate_arg s.sig_outputs in
let p = params_of_var_decs local_const s.sig_params in
add_value n (Signature.mk_node i o s.sig_statefull p);
Heptagon.mk_signature n i o s.sig_statefull p s.sig_loc
let translate_interface_desc = function
| Iopen n -> open_module n; Heptagon.Iopen n
| Itypedef tydec -> Heptagon.Itypedef (translate_typedec tydec)
| Iconstdef const_dec -> Heptagon.Iconstdef (translate_const_dec const_dec)
| Isignature s -> Heptagon.Isignature (translate_signature s)
let translate_interface_decl idecl =
let desc = translate_interface_desc idecl.interf_desc in
{ Heptagon.interf_desc = desc;
Heptagon.interf_loc = idecl.interf_loc }
let translate_interface i = List.map translate_interface_decl i

218
compiler/heptagon/parsing/parsetree.ml
View file

@ -1,218 +0,0 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* the internal representation *)
open Names
open Location
open Signature
type iterator_type =
| Imap
| Ifold
| Imapfold
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; }
and op =
| Epre of const option
| Efby | Earrow | Eifthenelse
| Earray_op of array_op
| Efield_update of longname
| Ecall of op_desc
and array_op =
| Erepeat | Eselect of exp list | Eselect_dyn
| Eupdate of exp list
| Eselect_slice
| Econcat
| Eiterator of iterator_type * op_desc
and op_desc = { op_name : longname; op_params: exp list; op_kind: op_kind }
and op_kind = | Efun | Enode
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_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 arg = { a_type : ty; a_name : name option }
type signature =
{ sig_name : name;
sig_inputs : arg list;
sig_statefull : bool;
sig_outputs : arg list;
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 mk_exp desc =
{ e_desc = desc; e_loc = Location.current_loc () }
let mk_app op =
{ a_op = op; }
let mk_op_desc ln params kind =
{ op_name = ln; op_params = params; op_kind = kind }
let mk_call desc exps =
Eapp (mk_app (Ecall desc), exps)
let mk_op_call s params exps =
mk_call (mk_op_desc (Name s) params Efun) exps
let mk_array_op_call op exps =
Eapp (mk_app (Earray_op op), exps)
let mk_iterator_call it ln params exps =
mk_array_op_call (Eiterator (it, mk_op_desc ln params Enode)) exps
let mk_type_dec name desc =
{ t_name = name; t_desc = desc; t_loc = Location.current_loc () }
let mk_equation desc =
{ eq_desc = desc; eq_loc = Location.current_loc () }
let mk_interface_decl desc =
{ interf_desc = desc; interf_loc = Location.current_loc () }
let mk_var_dec name ty last =
{ v_name = name; v_type = ty;
v_last = last; v_loc = Location.current_loc () }
let mk_block locals eqs =
{ b_local = locals; b_equs = eqs;
b_loc = Location.current_loc () }
let mk_const_dec id ty e =
{ c_name = id; c_type = ty; c_value = e;
c_loc = Location.current_loc (); }
let mk_arg name ty =
{ a_type = ty; a_name = name }

348
compiler/heptagon/parsing/scoping.ml
View file

@ -1,348 +0,0 @@
(** 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_name 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_name 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_iterator_type = function
| Imap -> Heptagon.Imap
| Ifold -> Heptagon.Ifold
| Imapfold -> Heptagon.Imapfold
let translate_op_kind = function
| Efun -> Heptagon.Efun
| Enode -> Heptagon.Enode
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
| Ecall { op_name = op; op_kind = Efun } -> 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 -> Types.Tprod(List.map (translate_type const_env) ty_list)
| Tid ln -> Types.Tid ln
| Tarray (ty, e) ->
let ty = translate_type const_env ty in
Types.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 = Types.invalid_type;
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
| Ecall desc -> Heptagon.Ecall (translate_op_desc const_env desc, None)
| Efield_update f -> Heptagon.Efield_update f
| Earray_op op -> Heptagon.Earray_op (translate_array_op const_env env op)
in
{ Heptagon.a_op = op; }
and translate_op_desc const_env desc =
{ Heptagon.op_name = desc.op_name;
Heptagon.op_params =
List.map (translate_size_exp const_env) desc.op_params;
Heptagon.op_kind = translate_op_kind desc.op_kind }
and translate_array_op const_env env = function
| 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)
| Erepeat -> Heptagon.Erepeat
| Eselect_slice -> Heptagon.Eselect_slice
| Econcat -> Heptagon.Econcat
| Eselect_dyn -> Heptagon.Eselect_dyn
| Eiterator (it, desc) ->
Heptagon.Eiterator (translate_iterator_type it,
translate_op_desc const_env desc, None)
and translate_desc loc const_env env = function
| Econst c -> Heptagon.Econst (translate_const c)
| Evar x ->
if Rename.mem x env then (* defined var *)
Heptagon.Evar (Rename.name loc env x)
else if NamesEnv.mem x const_env then (* defined as const var *)
Heptagon.Econstvar x
else (* undefined var *)
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 = (Earray_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.Carray (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) ->
let sh = List.map
(translate_switch_handler loc const_env env)
switch_handlers in
Heptagon.Eswitch (translate_exp const_env env e, sh)
| 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
, fst (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 }, env
and translate_state_handler const_env env sh =
let b, env = translate_block const_env env sh.s_block in
{ Heptagon.s_state = sh.s_state;
Heptagon.s_block = b;
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 = fst (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 = fst (translate_block const_env env sh.w_block) }
and translate_var_dec const_env env vd =
{ Heptagon.v_ident = Rename.name vd.v_loc env vd.v_name;
Heptagon.v_type = translate_type const_env vd.v_type;
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_params = List.map Signature.mk_param 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) =
Signature.mk_field f (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 = 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_arg const_env a =
{ Signature.a_name = a.a_name;
Signature.a_type = translate_type const_env a.a_type }
let translate_signature s =
let const_env = build_id_list no_location NamesEnv.empty s.sig_params in
{ Heptagon.sig_name = s.sig_name;
Heptagon.sig_inputs = List.map (translate_arg const_env) s.sig_inputs;
Heptagon.sig_outputs = List.map (translate_arg const_env) s.sig_outputs;
Heptagon.sig_statefull = s.sig_statefull;
Heptagon.sig_params = List.map Signature.mk_param 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 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)

241
compiler/heptagon/transformations/automata.ml
View file

@ -8,106 +8,87 @@
(**************************************************************************)
(* removing automata statements *)
(* $Id$ *)
open Misc
open Names
open Ident
open Heptagon
open Types
open Names
open Idents
open Heptagon
open Hept_mapfold
open Initial
open Modules
let mk_var_exp n ty =
mk_exp (Evar n) ty
let mk_pair e1 e2 =
mk_exp (Etuple [e1;e2]) (Tprod [e1.e_ty; e2.e_ty])
mk_exp (mk_op_app Etuple [e1;e2]) (Tprod [e1.e_ty; e2.e_ty])
let mk_reset_equation eq_list e =
mk_equation (Ereset (eq_list, e))
mk_equation (Ereset (mk_block eq_list, e))
let mk_switch_equation e l =
mk_equation (Eswitch (e, l))
let mk_exp_fby_false e =
mk_exp (Eapp(mk_op (Epre (Some (Cconstr Initial.pfalse))), [e]))
mk_exp (Epre (Some (mk_static_bool false), e))
(Tid Initial.pbool)
let mk_constructor constr ty =
mk_static_exp ~ty:ty (Sconstructor constr)
(* Be sure that [initial] is of the right type [e.e_ty] before using this *)
let mk_exp_fby_state initial e =
{ e with e_desc = Eapp(mk_op (Epre (Some (Cconstr initial))), [e]) }
{ e with e_desc = Epre (Some (mk_constructor initial e.e_ty), e) }
(* 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
(* create and add to the env the constructors corresponding to a name state *)
let intro_state_constr type_name state state_env =
let c = Modules.fresh_constr state in
Modules.add_constrs c type_name; NamesEnv.add state c state_env
(* create and add the the global env and to state_type_dec_list
a type corresponding to the state env*)
let intro_type type_name state_env =
let state_constrs = NamesEnv.fold (fun _ c c_l -> c::c_l) state_env [] in
(* Add the new type to the env *)
Modules.add_type type_name (Signature.Tenum state_constrs);
(* Add the new type to the types to add to the Ast *)
state_type_dec_list :=
(mk_type_dec state_type (Type_enum (list states))) :: !state_type_dec_list;
Name(state_type)
(mk_type_dec type_name (Type_enum state_constrs)) :: !state_type_dec_list
(* 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
(** Allows to classify an automaton :
Moore automatons doesn't have strong transitions,
Mealy automatons may have some. *)
let no_strong_transition state_handlers =
let handler no_strong { s_unless = l } = no_strong & (l = []) in
List.fold_left handler true state_handlers
let rec translate_eq (v, eq_list) eq =
match eq.eq_desc with
Eautomaton(state_handlers) ->
translate_automaton v eq_list state_handlers
| Eswitch(e, switch_handlers) ->
let eq = { eq with eq_desc =
Eswitch(e, translate_switch_handlers switch_handlers) } in
v, eq::eq_list
| Epresent(present_handlers, block) ->
let eq = { eq with eq_desc =
Epresent(translate_present_handlers present_handlers,
translate_block block) } in
v, eq::eq_list
| Ereset(r_eq_list, e) ->
let v, r_eq_list = translate_eqs v r_eq_list in
let eq = { eq with eq_desc = Ereset(r_eq_list, e) } in
v, eq::eq_list
| Eeq _ -> v, eq :: eq_list
and translate_eqs v eq_list = List.fold_left translate_eq (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 =
let translate_present_handler { p_cond = e; p_block = b } =
{ p_cond = e; p_block = translate_block b } in
List.map translate_present_handler handlers
and translate_automaton v eq_list handlers =
let has_until, has_unless = moore_mealy handlers in
let states =
let suffix = gen_symbol () in
let translate_automaton v eq_list handlers =
let type_name = Modules.fresh_type ("states") in
(* the state env associate a name to a qualified constructor *)
let state_env =
List.fold_left
(fun env { s_state = n } -> NamesEnv.add n (n ^ suffix) env)
(fun env { s_state = n } -> intro_state_constr type_name n env)
NamesEnv.empty handlers in
intro_type type_name state_env;
let tstatetype = Tid type_name in
let statetype = intro_type states in
let tstatetype = Tid statetype in
let initial = Name(NamesEnv.find (List.hd handlers).s_state states) in
(* The initial state constructor *)
let initial = (NamesEnv.find (List.hd handlers).s_state state_env) 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
let statename = Idents.fresh "s" in
let next_statename = Idents.fresh "ns" in
let resetname = Idents.fresh "r" in
let next_resetname = Idents.fresh "nr" in
let pre_next_resetname = Idents.fresh "pnr" in
let name n = Name(NamesEnv.find n states) in
let state n = mk_exp (Econst (Cconstr (name n))) tstatetype in
let name n = NamesEnv.find n state_env in
let state n =
mk_exp (Econst (mk_constructor (name n) tstatetype)) tstatetype in
let statevar n = mk_var_exp n tstatetype in
let boolvar n = mk_var_exp n (Tid Initial.pbool) in
@ -124,12 +105,11 @@ and translate_automaton v eq_list handlers =
let st_eq = mk_simple_equation
(Etuplepat[Evarpat(statename); Evarpat(resetname)])
(escapes n su (boolvar pre_next_resetname)) in
mk_block defnames [mk_reset_equation [st_eq]
(boolvar pre_next_resetname)]
mk_block ~defnames:defnames [mk_reset_equation [st_eq]
(boolvar pre_next_resetname)]
in
let weak { s_state = n; s_block = b; s_until = su } =
let b = translate_block b in
let defnames = Env.add next_resetname (Tid Initial.pbool) b.b_defnames in
let defnames = Env.add next_statename tstatetype defnames in
let ns_eq = mk_simple_equation
@ -143,76 +123,57 @@ and translate_automaton v eq_list handlers =
in
let v =
(mk_var_dec next_statename (Tid(statetype))) ::
(mk_var_dec next_statename tstatetype) ::
(mk_var_dec resetname (Tid Initial.pbool)) ::
(mk_var_dec next_resetname (Tid Initial.pbool)) ::
(mk_var_dec pre_next_resetname (Tid Initial.pbool)) :: v in
(* we optimise the case of an only strong automaton *)
(* or only weak automaton *)
match has_until, has_unless with
| true, false ->
let switch_e = mk_exp_fby_state initial (statevar next_statename) in
let switch_handlers = (List.map
(fun ({ s_state = n } as case) ->
{ w_name = name n; w_block = weak case })
handlers) in
let switch_eq = mk_switch_equation switch_e switch_handlers in
let nr_eq = mk_simple_equation (Evarpat pre_next_resetname)
(mk_exp_fby_false (boolvar (next_resetname))) in
let pnr_eq = mk_simple_equation (Evarpat resetname)
(boolvar pre_next_resetname) in
(* a Moore automaton with only weak transitions *)
v, switch_eq :: nr_eq :: pnr_eq :: eq_list
| _ ->
(* the general case; two switch to generate,
statename variable used and defined *)
let v = (mk_var_dec statename (Tid statetype)) :: v in
if no_strong_transition handlers
then (* Only weak transitions : a Moore automaton. *)
let switch_e = mk_exp_fby_state initial (statevar next_statename) in
let switch_handlers =
List.map (fun ({ s_state = n } as case) ->
{ w_name = name n; w_block = weak case })
handlers in
let switch_eq = mk_switch_equation switch_e switch_handlers in
let nr_eq =
mk_simple_equation (Evarpat pre_next_resetname)
(mk_exp_fby_false (boolvar (next_resetname))) in
let pnr_eq =
mk_simple_equation (Evarpat resetname) (boolvar pre_next_resetname) in
v, switch_eq :: nr_eq :: pnr_eq :: eq_list
else (* General case,
two switch to generate statename variable used and defined *)
let v = (mk_var_dec statename tstatetype) :: v in
let ns_switch_e = mk_exp_fby_state initial (statevar next_statename) in
let ns_switch_handlers =
List.map (fun ({ s_state = n } as case) ->
{ w_name = name n; w_block = strong case })
handlers in
let ns_switch_eq = mk_switch_equation ns_switch_e ns_switch_handlers in
let switch_e = statevar statename in
let switch_handlers =
List.map (fun ({ s_state = n } as case) ->
{ w_name = name n; w_block = weak case })
handlers in
let switch_eq = mk_switch_equation switch_e switch_handlers in
let pnr_eq =
mk_simple_equation (Evarpat pre_next_resetname)
(mk_exp_fby_false (boolvar (next_resetname))) in
v, ns_switch_eq :: switch_eq :: pnr_eq :: eq_list
let ns_switch_e = mk_exp_fby_state initial (statevar next_statename) in
let ns_switch_handlers = List.map
(fun ({ s_state = n } as case) ->
{ w_name = name n; w_block = strong case })
handlers in
let ns_switch_eq = mk_switch_equation ns_switch_e ns_switch_handlers in
let rec eq funs (v, eq_list) eq =
let eq, (v, eq_list) = Hept_mapfold.eq funs (v, eq_list) eq in
match eq.eq_desc with
| Eautomaton state_handlers ->
eq, translate_automaton v eq_list state_handlers
| _ -> eq, (v, eq::eq_list)
let switch_e = statevar statename in
let switch_handlers = List.map
(fun ({ s_state = n } as case) ->
{ w_name = name n; w_block = weak case })
handlers in
let switch_eq = mk_switch_equation switch_e switch_handlers in
let block funs acc b =
let b, (v, acc_eq_list) = Hept_mapfold.block funs ([], []) b in
{ b with b_local = v @ b.b_local; b_equs = acc_eq_list }, acc
let pnr_eq = mk_simple_equation (Evarpat pre_next_resetname)
(mk_exp_fby_false (boolvar (next_resetname))) in
v, ns_switch_eq :: switch_eq :: pnr_eq :: eq_list
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) =
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)
*)
let program p =
let funs = { Hept_mapfold.defaults
with eq = eq; block = block } in
let p, _ = Hept_mapfold.program_it funs ([],[]) p in
{ p with p_types = !state_type_dec_list @ p.p_types }

104
compiler/heptagon/transformations/completion.ml
View file

@ -10,71 +10,65 @@
open Misc
open Heptagon
open Ident
open Global_mapfold
open Hept_mapfold
open Idents
(* We first define a shallow pass,
meant to be called at an automaton/present/switch level
It'll collect the set of defined names among the handlers of the automaton/...
*)
(* We stop at the first level, it'll correspond to an handler *)
let block_collect funs env b =
b, b.b_defnames
let gather f funs env x =
let x, new_env = f funs Env.empty x in
x, Env.union new_env env
(* We need to return the union of the defined names which is done with [gather],
without traversing anything else.
This funs_collect will stop directly if called on something else than
blocks or handlers. *)
let funs_collect =
{ Hept_mapfold.defaults_stop with
block = block_collect;
switch_handler = gather Hept_mapfold.switch_handler;
present_handler = gather Hept_mapfold.present_handler;
state_handler = gather Hept_mapfold.state_handler; }
(* The real pass adding the needed equations *)
(* 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 = mk_exp (Elast n) ty in
let equation n ty eq_list =
(mk_equation (Eeq(Evarpat n, last n ty)))::eq_list
in
(mk_equation (Eeq(Evarpat n, last n ty)))::eq_list in
let d = Env.diff defined_names local_defined_names in
Env.fold equation d eq_list
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
let block funs defnames b =
let b, _ = Hept_mapfold.block funs Env.empty b in (*recursive call*)
let added_eq = complete_with_last defnames b.b_defnames [] in
{ b with b_equs = b.b_equs @ added_eq; b_defnames = defnames }
, defnames
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 eqdesc funs _ ed = match ed with
| Epresent _ | Eautomaton _ | Eswitch _ ->
(* collect defined names with the special pass *)
let ed, defnames =
Hept_mapfold.eqdesc funs_collect Env.empty ed in
(* add missing defnames *)
Hept_mapfold.eqdesc funs defnames ed
| _ -> raise Misc.Fallback
let translate_contract ({ c_eq = eqs } as c) =
{ c with c_eq = translate_eqs eqs }
let funs = { Hept_mapfold.defaults with eqdesc = eqdesc; block = block; }
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 = let p, _ = program_it funs Env.empty p in p
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 }

150
compiler/heptagon/transformations/every.ml
View file

@ -1,146 +1,34 @@
(**************************************************************************)
(* *)
(* 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'
*)
open Misc
open Ident
open Heptagon
open Hept_mapfold
open Reset
(*
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
let block funs acc b =
let b, (v, acc_eq_list) = Hept_mapfold.block funs ([], []) b in
{ b with b_local = v @ b.b_local; b_equs = acc_eq_list@b.b_equs }, acc
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 = Ecall(op_desc, 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 edesc funs (v,acc_eq_list) ed =
let ed, (v, acc_eq_list) = Hept_mapfold.edesc funs (v,acc_eq_list) ed in
match ed with
| Eapp (op, e_list, Some re) when not (is_var re) ->
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 = Ecall(op_desc,
Some { re with e_desc = Evar(n) }) },
e_list) }
| Eapp ({ a_op = Earray_op(Eiterator(it, op_desc, 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 =
Earray_op(Eiterator(it, op_desc, 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) }
Eapp(op, e_list, Some re), (v, acc_eq_list)
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
| Eiterator(it, op, n, e_list, Some re) when not (is_var re) ->
let x, v, acc_eq_list = equation v acc_eq_list re in
let re = { re with e_desc = Evar x } in
Eiterator(it, op, n, e_list, Some re), (v, acc_eq_list)
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 }
| _ -> ed, (v, acc_eq_list)
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 }
let program p =
let funs = { Hept_mapfold.defaults
with edesc = edesc; block = block } in
let p, _ = program_it funs ([],[]) p in
p

124
compiler/heptagon/transformations/inline.ml Normal file
View file

@ -0,0 +1,124 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
open Misc
open Idents
open Signature
open Types
open Names
open Heptagon
open Hept_mapfold
let to_be_inlined s = !Misc.flatten || (List.mem s !Misc.inline)
let mk_unique_node nd =
let mk_bind vd =
let id = Idents.fresh (Idents.sourcename vd.v_ident) in
(vd.v_ident, { vd with v_ident = id; }) in
let subst = List.map mk_bind (nd.n_block.b_local
@ nd.n_input @ nd.n_output) in
let subst_var_dec funs () vd =
({ vd with v_ident = (List.assoc vd.v_ident subst).v_ident; }, ()) in
let subst_edesc funs () ed = match ed with
| Evar vn -> (Evar (List.assoc vn subst).v_ident, ())
| _ -> raise Fallback in
let subst_eqdesc funs () eqd =
let (eqd, ()) = Hept_mapfold.eqdesc funs () eqd in
match eqd with
| Eeq (pat, e) ->
let rec subst_pat pat = match pat with
| Evarpat vn -> Evarpat (try (List.assoc vn subst).v_ident
with Not_found -> vn)
| Etuplepat patl -> Etuplepat (List.map subst_pat patl) in
(Eeq (subst_pat pat, e), ())
| _ -> raise Fallback in
let funs = { defaults with
var_dec = subst_var_dec;
eqdesc = subst_eqdesc;
edesc = subst_edesc; } in
fst (Hept_mapfold.node_dec funs () nd)
let exp funs (env, newvars, newequs) exp = match exp.e_desc with
| Eiterator (it, { a_op = Enode nn; }, _, _, _) when to_be_inlined nn ->
Format.eprintf
"WARN: inlining iterators (\"%s %s\" here) is unsupported.@."
(Hept_printer.iterator_to_string it) (fullname nn);
(exp, (env, newvars, newequs))
| Eapp ({ a_op = Enode nn; } as op, argl, rso) when to_be_inlined nn ->
let add_reset eq = match rso with
| None -> eq
| Some x -> mk_equation ~statefull:false
(Ereset (mk_block [eq], x)) in
let ni = mk_unique_node (env nn) in
let static_subst =
List.combine (List.map (fun p -> Name p.p_name) ni.n_params)
op.a_params in
(* Perform [static_exp] substitution. *)
let ni =
let apply_sexp_subst_sexp funs () sexp = match sexp.se_desc with
| Svar s -> ((try List.assoc s static_subst
with Not_found -> sexp), ())
| _ -> Global_mapfold.static_exp funs () sexp in
let funs =
{ defaults with global_funs =
{ Global_mapfold.defaults with Global_mapfold.static_exp =
apply_sexp_subst_sexp; }; } in
fst (Hept_mapfold.node_dec funs () ni) in
let mk_input_equ vd e =
mk_equation ~statefull:false (Eeq (Evarpat vd.v_ident, e)) in
let mk_output_exp vd = mk_exp (Evar vd.v_ident) vd.v_type in
let newvars = ni.n_input @ ni.n_block.b_local @ ni.n_output @ newvars
and newequs =
List.map2 mk_input_equ ni.n_input argl
@ List.map add_reset ni.n_block.b_equs
@ newequs in
(* For clocking reason we cannot create 1-tuples. *)
let res_e = match ni.n_output with
| [o] -> mk_output_exp o
| _ ->
mk_exp (Eapp ({ op with a_op = Etuple; },
List.map mk_output_exp ni.n_output, None)) exp.e_ty in
(res_e, (env, newvars, newequs))
| _ -> Hept_mapfold.exp funs (env, newvars, newequs) exp
let block funs (env, newvars, newequs) blk =
let (block, (env, newvars, newequs)) =
Hept_mapfold.block funs (env, newvars, newequs) blk in
({ blk with b_local = newvars @ blk.b_local; b_equs = newequs @ blk.b_equs; },
(env, [], []))
let node_dec funs (env, newvars, newequs) nd =
let nd, (env, newvars, newequs) =
Hept_mapfold.node_dec funs (env, newvars, newequs) nd in
({ nd with n_block =
{ nd.n_block with b_local = newvars @ nd.n_block.b_local;
b_equs = newequs @ nd.n_block.b_equs } },
(env, [], []))
let program p =
let env n =
let mk_ln s = Modname { qual = p.p_modname; id = s; } in
List.find (fun nd -> mk_ln nd.n_name = n) p.p_nodes in
let funs =
{ defaults with exp = exp; block = block; node_dec = node_dec; eq = eq; } in
let (p, (_, newvars, newequs)) = Hept_mapfold.program funs (env, [], []) p in
assert (newvars = []);
assert (newequs = []);
p

103
compiler/heptagon/transformations/last.ml
View file

@ -7,10 +7,9 @@
(* *)
(**************************************************************************)
(* removing accessed to shared variables (last x) *)
open Misc
open Heptagon
open Ident
open Hept_mapfold
open Idents
(* introduce a fresh equation [last_x = pre(x)] for every *)
(* variable declared with a last *)
@ -18,87 +17,37 @@ let last (eq_list, env, v) { v_ident = 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
let lastn = Idents.fresh ("last" ^ (sourcename n)) in
let eq = mk_equation (Eeq (Evarpat lastn,
mk_exp (Eapp (mk_op (Epre default),
[mk_exp (Evar n) t])) t)) in
mk_exp (Epre (default,
mk_exp (Evar n) t)) t)) in
eq:: eq_list,
Env.add n lastn env,
(mk_var_dec 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
let edesc funs env ed = match ed with
| Elast x ->
let lx = Env.find x env in Evar lx, env
| _ -> raise Misc.Fallback
and translate_eqs env eq_list = List.map (translate_eq env) eq_list
let block funs env b =
let eq_lastn_n_list, env, last_v = extend_env env b.b_local in
let b, _ = Hept_mapfold.block funs env b in
{ b with b_local = b.b_local @ last_v;
b_equs = eq_lastn_n_list @ b.b_equs }, env
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 }
let node_dec funs env n =
let _, env, _ = extend_env Env.empty n.n_input in
let eq_lasto_list, env, last_o = extend_env env n.n_output in
let n, _ = Hept_mapfold.node_dec funs env n in
{ n with n_block =
{ n.n_block with b_local = n.n_block.b_local @ last_o;
b_equs = eq_lasto_list @ n.n_block.b_equs } }, env
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) }
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 }
let program p =
let funs = { Hept_mapfold.defaults with
node_dec = node_dec; block = block; edesc = edesc } in
let p, _ = Hept_mapfold.program_it funs Env.empty p in
p

68
compiler/heptagon/transformations/present.ml
View file

@ -7,62 +7,28 @@
(* *)
(**************************************************************************)
(* removing present statements *)
(* $Id$ *)
open Misc
open Location
open Heptagon
open Initial
open Hept_mapfold
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_handlers handlers cont =
let translate_present_handler { p_cond = e; p_block = b } cont =
let statefull = b.b_statefull or cont.b_statefull in
mk_block ~statefull:statefull b.b_defnames
[mk_switch_equation
~statefull:statefull e
[{ w_name = ptrue; w_block = b };
{ w_name = pfalse; w_block = cont }]] in
mk_block ~statefull:statefull ~defnames:b.b_defnames
[mk_switch_equation
~statefull:statefull e
[{ w_name = Initial.ptrue; w_block = b };
{ w_name = Initial.pfalse; w_block = cont }]] in
let b = List.fold_right translate_present_handler handlers cont in
List.hd (b.b_equs)
(List.hd (b.b_equs)).eq_desc
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 eqdesc funs acc eqd =
let eqd, _ = Hept_mapfold.eqdesc funs acc eqd in
match eqd with
| Epresent(ph, b) -> translate_present_handlers ph b, acc
| _ -> eqd, acc
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 =
let funs = { Hept_mapfold.defaults with eqdesc = eqdesc } in
let p, _ = Hept_mapfold.program_it funs false p in
p
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 }

311
compiler/heptagon/transformations/reset.ml
View file

@ -8,12 +8,13 @@
(**************************************************************************)
(* removing reset statements *)
(* $Id$ *)
open Misc
open Ident
open Idents
open Heptagon
open Hept_mapfold
open Types
open Initial
(* We introduce an initialization variable for each block *)
(* Using an asynchronous reset would allow to produce *)
@ -25,7 +26,9 @@ open Types
| case C2 do ...
| case C3 do ...
end
every r
every res
---->
switch e with
case C1 do ... (* l_m1 *)
@ -35,8 +38,9 @@ open Types
| 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
l_m1 = if res then true else (true fby m1);
l_m2 = if res then true else (true fby m2);
l_m3 = if res then true else (true fby m3);
e1 -> e2 is translated into if (true fby false) then e1 else e2
*)
@ -46,236 +50,141 @@ let mk_bool_var n =
let mk_bool_param n =
mk_var_dec n (Tid Initial.pbool)
let or_op_call = mk_op ( Ecall(mk_op_desc Initial.por [] Efun, None) )
let or_op_call e_list = mk_op_app (Efun Initial.por) e_list
let pre_true e = {
e with e_desc = Eapp(mk_op (Epre (Some (Cconstr Initial.ptrue))), [e])
}
let pre_true e =
{ e with e_desc = Epre (Some (mk_static_bool true), e) }
let init e = pre_true { dfalse with e_loc = e.e_loc }
(* 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(or_op_call, [mk_bool_var n; e]) }
let add_resets res e =
match res, e with
| None, _ -> e
| _, None -> res
| Some re, Some e -> Some { e with e_desc = or_op_call [re; 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 (mk_bool_var n)
let ifres res e2 e3 =
match res with
| Rfalse -> mk_ifthenelse (init e3) e2 e3
| _ -> (* a reset occurs *)
mk_ifthenelse (exp_of_res res) e2 e3
| None -> mk_op_app Eifthenelse [init e3; e2; e3]
| Some re -> (* a reset occurs *)
mk_op_app Eifthenelse [re; e2; e3]
(* add an equation *)
let equation v acc_eq_list e =
let n = Ident.fresh "r" in
let n = Idents.fresh "r" in
n,
(mk_bool_param n) :: v,
(mk_equation (Eeq(Evarpat n, e))) ::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)
| Evar n -> add_resets res (Some e), v, acc_eq_list
| _ ->
let n, v, acc_eq_list = equation v acc_eq_list e in
v, acc_eq_list, Rorthen(res, n)
add_resets res (Some { e with e_desc = Evar n }), v, acc_eq_list
let add_locals m n locals =
let rec loop locals i n =
if i < n then
loop ((mk_bool_param m.(i)) :: locals) (i+1) n
else locals in
loop locals 0 n
let mk_local_equation i k m lm =
(* m_i = false; m_j = l_mj *)
if i = k then
mk_simple_equation (Evarpat m) dfalse
else
mk_simple_equation (Evarpat m) (mk_bool_var lm)
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 ((mk_simple_equation (Evarpat (m.(k))) dfalse) :: acc) (k+1)
else
loop
((mk_simple_equation (Evarpat (m.(k))) (mk_bool_var lm.(k))) :: acc)
(k+1)
else acc
in loop acc 0
let add_global_equations n m lm res acc =
let mk_global_equation res m lm =
(* [ 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
let exp =
(match res with
| Rfalse -> pre_true (mk_bool_var m.(k))
| _ -> ifres res dtrue (pre_true (mk_bool_var m.(k)))
) in
loop
((mk_equation (Eeq (Evarpat (lm.(k)), exp))) :: 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) (Tid Initial.pbool) acc) (k+1)
else acc in
loop d 0
let e =
(match res with
| None -> pre_true (mk_bool_var m)
| _ -> mk_exp (ifres res dtrue (pre_true (mk_bool_var m)))
(Tid Initial.pbool)
) in
mk_simple_equation (Evarpat lm) e
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
let edesc funs (res, v, acc_eq_list) ed =
let ed, _ = Hept_mapfold.edesc funs (res, v, acc_eq_list) ed in
let ed = match ed with
| Efby (e1, e2) ->
(match res, e1 with
| None, { e_desc = Econst c } ->
(* no reset *)
Epre(Some c, e2)
| _ ->
ifres res e1
{ e2 with e_desc = Epre(default e1, e2) }
)
| Eapp({ a_op = Earrow }, [e1;e2], _) ->
ifres res e1 e2
(* add reset to the current reset exp. *)
| Eapp({ a_op = Ecall(op_desc, Some re) } as op, e_list) ->
let re = translate res re in
let e_list = List.map (translate res) e_list in
let op = { op with a_op = Ecall(op_desc, Some (or_op res re))} in
{ e with e_desc = Eapp(op, e_list) }
(* create a new reset exp if necessary *)
| Eapp({ a_op = Ecall(op_desc, None) } as op, e_list) ->
let e_list = List.map (translate res) e_list in
if true_reset res & op_desc.op_kind = Enode then
let op = { op with a_op = Ecall(op_desc, Some (exp_of_res res)) } in
{ e with e_desc = Eapp(op, e_list) }
else
{ e with e_desc = Eapp(op, e_list ) }
(* add reset to the current reset exp. *)
| Eapp( { a_op = Earray_op (Eiterator(it, op_desc, Some re)) } as op,
e_list) ->
let re = translate res re in
let e_list = List.map (translate res) e_list in
let r = Some (or_op res re) in
let op = { op with a_op = Earray_op (Eiterator(it, op_desc, r)) } in
{ e with e_desc = Eapp(op, e_list) }
(* create a new reset exp if necessary *)
| Eapp({ a_op = Earray_op (Eiterator(it, op_desc, None)) } 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
let op = { op with a_op = Earray_op (Eiterator(it, op_desc, r)) } in
{ e with e_desc = Eapp(op, e_list) }
else
{ e with e_desc = Eapp(op, e_list) }
| Eapp({ a_op = Enode _ } as op, e_list, re) ->
Eapp(op, e_list, add_resets res re)
(* add reset to the current reset exp. *)
| Eiterator(it, ({ a_op = Enode _ } as op), n, e_list, re) ->
Eiterator(it, op, n, e_list, add_resets res re)
| _ -> ed
in
ed, (res, v, acc_eq_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 switch_handlers funs (res, v, acc_eq_list) switch_handlers =
(* introduce a reset bit for each branch *)
let m_list = List.map (fun _ -> Idents.fresh "r") switch_handlers in
let lm_list = List.map (fun _ -> Idents.fresh "r") switch_handlers in
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 body i ({ w_block = b } as sh) m lm =
let defnames = List.fold_left (fun acc m ->
Env.add m (Tid Initial.pbool) acc) b.b_defnames m_list in
let _, (_, v, acc_eq_list) =
mapfold (eq_it funs) (Some (mk_bool_var lm), b.b_local, []) b.b_equs in
let added_eqs = mapi2 (mk_local_equation i) m_list lm_list in
{ sh with w_block = { b with b_local = v; b_defnames = defnames;
b_equs = added_eqs @ acc_eq_list } } in
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 v = (List.map mk_bool_param m_list)@
(List.map mk_bool_param lm_list)@v in
let switch_handlers = mapi3 body switch_handlers m_list lm_list in
let added_eqs = List.map2 (mk_global_equation res) m_list lm_list in
let program (p) =
{ p with p_nodes = List.map node p.p_nodes }
v, switch_handlers, acc_eq_list @ added_eqs
let eq funs (res, v, acc_eq_list) equ =
match equ.eq_desc with
| Eswitch(e, sh) ->
let e, _ = exp_it funs (res, v, acc_eq_list) e in
let v, sh, acc_eq_list =
switch_handlers funs (res, v, acc_eq_list) sh in
equ, (res, v, { equ with eq_desc = Eswitch(e, sh) } :: acc_eq_list)
| Ereset(b, e) ->
let e, _ = exp_it funs (res, v, acc_eq_list) e in
let res, v, acc_eq_list =
(* if statefull eq_list then*)
orthen v acc_eq_list res e
(* else
let _, v, acc_eq_list = equation v acc_eq_list e in
res, v, acc_eq_list*)
in
let _, (res, v, acc_eq_list) =
mapfold (eq_it funs) (res, v, acc_eq_list) b.b_equs in
equ, (res, v, acc_eq_list)
| _ ->
let equ, (res, v, acc_eq_list) = eq funs (res, v, acc_eq_list) equ in
equ, (res, v, equ::acc_eq_list)
let block funs _ b =
let n, (_, v, eq_list) = Hept_mapfold.block funs (None, [], []) b in
{ b with b_local = v @ b.b_local; b_equs = eq_list; }, (None, [], [])
let program p =
let funs = { Hept_mapfold.defaults with
eq = eq; block = block; edesc = edesc } in
let p, _ = program_it funs (None, [], []) p in
p

164
compiler/main/hept2mls.ml
View file

@ -12,11 +12,11 @@
open Location
open Misc
open Names
open Ident
open Idents
open Static
open Types
open Clocks
open Format
open Printf
open Minils
open Mls_utils
@ -31,11 +31,11 @@ struct
let message loc kind =
begin match kind with
| Ereset_not_var ->
eprintf "%aOnly variables can be used for resets.\n"
output_location loc
eprintf "%aOnly variables can be used for resets.@."
print_location loc
| Eunsupported_language_construct ->
eprintf "%aThis construct is not supported by MiniLS.\n"
output_location loc
eprintf "%aThis construct is not supported by MiniLS.@."
print_location loc
end;
raise Misc.Error
end
@ -48,7 +48,7 @@ struct
type env =
| Eempty
| Ecomp of env * IdentSet.t
| Eon of env * longname * ident
| Eon of env * constructor_name * ident
let empty = Eempty
@ -64,7 +64,7 @@ struct
let con env x e =
let rec conrec env =
match env with
| Eempty -> Format.printf "%s\n" (name x); assert false
| Eempty -> Format.eprintf "%s@." (name x); assert false
| Eon(env, tag, name) ->
let e, ck = conrec env in
let ck_tag_name = Con(ck, tag, name) in
@ -90,7 +90,7 @@ end
(* add an equation *)
let equation locals l_eqs e =
let n = Ident.fresh "ck" in
let n = Idents.fresh "ck" in
n,
(mk_var_dec n e.e_ty) :: locals,
(mk_equation (Evarpat n) e):: l_eqs
@ -113,8 +113,9 @@ let add_locals ni l_eqs s_eqs s_handlers =
s_eqs s_handlers in
addrec l_eqs s_eqs s_handlers
let translate_var { Heptagon.v_ident = n; Heptagon.v_type = ty; } =
mk_var_dec n ty
let translate_var { Heptagon.v_ident = n; Heptagon.v_type = ty;
Heptagon.v_loc = loc } =
mk_var_dec ~loc:loc n ty
let translate_locals locals l =
List.fold_left (fun locals v -> translate_var v :: locals) locals l
@ -153,7 +154,7 @@ let switch x ci_eqs_list =
else
begin
List.iter
(fun (x,e) -> Printf.eprintf "|%s|, " (name x))
(fun (x,e) -> Format.eprintf "|%s|, " (name x))
firsts;
assert false
end;
@ -176,27 +177,12 @@ let switch x ci_eqs_list =
| [] | (_, []) :: _ -> []
| (ci, (y, { e_ty = ty; e_loc = loc }) :: _) :: _ ->
let ci_e_list, ci_eqs_list = split ci_eqs_list in
(y, mk_exp ~exp_ty:ty (Emerge(x, ci_e_list))) ::
(y, mk_exp ~exp_ty:ty ~loc:loc (Emerge(x, ci_e_list))) ::
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.Carray(n, c) -> Carray(n, const c)
let translate_op_kind = function
| Heptagon.Efun -> Efun
| Heptagon.Enode -> Enode
let translate_op_desc { Heptagon.op_name = n; Heptagon.op_params = p;
Heptagon.op_kind = k } =
{ op_name = n; op_params = p;
op_kind = translate_op_kind k }
let translate_reset = function
| Some { Heptagon.e_desc = Heptagon.Evar n } -> Some n
| Some re -> Error.message re.Heptagon.e_loc Error.Ereset_not_var
@ -205,63 +191,59 @@ let translate_reset = function
let translate_iterator_type = function
| Heptagon.Imap -> Imap
| Heptagon.Ifold -> Ifold
| Heptagon.Ifoldi -> Ifoldi
| Heptagon.Imapfold -> Imapfold
let rec application env { Heptagon.a_op = op; } 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.Ecall(op_desc, r), e_list ->
Ecall(translate_op_desc op_desc, e_list, translate_reset r)
| Heptagon.Efield_update f, [e1;e2] -> Efield_update(f, e1, e2)
| Heptagon.Earray_op op, e_list ->
Earray_op (translate_array_op env op e_list)
let rec translate_op env = function
| Heptagon.Eequal -> Eequal
| Heptagon.Eifthenelse -> Eifthenelse
| Heptagon.Efun f -> Efun f
| Heptagon.Enode f -> Enode f
| Heptagon.Efield -> Efield
| Heptagon.Efield_update -> Efield_update
| Heptagon.Earray_fill -> Earray_fill
| Heptagon.Eselect -> Eselect
| Heptagon.Eselect_dyn -> Eselect_dyn
| Heptagon.Eupdate -> Eupdate
| Heptagon.Eselect_slice -> Eselect_slice
| Heptagon.Econcat -> Econcat
| Heptagon.Earray -> Earray
| Heptagon.Etuple -> Etuple
| Heptagon.Earrow ->
Error.message no_location Error.Eunsupported_language_construct
and translate_array_op env op e_list =
match op, e_list with
| Heptagon.Erepeat, [e; idx] ->
Erepeat (size_exp_of_exp idx, e)
| Heptagon.Eselect idx_list, [e] ->
Eselect (idx_list, e)
| Heptagon.Eselect_dyn, e::defe::idx_list ->
Eselect_dyn (idx_list, 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, op_desc, reset), idx::e_list ->
Eiterator(translate_iterator_type it,
translate_op_desc op_desc,
size_exp_of_exp idx, e_list,
translate_reset reset)
let translate_app env app =
mk_app ~params:app.Heptagon.a_params
~unsafe:app.Heptagon.a_unsafe (translate_op env app.Heptagon.a_op)
let rec translate env
{ Heptagon.e_desc = desc; Heptagon.e_ty = ty;
Heptagon.e_loc = loc } =
match desc with
| Heptagon.Econst(c) ->
Env.const env (mk_exp ~loc:loc ~exp_ty:ty (Econst (const c)))
| Heptagon.Econst c ->
Env.const env (mk_exp ~loc:loc ~exp_ty:ty (Econst c))
| Heptagon.Evar x ->
Env.con env x (mk_exp ~loc:loc ~exp_ty:ty (Evar x))
| Heptagon.Econstvar(x) ->
Env.const env (mk_exp ~loc:loc ~exp_ty:ty (Econstvar x))
| Heptagon.Etuple(e_list) ->
mk_exp ~loc:loc ~exp_ty:ty (Etuple (List.map (translate env) e_list))
| Heptagon.Eapp(app, e_list) ->
mk_exp ~loc:loc ~exp_ty:ty (application env app
(List.map (translate env) e_list))
| Heptagon.Efield(e, field) ->
mk_exp ~loc:loc ~exp_ty:ty (Efield (translate env e, field))
| Heptagon.Epre(None, e) ->
mk_exp ~loc:loc ~exp_ty:ty (Efby(None, translate env e))
| Heptagon.Epre(Some c, e) ->
mk_exp ~loc:loc ~exp_ty:ty (Efby(Some c, translate env e))
| Heptagon.Efby ({ Heptagon.e_desc = Heptagon.Econst c }, e) ->
mk_exp ~loc:loc ~exp_ty:ty (Efby(Some c, translate env e))
| Heptagon.Estruct f_e_list ->
let f_e_list = List.map
(fun (f, e) -> (f, translate env e)) f_e_list in
mk_exp ~loc:loc ~exp_ty:ty (Estruct f_e_list)
| Heptagon.Earray(e_list) ->
mk_exp ~loc:loc ~exp_ty:ty (Earray (List.map (translate env) e_list))
| Heptagon.Eapp(app, e_list, reset) ->
mk_exp ~loc:loc ~exp_ty:ty (Eapp (translate_app env app,
List.map (translate env) e_list,
translate_reset reset))
| Heptagon.Eiterator(it, app, n, e_list, reset) ->
mk_exp ~loc:loc ~exp_ty:ty
(Eiterator (translate_iterator_type it,
translate_app env app, n,
List.map (translate env) e_list,
translate_reset reset))
| Heptagon.Elast _ ->
Error.message loc Error.Eunsupported_language_construct
@ -272,7 +254,7 @@ let rec translate_pat = function
let rec rename_pat ni locals s_eqs = function
| Heptagon.Evarpat(n), ty ->
if IdentSet.mem n ni then (
let n_copy = Ident.fresh (sourcename n) in
let n_copy = Idents.fresh (sourcename n) in
Evarpat n_copy,
(mk_var_dec n_copy ty) :: locals,
add n (mk_exp ~exp_ty:ty (Evar n_copy)) s_eqs
@ -343,7 +325,7 @@ and translate_switch_handlers env ni (locals, l_eqs, s_eqs) e handlers =
[] -> IdentSet.empty
| { Heptagon.w_block = { Heptagon.b_defnames = env } } :: _ ->
(* Create set from env *)
(Ident.Env.fold
(Idents.Env.fold
(fun name _ set -> IdentSet.add name set)
env
IdentSet.empty) in
@ -359,12 +341,10 @@ and translate_switch_handlers env ni (locals, l_eqs, s_eqs) e handlers =
let translate_contract env contract =
match contract with
| None -> None, env
| Some { Heptagon.c_local = v;
Heptagon.c_eq = eq_list;
| Some { Heptagon.c_block = { Heptagon.b_local = v;
Heptagon.b_equs = eq_list };
Heptagon.c_assume = e_a;
Heptagon.c_enforce = e_g;
Heptagon.c_controllables = cl } ->
let env = Env.add cl env in
Heptagon.c_enforce = e_g} ->
let env' = Env.add v env in
let locals = translate_locals [] v in
let locals, l_eqs, s_eqs =
@ -375,22 +355,21 @@ let translate_contract env contract =
Some { c_local = locals;
c_eq = l_eqs;
c_assume = e_a;
c_enforce = e_g;
c_controllables = List.map translate_var cl },
c_enforce = e_g },
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_block = { Heptagon.b_local = v; Heptagon.b_equs = eq_list };
Heptagon.n_loc = loc;
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 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
@ -402,31 +381,32 @@ let node
n_equs = l_eqs;
n_loc = loc ;
n_params = params;
n_params_constraints = params_constr;
n_params_instances = []; }
n_params_constraints = params_constr }
let typedec
{Heptagon.t_name = n; Heptagon.t_desc = tdesc; Heptagon.t_loc = loc} =
let onetype = function
| Heptagon.Type_abs -> Type_abs
| Heptagon.Type_alias ln -> Type_alias ln
| Heptagon.Type_enum tag_list -> Type_enum tag_list
| Heptagon.Type_struct field_ty_list ->
Type_struct field_ty_list
| Heptagon.Type_struct field_ty_list -> Type_struct 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; }
{ Minils.c_name = cd.Heptagon.c_name;
Minils.c_value = cd.Heptagon.c_value;
Minils.c_type = cd.Heptagon.c_type;
Minils.c_loc = cd.Heptagon.c_loc; }
let program
{ Heptagon.p_pragmas = pragmas;
{ Heptagon.p_modname = modname;
Heptagon.p_opened = modules;
Heptagon.p_types = pt_list;
Heptagon.p_nodes = n_list;
Heptagon.p_consts = c_list; } =
{ p_pragmas = pragmas;
{ p_modname = modname;
p_format_version = minils_format_version;
p_opened = modules;
p_types = List.map typedec pt_list;
p_nodes = List.map node n_list;

60
compiler/main/heptc.ml
View file

@ -9,6 +9,7 @@
open Misc
open Modules
open Location
open Compiler_utils
open Hept_compiler
@ -17,68 +18,50 @@ open Hept_compiler
let compile_impl modname filename =
(* input and output files *)
let source_name = filename ^ ".ept"
let source_name = filename ^ ".ept" in
let filename = String.uncapitalize filename
and obj_interf_name = filename ^ ".epci"
and mls_name = filename ^ ".mls"
and obc_name = filename ^ ".obc"
and ml_name = filename ^ ".ml" in
and mls_name = filename ^ ".mls" in
let ic = open_in source_name
let ic, lexbuf = lexbuf_from_file source_name
and itc = open_out_bin obj_interf_name
and mlsc = open_out mls_name
and obc = open_out obc_name
and mlc = open_out ml_name in
and mlsc = open_out mls_name in
let close_all_files () =
close_in ic;
close_out itc;
close_out mlsc;
close_out obc;
close_out mlc in
close_out mlsc in
try
init_compiler modname source_name ic;
init_compiler modname;
add_include (Filename.dirname filename);
(* Parsing of the file *)
let lexbuf = Lexing.from_channel ic in
let p = parse_implementation lexbuf in
let p = do_silent_pass "Parsing" (parse_implementation modname) lexbuf in
(* Convert the parse tree to Heptagon AST *)
let p = Scoping.translate_program p in
comment "Parsing";
pp p;
let p = do_pass "Scoping" Hept_scoping.translate_program p pp in
(* Process the Heptagon AST *)
let p = Hept_compiler.compile_impl pp p in
Modules.write itc;
let p = compile_impl pp p in
output_value itc (Modules.current_module ());
(* Set pretty printer to the Minils one *)
let pp = Mls_compiler.pp in
(* Compile Heptagon to MiniLS *)
let p = Hept2mls.program p in
let pp = Mls_printer.print stdout in
comment "Translation into MiniLs";
let p = do_pass "Translation into MiniLs" Hept2mls.program p pp in
Mls_printer.print mlsc p;
(* Process the MiniLS AST *)
let p = Mls_compiler.compile pp p in
(* Compile MiniLS to Obc *)
let o = Mls2obc.program p in
comment "Translation into Obc";
Obc.Printer.print obc o;
let pp = Obc.Printer.print stdout in
if !verbose then pp o;
(* Translation into dataflow and sequential languages *)
Mls2seq.targets filename p o !target_languages;
(* Generate the sequential code *)
Mls2seq.program p;
close_all_files ()
with
| x -> close_all_files (); raise x
with x -> close_all_files (); raise x
let main () =
@ -91,7 +74,10 @@ let main () =
"-I", Arg.String add_include, doc_include;
"-where", Arg.Unit locate_stdlib, doc_locate_stdlib;
"-stdlib", Arg.String set_stdlib, doc_stdlib;
"-c", Arg.Set create_object_file, doc_object_file;
"-s", Arg.String set_simulation_node, doc_sim;
"-inline", Arg.String add_inlined_node, doc_inline;
"-flatten", Arg.Set flatten, doc_flatten;
"-assert", Arg.String add_assert, doc_assert;
"-nopervasives", Arg.Unit set_no_pervasives, doc_no_pervasives;
"-target", Arg.String add_target_language, doc_target;

514
compiler/main/mls2obc.ml Normal file
View file

@ -0,0 +1,514 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Translation from Minils to Obc. *)
open Misc
open Names
open Idents
open Signature
open Obc
open Types
open Control
open Static
open Obc_mapfold
open Initial
(** Not giving any type and called after typing, DO NOT use it anywhere else *)
let static_exp_of_int i =
Types.mk_static_exp (Types.Sint i)
let gen_obj_name n =
(shortname n) ^ "_mem" ^ (gen_symbol ())
let op_from_string op = { qual = "Pervasives"; name = op; }
let rec lhs_of_idx_list e = function
| [] -> e | idx :: l -> mk_lhs (Larray (lhs_of_idx_list e l, idx))
let array_elt_of_exp idx e =
match e.e_desc with
| Econst ({ se_desc = Sarray_power (c, _) }) ->
mk_exp (Econst c)
| _ ->
mk_lhs_exp (Larray(lhs_of_exp e, mk_exp (Elhs idx)))
(** 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] ->
mk_exp (Eop (op_from_string "<",
[ idx; mk_exp (Econst n)]))
| (idx :: idx_list, n :: bounds) ->
let e = mk_exp (Eop (op_from_string "<",
[idx; mk_exp (Econst n)])) in
mk_exp (Eop (op_from_string "&",
[e; bound_check_expr idx_list bounds]))
| (_, _) -> assert false
let reinit o =
Acall ([], o, Mreset, [])
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 []
let translate_var_dec map l =
let one_var { Minils.v_ident = x; Minils.v_type = t; v_loc = loc } =
mk_var_dec ~loc:loc x t
in
List.map one_var l
(* [translate e = c] *)
let rec translate map (si, j, s) e =
let desc = match e.Minils.e_desc with
| Minils.Econst v -> Econst v
| Minils.Evar n -> Elhs (var_from_name map n)
| Minils.Eapp ({ Minils.a_op = Minils.Eequal }, e_list, _) ->
Eop (op_from_string "=", List.map (translate map (si, j, s)) e_list)
| Minils.Eapp ({ Minils.a_op = Minils.Efun n },
e_list, _) when Mls_utils.is_op n ->
Eop (n, List.map (translate map (si, j, s)) e_list)
| Minils.Ewhen (e, _, _) ->
let e = translate map (si, j, s) e in
e.e_desc
| Minils.Estruct f_e_list ->
let type_name =
(match e.Minils.e_ty with
| Tid name -> name
| _ -> assert false) in
let f_e_list =
List.map
(fun (f, e) -> (f, (translate map (si, j, s) e)))
f_e_list
in Estruct (type_name, f_e_list)
| Minils.Eapp ({ Minils.a_op = Minils.Efield;
Minils.a_params = [{ se_desc = Sfield f }] },
[e], _) ->
let e = translate map (si, j, s) e in
Elhs (mk_lhs (Lfield (lhs_of_exp e, f)))
(*Array operators*)
| Minils.Eapp ({ Minils.a_op = Minils.Earray }, e_list, _) ->
Earray (List.map (translate map (si, j, s)) e_list)
| Minils.Eapp ({ Minils.a_op = Minils.Eselect;
Minils.a_params = idx }, [e], _) ->
let e = translate map (si, j, s) e in
let idx_list = List.map (fun idx -> mk_exp (Econst idx)) idx in
Elhs (lhs_of_idx_list (lhs_of_exp e) idx_list)
| _ ->
Format.eprintf "%a@." Mls_printer.print_exp e;
assert false
in
mk_exp ~ty:e.Minils.e_ty desc
(* [translate pat act = si, d] *)
and translate_act map context pat
({ Minils.e_desc = desc } as act) =
match pat, desc with
| Minils.Etuplepat p_list,
Minils.Eapp ({ Minils.a_op = Minils.Etuple }, act_list, _) ->
List.flatten (List.map2 (translate_act map context) p_list act_list)
| Minils.Etuplepat p_list,
Minils.Econst { se_desc = Stuple se_list } ->
let const_list = Mls_utils.exp_list_of_static_exp_list se_list in
List.flatten (List.map2 (translate_act map context) p_list const_list)
| pat, Minils.Ewhen (e, _, _) ->
translate_act map context pat e
| pat, Minils.Emerge (x, c_act_list) ->
let lhs = var_from_name map x in
[Acase (mk_exp (Elhs lhs),
translate_c_act_list map context pat c_act_list)]
| Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) ->
let cpt1 = Idents.fresh "i" in
let cpt2 = Idents.fresh "i" in
let x = var_from_name map x in
(match e1.Minils.e_ty, e2.Minils.e_ty with
| Tarray (_, n1), Tarray (_, n2) ->
let e1 = translate map context e1 in
let e2 = translate map context e2 in
let a1 =
Afor (cpt1, mk_static_int 0, n1,
mk_block [Aassgn (mk_lhs (Larray (x, mk_evar cpt1)),
mk_lhs_exp (Larray (lhs_of_exp e1,
mk_evar cpt1)))] ) in
let idx = mk_exp (Eop (op_from_string "+",
[ mk_exp (Econst n1); mk_evar cpt2])) in
let a2 =
Afor (cpt2, static_exp_of_int 0, n2,
mk_block [Aassgn (mk_lhs (Larray (x, idx)),
mk_lhs_exp (Larray (lhs_of_exp e2,
mk_evar cpt2)))] )
in
[a1; a2]
| _ -> assert false )
| Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Earray_fill;
Minils.a_params = [n] }, [e], _) ->
let cpt = Idents.fresh "i" in
let e = translate map context e in
[ Afor (cpt, mk_static_int 0, n,
mk_block [Aassgn (mk_lhs (Larray (var_from_name map x,
mk_evar cpt)), e) ]) ]
| Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice;
Minils.a_params = [idx1; idx2] }, [e], _) ->
let cpt = Idents.fresh "i" in
let e = translate map context e in
let idx = mk_exp (Eop (op_from_string "+",
[mk_evar cpt;
mk_exp (Econst idx1) ])) in
(* bound = (idx2 - idx1) + 1*)
let bound = mk_static_int_op (op_from_string "+")
[ mk_static_int 1;
mk_static_int_op (op_from_string "-") [idx2;idx1] ] in
[ Afor (cpt, mk_static_int 0, bound,
mk_block [Aassgn (mk_lhs (Larray (var_from_name map x,
mk_evar cpt)),
mk_lhs_exp (Larray (lhs_of_exp e, idx)))] ) ]
| Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Eselect_dyn }, e1::e2::idx, _) ->
let x = var_from_name map x in
let bounds = Mls_utils.bounds_list e1.Minils.e_ty in
let e1 = translate map context e1 in
let idx = List.map (translate map context) idx in
let true_act =
Aassgn (x, mk_exp (Elhs (lhs_of_idx_list (lhs_of_exp e1) idx))) in
let false_act = Aassgn (x, translate map context e2) in
let cond = bound_check_expr idx bounds in
[ Acase (cond, [ ptrue, mk_block [true_act];
pfalse, mk_block [false_act] ]) ]
| Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Eupdate },
e1::e2::idx, _) ->
let x = var_from_name map x in
let bounds = Mls_utils.bounds_list e1.Minils.e_ty in
let idx = List.map (translate map context) idx in
let action = Aassgn (lhs_of_idx_list x idx,
translate map context e2) in
let cond = bound_check_expr idx bounds in
let action = Acase (cond, [ ptrue, mk_block [action] ]) in
let copy = Aassgn (x, translate map context e1) in
[copy; action]
| Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Efield_update;
Minils.a_params = [{ se_desc = Sfield f }] },
[e1; e2], _) ->
let x = var_from_name map x in
let copy = Aassgn (x, translate map context e1) in
let action = Aassgn (mk_lhs (Lfield (x, f)),
translate map context e2) in
[copy; action]
| Minils.Evarpat n, _ ->
[Aassgn (var_from_name map n, translate map context act)]
| _ ->
(*let ff = Format.formatter_of_out_channel stdout in
Mls_printer.print_exp ff act; Format.fprintf ff "@?";*) assert false
and translate_c_act_list map context pat c_act_list =
List.map
(fun (c, act) -> (c, mk_block (translate_act map context pat act)))
c_act_list
let mk_obj_call_from_context (o, _) n =
match o with
| Oobj _ -> Oobj n
| Oarray (_, lhs) -> Oarray(n, lhs)
let size_from_call_context (_, n) = n
let empty_call_context = Oobj "n", None
let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
(v, si, j, s) =
let { Minils.e_desc = desc; Minils.e_ty = ty;
Minils.e_ck = ck; Minils.e_loc = loc } = 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 ->
(Aassgn (x,
mk_exp (Econst c))) :: si) in
let action = Aassgn (var_from_name map n,
translate map (si, j, s) e)
in
v, si, j, (control map ck action) :: s
| Minils.Etuplepat p_list,
Minils.Eapp({ Minils.a_op = Minils.Etuple }, act_list, _) ->
List.fold_right2
(fun pat e ->
translate_eq map call_context
(Minils.mk_equation pat e))
p_list act_list (v, si, j, s)
| pat, Minils.Eapp({ Minils.a_op = Minils.Eifthenelse }, [e1;e2;e3], _) ->
let cond = translate map (si, j, s) e1 in
let vt, si, j, true_act = translate_eq map call_context
(Minils.mk_equation pat e2) (v, si, j, s) in
let vf, si, j, false_act = translate_eq map call_context
(Minils.mk_equation pat e3) (v, si, j, s) in
let vf = translate_var_dec map vf in
let vt = translate_var_dec map vt in
let action =
Acase (cond, [ptrue, mk_block ~locals:vt true_act;
pfalse, mk_block ~locals:vf false_act]) in
v, si, j, (control map ck action) :: s
| pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app,
e_list, r) ->
let name_list = translate_pat map pat in
let c_list = List.map (translate map (si, j, s)) e_list in
let v', si', j', action = mk_node_call map call_context
app loc name_list c_list in
let action = List.map (control map ck) action in
let s = (match r, app.Minils.a_op with
| Some r, Minils.Enode _ ->
let ck = Clocks.Con (ck, Initial.ptrue, r) in
let ra = List.map (control map ck) si' in
ra @ action @ s
| _, _ -> action @ s) in
v' @ v, si'@si, j'@j, s
| pat, Minils.Eiterator (it, app, n, e_list, reset) ->
let name_list = translate_pat map pat in
let c_list =
List.map (translate map (si, j, s)) e_list in
let x = Idents.fresh "i" in
let call_context = Oarray ("n", mk_lhs (Lvar x)), Some n in
let si', j', action = translate_iterator map call_context it
name_list app loc n x c_list in
let action = List.map (control map ck) action in
let s =
(match reset, app.Minils.a_op with
| Some r, Minils.Enode _ ->
let ck = Clocks.Con (ck, Initial.ptrue, r) in
let ra = List.map (control map ck) si' in
ra @ action @ s
| _, _ -> action @ s)
in (v, si' @ si, j' @ j, s)
| (pat, _) ->
let action = translate_act map (si, j, s) pat e in
let action = List.map (control map ck) action in
v, si, j, action @ s
and translate_eq_list map call_context act_list =
List.fold_right (translate_eq map call_context) act_list ([], [], [], [])
and mk_node_call map call_context app loc name_list args =
match app.Minils.a_op with
| Minils.Efun f when Mls_utils.is_op f ->
let e = mk_exp (Eop(f, args)) in
[], [], [], [Aassgn(List.hd name_list, e) ]
| Minils.Enode f when Itfusion.is_anon_node f ->
let add_input env vd =
Env.add vd.Minils.v_ident (mk_lhs (Lvar vd.Minils.v_ident)) env in
let build env vd a =
Env.add vd.Minils.v_ident a env in
let subst_act_list env act_list =
let exp funs env e = match e.e_desc with
| Elhs { l_desc = Lvar x } ->
let e =
(try Env.find x env
with Not_found -> e) in
e, env
| _ -> Obc_mapfold.exp funs env e
in
let funs = { Obc_mapfold.defaults with exp = exp } in
let act_list, _ = mapfold (Obc_mapfold.act_it funs) env act_list in
act_list
in
let nd = Itfusion.find_anon_node f in
let map = List.fold_left add_input map nd.Minils.n_input in
let map = List.fold_left2 build map nd.Minils.n_output name_list in
let map = List.fold_left add_input map nd.Minils.n_local in
let v, si, j, s = translate_eq_list map call_context nd.Minils.n_equs in
let env = List.fold_left2 build Env.empty nd.Minils.n_input args in
v @ nd.Minils.n_local, si, j, subst_act_list env s
| Minils.Enode f | Minils.Efun f ->
let o = mk_obj_call_from_context call_context (gen_obj_name f) in
let obj =
{ o_name = obj_call_name o; o_class = f;
o_params = app.Minils.a_params;
o_size = size_from_call_context call_context; o_loc = loc } in
let si =
(match app.Minils.a_op with
| Minils.Efun _ -> []
| Minils.Enode _ -> [reinit o]) in
[], si, [obj], [Acall (name_list, o, Mstep, args)]
| _ -> assert false
and translate_iterator map call_context it name_list app loc n x c_list =
let array_of_output name_list =
List.map (fun l -> mk_lhs (Larray (l, mk_evar x))) name_list in
let array_of_input c_list =
List.map (array_elt_of_exp (mk_lhs (Lvar x))) c_list in
match it with
| Minils.Imap ->
let c_list = array_of_input c_list in
let name_list = array_of_output name_list in
let v, si, j, action = mk_node_call map call_context
app loc name_list c_list in
let v = translate_var_dec map v in
let b = mk_block ~locals:v action in
si, j, [ Afor (x, static_exp_of_int 0, n, b) ]
| Minils.Imapfold ->
let (c_list, acc_in) = split_last c_list in
let c_list = array_of_input c_list in
let (name_list, acc_out) = split_last name_list in
let name_list = array_of_output name_list in
let v, si, j, action = mk_node_call map call_context
app loc (name_list @ [ acc_out ])
(c_list @ [ mk_exp (Elhs acc_out) ]) in
let v = translate_var_dec map v in
let b = mk_block ~locals:v action in
si, j, [Aassgn (acc_out, acc_in);
Afor (x, static_exp_of_int 0, n, b)]
| Minils.Ifold ->
let (c_list, acc_in) = split_last c_list in
let c_list = array_of_input c_list in
let acc_out = last_element name_list in
let v, si, j, action = mk_node_call map call_context
app loc name_list (c_list @ [ mk_exp (Elhs acc_out) ]) in
let v = translate_var_dec map v in
let b = mk_block ~locals:v action in
si, j, [ Aassgn (acc_out, acc_in);
Afor (x, static_exp_of_int 0, n, b) ]
| Minils.Ifoldi ->
let (c_list, acc_in) = split_last c_list in
let c_list = array_of_input c_list in
let acc_out = last_element name_list in
let v, si, j, action = mk_node_call map call_context
app loc name_list (c_list @ [ mk_evar x; mk_exp (Elhs acc_out) ]) in
let v = translate_var_dec map v in
let b = mk_block ~locals:v action in
si, j, [ Aassgn (acc_out, acc_in);
Afor (x, static_exp_of_int 0, n, b) ]
let remove m d_list =
List.filter (fun { Minils.v_ident = n } -> not (List.mem_assoc n m)) d_list
let translate_contract map mem_vars =
function
| None -> ([], [], [], [])
| Some
{
Minils.c_eq = eq_list;
Minils.c_local = d_list;
Minils.c_assume = e_a;
Minils.c_enforce = e_c
} ->
let (v, si, j, s_list) = translate_eq_list map
empty_call_context eq_list in
let d_list = translate_var_dec map (v @ d_list) in
let d_list = List.filter
(fun vd -> not (List.mem vd.v_ident mem_vars)) d_list in
(si, j, s_list, d_list)
(** Returns a map, mapping variables names to the variables
where they will be stored. *)
let subst_map inputs outputs locals mems =
(* Create a map that simply maps each var to itself *)
let m =
List.fold_left
(fun m { Minils.v_ident = x } -> Env.add x (mk_lhs (Lvar x)) m)
Env.empty (inputs @ outputs @ locals)
in
List.fold_left (fun m x -> Env.add x (mk_lhs (Lmem x)) m) m mems
let translate_node
({
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_params = params;
Minils.n_loc = loc;
} as n) =
let mem_vars = Mls_utils.node_memory_vars n in
let subst_map = subst_map i_list o_list d_list mem_vars in
let (v, si, j, s_list) = translate_eq_list subst_map
empty_call_context eq_list in
let (si', j', s_list', d_list') =
translate_contract subst_map mem_vars contract in
let i_list = translate_var_dec subst_map i_list in
let o_list = translate_var_dec subst_map o_list in
let d_list = translate_var_dec subst_map (v @ d_list) in
let m, d_list = List.partition
(fun vd -> List.mem vd.v_ident mem_vars) d_list in
let s = joinlist (s_list @ s_list') in
let j = j' @ j in
let si = joinlist (si @ si') in
let stepm = {
m_name = Mstep; m_inputs = i_list; m_outputs = o_list;
m_body = mk_block ~locals:(d_list' @ d_list) s } in
let resetm = {
m_name = Mreset; m_inputs = []; m_outputs = [];
m_body = mk_block si } in
{ cd_name = f; cd_mems = m; cd_params = params;
cd_objs = j; cd_methods = [stepm; resetm];
cd_loc = loc }
let translate_ty_def { Minils.t_name = name; Minils.t_desc = tdesc;
Minils.t_loc = loc } =
let tdesc = match tdesc with
| Minils.Type_abs -> Type_abs
| Minils.Type_alias ln -> Type_alias ln
| Minils.Type_enum tag_name_list ->
Type_enum (List.map shortname tag_name_list)
| Minils.Type_struct field_ty_list ->
Type_struct field_ty_list in
{ t_name = name; t_desc = tdesc; t_loc = loc }
let translate_const_def { Minils.c_name = name; Minils.c_value = se;
Minils.c_type = ty; Minils.c_loc = loc } =
{ c_name = name;
c_value = se;
c_type = ty;
c_loc = loc }
let program {
Minils.p_modname = p_modname;
Minils.p_opened = p_module_list;
Minils.p_types = p_type_list;
Minils.p_nodes = p_node_list;
Minils.p_consts = p_const_list
} =
{
p_modname = p_modname;
p_opened = p_module_list;
p_types = List.map translate_ty_def p_type_list;
p_consts = List.map translate_const_def p_const_list;
p_defs = List.map translate_node p_node_list;
}

2
compiler/minils/_tags
View file

@ -1 +1 @@
<analysis> or <transformations> or <main> or <parsing> or <sequential>:include
<analysis> or <transformations> or <main> or <parsing>:include

230
compiler/minils/analysis/clocking.ml
View file

@ -9,180 +9,92 @@
(* clock checking *)
open Misc
open Ident
open Idents
open Minils
open Mls_printer
open Signature
open Types
open Clocks
open Location
open Printf
open Format
(** Error Kind *)
type err_kind = | Etypeclash of ct * ct
type error_kind = | Etypeclash of ct * ct
let err_message exp = function
let error_message loc = function
| Etypeclash (actual_ct, expected_ct) ->
Printf.eprintf "%aClock Clash: this expression has clock %a, \n\
but is expected to have clock %a.\n"
print_exp exp
Format.eprintf "%aClock Clash: this expression has clock %a,@\n\
but is expected to have clock %a.@."
print_location loc
print_clock actual_ct
print_clock expected_ct;
raise Error
exception Unify
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) ->
(try List.iter2 unify ct_list1 ct_list2 with | _ -> raise Unify)
| _ -> 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)
| Tarray _ | Tid _ -> 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)
| Ecall(_, e_list, r) ->
let ck_r = match r with
| None -> new_var()
| Some(reset) -> typ_of_name h reset
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)
| 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)
| 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)
| Earray e_list ->
let ck = new_var ()
in (List.iter (expect h (Ck ck)) e_list; skeleton ck e.e_ty)
| Earray_op(op) -> typing_array_op h e op
let ct = match e.e_desc with
| Econst se -> skeleton (new_var ()) se.se_ty
| Evar x -> Ck (typ_of_name h x)
| Efby (c, e) -> typing h e
| Eapp({a_op = op}, args, r) ->
let ck = match r with
| None -> new_var ()
| Some(reset) -> typ_of_name h reset in
typing_op op args h e ck
| Eiterator (_, _, _, args, r) -> (* Typed exactly as a fun or a node... *)
let ck = match r with
| None -> new_var()
| Some(reset) -> typ_of_name h reset
in (List.iter (expect h (Ck ck)) args; skeleton ck 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)
| 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)
| 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)
in (e.e_ck <- ckofct ct; ct)
and typing_array_op h e = function
| Erepeat (_, e) -> typing h e
| Eselect (_, e) -> typing h e
| Eselect_dyn (e_list, e, defe) ->
let ck = new_var () in
and typing_op op args h e ck = match op, args with
| (Eequal | Efun _ | Enode _), e_list ->
(List.iter (expect h (Ck ck)) e_list; skeleton ck e.e_ty)
| Etuple, e_list ->
Cprod (List.map (typing h) e_list)
| Eifthenelse, [e1; e2; e3] ->
let ct = skeleton ck e.e_ty
in (expect h ct e; List.iter (expect h ct) e_list; ct)
| Eupdate (_, e1, e2) ->
let ck = new_var () in
in (expect h (Ck ck) e1; expect h ct e2; expect h ct e3; ct)
| Efield, [e1] ->
let ct = skeleton ck e1.e_ty in (expect h (Ck ck) e1; ct)
| Efield_update, [e1; e2] ->
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
| Earray, e_list ->
(List.iter (expect h (Ck ck)) e_list; skeleton ck e.e_ty)
| Earray_fill, [e] -> typing h e
| Eselect, [e] -> typing h e
| Eselect_dyn, e1::defe::idx -> (* TODO defe not treated ? *)
let ct = skeleton ck e1.e_ty
in (List.iter (expect h ct) (e1::defe::idx); ct)
| Eupdate, e1::e2::idx ->
let ct = skeleton ck e.e_ty
in (expect h (Ck ck) e1; expect h ct e2; List.iter (expect h ct) idx; ct)
| Eselect_slice, [e] -> typing h e
| Econcat, [e1; e2] ->
let ct = skeleton ck e.e_ty
in (expect h (Ck ck) e1; expect h ct e2; ct)
| Eiterator (_, _, _, e_list, r) ->
let ck_r = match r with
| None -> new_var()
| Some(reset) -> typ_of_name h reset
in (List.iter (expect h (Ck ck_r)) e_list; skeleton ck_r e.e_ty)
and expect h expected_ty e =
let actual_ty = typing h e
in
let actual_ty = typing h e in
try unify actual_ty expected_ty
with | Unify -> err_message e (Etypeclash (actual_ty, expected_ty))
with
| Unify -> eprintf "%a : " print_exp e;
error_message e.e_loc (Etypeclash (actual_ty, expected_ty))
and typing_c_e_list h ck_c n c_e_list =
let rec typrec =
@ -198,15 +110,15 @@ let rec typing_pat h =
| Etuplepat pat_list -> Cprod (List.map (typing_pat h) pat_list)
let typing_eqs h eq_list = (*TODO FIXME*)
let typing_eq { eq_lhs = pat; eq_rhs = e } = match e.e_desc with
| _ -> let ty_pat = typing_pat h pat in
(try expect h ty_pat e with
| Error -> (* DEBUG *)
Printf.eprintf "Complete expression: %a\nClock pattern: %a\n"
Mls_printer.print_exp e
Mls_printer.print_clock ty_pat;
raise Error) in
List.iter typing_eq eq_list
let typing_eq { eq_lhs = pat; eq_rhs = e } =
let ty_pat = typing_pat h pat in
(try expect h ty_pat e with
| Error -> (* DEBUG *)
Format.eprintf "Complete expression: %a@\nClock pattern: %a@."
Mls_printer.print_exp e
Mls_printer.print_clock ty_pat;
raise Error)
in List.iter typing_eq eq_list
let build h dec =
List.fold_left (fun h { v_ident = n } -> Env.add n (new_var ()) h) h dec
@ -220,9 +132,7 @@ let typing_contract h contract base =
| 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
c_enforce = e_g; } ->
let h' = build h l_list in
(* assumption *)
(* property *)
@ -245,7 +155,7 @@ let typing_node ({ n_name = f;
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_ident h) } in
let set_clock vd = { vd with v_clock = ck_repr (Env.find vd.v_ident h) } in
{ (node) with
n_input = List.map set_clock i_list;
n_output = List.map set_clock o_list;

26
compiler/minils/analysis/init.ml
View file

@ -16,7 +16,7 @@
open Misc
open Names
open Ident
open Idents
open Minils
open Location
open Format
@ -156,24 +156,20 @@ struct
List.iter (fprintf ff "%s@]@ @[%a" sep print) l;
fprintf ff "%s@]" pf)
let rec fprint_init ff i =
let rec print_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
fprintf ff "@[%a\\/%a@]" print_init i1 print_init i2
| Ilink i -> print_init ff i
let rec fprint_typ ff =
let rec print_type ff =
function
| Ileaf i -> fprint_init ff i
| Ileaf i -> print_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 "@?@]")
fprintf ff "@[%a@]" (print_list_r fprint_type "(" " *" ")") ty_list
end
@ -190,11 +186,11 @@ struct
let message loc kind =
((match kind with
| Eclash (left_ty, right_ty) ->
Printf.eprintf
Format.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.
%a,@\n\
but is expected to have type %a@."
print_location loc Printer.output_typ left_ty Printer.
output_typ right_ty);
raise Misc.Error)

111
compiler/minils/main/mls2seq.ml
View file

@ -8,51 +8,74 @@
(**************************************************************************)
open Compiler_utils
open Obc
open Minils
open Misc
(** 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
(** Definition of a target. A target starts either from
dataflow code (ie Minils) or sequential code (ie Obc),
with or without static parameters*)
type target =
| Obc of (Obc.program -> unit)
| Obc_no_params of (Obc.program -> unit)
| Minils of (Minils.program -> unit)
| Minils_no_params of (Minils.program -> unit)
(** Generation of a sequential target *)
let sequential_target filename o target_languages =
let rec one_target = function
| "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 = Cmain.translate filename o in
C.output dir c_ast;
one_target others
| unknown_lg :: others -> unknown_lg :: one_target others
| [] -> [] in
one_target target_languages
(** Writes a .epo file for program [p]. *)
let write_object_file p =
let filename = (filename_of_name p.Minils.p_modname)^".epo" in
let epoc = open_out_bin filename in
output_value epoc p;
close_out epoc;
comment "Generating of object file"
(** 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
(** Writes a .epo file for program [p]. *)
let write_obc_file p =
let obc_name = (filename_of_name p.Obc.p_modname)^".obc" in
let obc = open_out obc_name in
Obc_printer.print obc p;
close_out obc;
comment "Generation of Obc code"
let targets = [ "c", Obc_no_params Cmain.program;
"obc", Obc write_obc_file;
"obc_np", Obc_no_params write_obc_file;
"epo", Minils write_object_file ]
let generate_target p s =
let print_unfolded p_list =
comment "Unfolding";
if !Misc.verbose then List.iter (Mls_printer.print stderr) p_list in
let target =
(try List.assoc s targets
with Not_found -> language_error s; raise Error) in
match target with
| Minils convert_fun ->
convert_fun p
| Obc convert_fun ->
let o = Mls2obc.program p in
convert_fun o
| Minils_no_params convert_fun ->
let p_list = Callgraph.program p in
List.iter convert_fun p_list
| Obc_no_params convert_fun ->
let p_list = Callgraph.program p in
let o_list = List.map Mls2obc.program p_list in
print_unfolded p_list;
comment "Translation to Obc";
if !Misc.verbose then
List.iter (Obc_printer.print stdout) o_list;
List.iter convert_fun o_list
let program p =
(* Translation into dataflow and sequential languages *)
let targets =
if !create_object_file then
["epo"]
else
match !target_languages with
| [] -> ["obc"]; (* by default, generate obc file *)
| l -> l
in
List.iter (generate_target p) targets

35
compiler/minils/main/mls_compiler.ml
View file

@ -7,24 +7,41 @@
(* *)
(**************************************************************************)
open Misc
open Location
open Compiler_utils
let pp p = if !verbose then Mls_printer.print stdout p
(*
let parse parsing_fun lexing_fun lexbuf =
try
parsing_fun lexing_fun lexbuf
with
| Mls_lexer.Lexical_error(err, loc) ->
lexical_error err loc
| Mls_parser.Error ->
let pos1 = Lexing.lexeme_start_p lexbuf
and pos2 = Lexing.lexeme_end_p lexbuf in
let l = Loc(pos1,pos2) in
syntax_error l
let parse_implementation prog_name lexbuf =
let p = parse Mls_parser.program Mls_lexer.token lexbuf in
{ p with Mls_parsetree.p_modname = prog_name }
*)
let compile pp p =
(* Clocking *)
let p = do_silent_pass Clocking.program "Clocking" p true in
let p = pass "Clocking" true Clocking.program p pp in
(* Check that the dataflow code is well initialized *)
let p =
do_silent_pass Init.program "Initialization check" p !init in
(*let p = silent_pass "Initialization check" !init Init.program p in *)
(* Iterator fusion *)
(*let p = pass "Iterator fusion" false Itfusion.program p pp in*)
(* Normalization to maximize opportunities *)
let p = do_pass Normalize.program "Normalization" p pp true in
let p = pass "Normalization" true Normalize.program p pp in
(* Scheduling *)
let p = do_pass Schedule.program "Scheduling" p pp true in
(* Parametrized functions instantiation *)
let p = do_pass Callgraph.program
"Parametrized functions instantiation" p pp true in
let p = pass "Scheduling" true Schedule.program p pp in
p

59
compiler/minils/main/mlsc.ml
View file

@ -12,33 +12,14 @@ open Location
open Compiler_utils
open Mls2seq
let pp = Mls_printer.print stdout
let parse parsing_fun lexing_fun lexbuf =
try
parsing_fun lexing_fun lexbuf
with
| Mls_lexer.Lexical_error(err, pos1, pos2) ->
lexical_error err (Loc(pos1, pos2))
| Mls_parser.Error ->
let pos1 = Lexing.lexeme_start lexbuf
and pos2 = Lexing.lexeme_end lexbuf in
let l = Loc(pos1,pos2) in
syntax_error l
let parse_implementation lexbuf =
parse Mls_parser.program Mls_lexer.token lexbuf
let compile_impl modname filename =
(* input and output files *)
(* input and output files *)
let source_name = filename ^ ".mls"
and mls_norm_name = filename ^ "_norm.mls"
and obc_name = filename ^ ".obc" in
let ic = open_in source_name
let ic, lexbuf = lexbuf_from_file source_name
and mlsnc = open_out mls_norm_name
and obc = open_out obc_name in
@ -49,35 +30,23 @@ let compile_impl modname filename =
in
try
init_compiler modname source_name ic;
init_compiler modname;
(* Set pretty printer to the Minils one *)
let pp = Mls_compiler.pp in
(* Parsing of the file *)
let lexbuf = Lexing.from_channel ic in
let p = parse_implementation lexbuf in
if !verbose
then begin
comment "Parsing";
pp p
end;
let p = do_silent_pass "Parsing" (Mls_compiler.parse_implementation modname)
lexbuf in
(* Call the compiler*)
(* Convert Parse tree to Minils AST *)
let p = do_pass "Scoping" Mls_scoping.translate_program p pp in
(* Process the MiniLS AST *)
let p = Mls_compiler.compile pp p in
if !verbose
then begin
comment "Checking"
end;
(* Producing Object-based code *)
let o = Mls2obc.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;
(* Generate the sequential code *)
Mls2seq.program p;
close_all_files ()
@ -98,12 +67,12 @@ let main () =
Arg.parse
[
"-v", Arg.Set verbose, doc_verbose;
"-assert", Arg.String add_assert, doc_assert;
"-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;
"-c", Arg.Set create_object_file, doc_object_file;
"-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;

216
compiler/minils/minils.ml
View file

@ -11,144 +11,129 @@
open Location
open Names
open Ident
open Idents
open Signature
open Static
open Types
open Clocks
(** Warning: Whenever Minils ast is modified,
minils_format_version should be incremented. *)
let minils_format_version = "1"
type iterator_type =
| Imap
| Ifold
| Ifoldi
| Imapfold
type type_dec =
{ t_name: name;
t_desc: tdesc;
t_loc: location }
type type_dec = {
t_name: qualname;
t_desc: tdesc;
t_loc: location }
and tdesc =
| Type_abs
| Type_enum of name list
| Type_alias of ty
| Type_enum of constructor_name list
| Type_struct of structure
and exp =
{ e_desc: edesc; (* its descriptor *)
mutable e_ck: ck;
mutable e_ty: ty;
e_loc: location }
and exp = {
e_desc: edesc;
mutable e_ck: ck;
mutable e_ty: ty;
e_loc: location }
and edesc =
| Econst of const
| Evar of ident
| Econstvar of name
| Efby of const option * exp
| Etuple of exp list
| Ecall of op_desc * exp list * ident option (** [op_desc] is the function
called [exp list] is the
passed arguments [ident
option] is the optional reset
condition *)
| Econst of static_exp
| Evar of var_ident
| Efby of static_exp option * exp
(** static_exp fby exp *)
| Eapp of app * exp list * var_ident option
(** app ~args=(exp,exp...) reset ~r=ident *)
| Ewhen of exp * constructor_name * var_ident
(** exp when Constructor(ident) *)
| Emerge of var_ident * (constructor_name * exp) list
(** merge ident (Constructor -> exp)+ *)
| Estruct of (field_name * exp) list
(** { field=exp; ... } *)
| Eiterator of iterator_type * app * static_exp * exp list * var_ident option
(** map f <<n>> (exp, exp...) reset ident *)
| Ewhen of exp * longname * ident
| Emerge of ident * (longname * exp) list
| Eifthenelse of exp * exp * exp
| Efield of exp * longname
| Efield_update of longname * exp * exp (*field, record, value*)
| Estruct of (longname * exp) list
| Earray of exp list
| Earray_op of array_op
and app = { a_op: op; a_params: static_exp list; a_unsafe: bool }
(** Unsafe applications could have side effects
and be delicate about optimizations, !be careful! *)
and array_op =
| Erepeat of size_exp * exp
| Eselect of size_exp list * exp (*indices, array*)
| Eselect_dyn of exp list * exp * exp (* indices, 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_type * op_desc * size_exp * exp list * ident option
(** [op_desc] is the function iterated, [size_exp] is the size of the
iteration, [exp list] is the passed arguments, [ident option] is the
optional reset condition *)
and op =
| Eequal (** arg1 = arg2 *)
| Etuple (** (args) *)
| Efun of fun_name (** "Stateless" longname <<a_params>> (args) reset r *)
| Enode of fun_name (** "Stateful" longname <<a_params>> (args) reset r *)
| Eifthenelse (** if arg1 then arg2 else arg3 *)
| Efield (** arg1.a_param1 *)
| Efield_update (** { arg1 with a_param1 = arg2 } *)
| Earray (** [ args ] *)
| Earray_fill (** [arg1^a_param1] *)
| Eselect (** arg1[a_params] *)
| Eselect_slice (** arg1[a_param1..a_param2] *)
| Eselect_dyn (** arg1.[arg3...] default arg2 *)
| Eupdate (** [ arg1 with arg3..arg_n = arg2 ] *)
| Econcat (** arg1@@arg2 *)
and op_desc = { op_name: longname; op_params: size_exp list; op_kind: op_kind }
and op_kind = | Efun | Enode
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 const =
| Cint of int
| Cfloat of float
| Cconstr of longname
| Carray of size_exp * const
and pat =
type pat =
| Etuplepat of pat list
| Evarpat of ident
| Evarpat of var_ident
type eq =
{ eq_lhs : pat;
eq_rhs : exp;
eq_loc : location }
type eq = {
eq_lhs : pat;
eq_rhs : exp;
eq_loc : location }
type var_dec =
{ v_ident : ident;
v_type : ty;
v_clock : ck }
type var_dec = {
v_ident : var_ident;
v_type : ty;
v_clock : ck;
v_loc : location }
type contract =
{ c_assume : exp;
c_enforce : exp;
c_controllables : var_dec list;
c_local : var_dec list;
c_eq : eq list;
}
type contract = {
c_assume : exp;
c_enforce : exp;
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_params : param list;
n_params_constraints : size_constraint list;
n_params_instances : (int list) list; }(*TODO commenter ou passer en env*)
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; }
type node_dec = {
n_name : qualname;
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_params : param list;
n_params_constraints : size_constraint list }
type const_dec = {
c_name : qualname;
c_type : ty;
c_value : static_exp;
c_loc : location }
type program = {
p_modname : name;
p_format_version : string;
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 mk_exp ?(exp_ty = Tprod []) ?(clock = Cbase) ?(loc = no_location) desc =
let mk_exp ?(exp_ty = invalid_type) ?(clock = Cbase) ?(loc = no_location) desc =
{ e_desc = desc; e_ty = exp_ty; e_ck = clock; e_loc = loc }
let mk_var_dec ?(clock = Cbase) ident ty =
{ v_ident = ident; v_type = ty;
v_clock = clock }
let mk_var_dec ?(loc = no_location) ?(clock = Cbase) ident ty =
{ v_ident = ident; v_type = ty; v_clock = clock; v_loc = loc }
let mk_equation ?(loc = no_location) pat exp =
{ eq_lhs = pat; eq_rhs = exp; eq_loc = loc }
@ -164,14 +149,21 @@ let mk_node
n_equs = eq;
n_loc = loc;
n_params = param;
n_params_constraints = constraints;
n_params_instances = pinst; }
n_params_constraints = constraints }
let mk_type_dec ?(type_desc = Type_abs) ?(loc = no_location) name =
let mk_type_dec type_desc name loc =
{ t_name = name; t_desc = type_desc; t_loc = loc }
let mk_op ?(op_params = []) ?(op_kind = Enode) lname =
{ op_name = lname; op_params = op_params; op_kind = op_kind }
let mk_const_dec id ty e loc =
{ c_name = id; c_type = ty; c_value = e; c_loc = loc }
let void = mk_exp (Etuple [])
let mk_app ?(params=[]) ?(unsafe=false) op =
{ a_op = op; a_params = params; a_unsafe = unsafe }
(** The modname field has to be set when known, TODO LG : format_version *)
let mk_program o n t c =
{ p_modname = ""; p_format_version = "";
p_opened = o; p_nodes = n; p_types = t; p_consts = c }
let void = mk_exp (Eapp (mk_app Etuple, [], None))

191
compiler/minils/mls_mapfold.ml Normal file
View file

@ -0,0 +1,191 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Generic mapred over Minils Ast *)
open Misc
open Global_mapfold
open Minils
(* /!\ do never, never put in your funs record one
of the generic iterator function (_it),
either yours either the default version named according to the type. *)
type 'a mls_it_funs = {
app: 'a mls_it_funs -> 'a -> Minils.app -> Minils.app * 'a;
edesc: 'a mls_it_funs -> 'a -> Minils.edesc -> Minils.edesc * 'a;
eq: 'a mls_it_funs -> 'a -> Minils.eq -> Minils.eq * 'a;
eqs: 'a mls_it_funs -> 'a -> Minils.eq list -> Minils.eq list * 'a;
exp: 'a mls_it_funs -> 'a -> Minils.exp -> Minils.exp * 'a;
pat: 'a mls_it_funs -> 'a -> Minils.pat -> Minils.pat * 'a;
var_dec: 'a mls_it_funs -> 'a -> Minils.var_dec -> Minils.var_dec * 'a;
var_decs: 'a mls_it_funs -> 'a -> Minils.var_dec list
-> Minils.var_dec list * 'a;
contract: 'a mls_it_funs -> 'a -> Minils.contract -> Minils.contract * 'a;
node_dec: 'a mls_it_funs -> 'a -> Minils.node_dec -> Minils.node_dec * 'a;
const_dec: 'a mls_it_funs -> 'a -> Minils.const_dec -> Minils.const_dec * 'a;
type_dec: 'a mls_it_funs -> 'a -> Minils.type_dec -> Minils.type_dec * 'a;
tdesc: 'a mls_it_funs -> 'a -> Minils.tdesc -> Minils.tdesc * 'a;
program: 'a mls_it_funs -> 'a -> Minils.program -> Minils.program * 'a;
global_funs:'a Global_mapfold.global_it_funs }
let rec exp_it funs acc e = funs.exp funs acc e
and exp funs acc e =
let e_ty, acc = ty_it funs.global_funs acc e.e_ty in
let ed, acc = edesc_it funs acc e.e_desc in
{ e with e_desc = ed; e_ty = e_ty }, acc
and edesc_it funs acc ed =
try funs.edesc funs acc ed
with Fallback -> edesc funs acc ed
and edesc funs acc ed = match ed with
| Econst se ->
let se, acc = static_exp_it funs.global_funs acc se in
Econst se, acc
| Evar x -> ed, acc
| Efby (se, e) ->
let se, acc = optional_wacc (static_exp_it funs.global_funs) acc se in
let e, acc = exp_it funs acc e in
Efby (se, e), acc
| Eapp(app, args, reset) ->
let app, acc = app_it funs acc app in
let args, acc = mapfold (exp_it funs) acc args in
Eapp (app, args, reset), acc
| Ewhen(e, c, x) ->
let e, acc = exp_it funs acc e in
Ewhen(e, c, x), acc
| Emerge(x, c_e_list) ->
let aux acc (c,e) =
let e, acc = exp_it funs acc e in
(c,e), acc in
let c_e_list, acc = mapfold aux acc c_e_list in
Emerge(x, c_e_list), acc
| Estruct n_e_list ->
let aux acc (n,e) =
let e, acc = exp_it funs acc e in
(n,e), acc in
let n_e_list, acc = mapfold aux acc n_e_list in
Estruct n_e_list, acc
| Eiterator (i, app, param, args, reset) ->
let app, acc = app_it funs acc app in
let param, acc = static_exp_it funs.global_funs acc param in
let args, acc = mapfold (exp_it funs) acc args in
Eiterator (i, app, param, args, reset), acc
and app_it funs acc a = funs.app funs acc a
and app funs acc a =
let p, acc = mapfold (static_exp_it funs.global_funs) acc a.a_params in
{ a with a_params = p }, acc
and pat_it funs acc p =
try funs.pat funs acc p
with Fallback -> pat funs acc p
and pat funs acc p = match p with
| Etuplepat pl ->
let pl, acc = mapfold (pat_it funs) acc pl in
Etuplepat pl, acc
| Evarpat _ -> p, acc
and eq_it funs acc eq = funs.eq funs acc eq
and eq funs acc eq =
let eq_lhs, acc = pat_it funs acc eq.eq_lhs in
let eq_rhs, acc = exp_it funs acc eq.eq_rhs in
{ eq with eq_lhs = eq_lhs; eq_rhs = eq_rhs }, acc
and eqs_it funs acc eqs = funs.eqs funs acc eqs
and eqs funs acc eqs = mapfold (eq_it funs) acc eqs
and var_dec_it funs acc vd = funs.var_dec funs acc vd
and var_dec funs acc vd =
let v_type, acc = ty_it funs.global_funs acc vd.v_type in
{ vd with v_type = v_type }, acc
and var_decs_it funs acc vds = funs.var_decs funs acc vds
and var_decs funs acc vds = mapfold (var_dec_it funs) acc vds
and contract_it funs acc c = funs.contract funs acc c
and contract funs acc c =
let c_assume, acc = exp_it funs acc c.c_assume in
let c_enforce, acc = exp_it funs acc c.c_enforce in
let c_local, acc = var_decs_it funs acc c.c_local in
let c_eq, acc = eqs_it funs acc c.c_eq in
{ c with
c_assume = c_assume; c_enforce = c_enforce; c_local = c_local; c_eq = c_eq }
, acc
and node_dec_it funs acc nd = funs.node_dec funs acc nd
and node_dec funs acc nd =
let n_input, acc = var_decs_it funs acc nd.n_input in
let n_output, acc = var_decs_it funs acc nd.n_output in
let n_local, acc = var_decs_it funs acc nd.n_local in
let n_params, acc = mapfold (param_it funs.global_funs) acc nd.n_params in
let n_contract, acc = optional_wacc (contract_it funs) acc nd.n_contract in
let n_equs, acc = eqs_it funs acc nd.n_equs in
{ nd with
n_input = n_input; n_output = n_output;
n_local = n_local; n_params = n_params;
n_contract = n_contract; n_equs = n_equs }
, acc
and const_dec_it funs acc c = funs.const_dec funs acc c
and const_dec funs acc c =
let ty, acc = ty_it funs.global_funs acc c.c_type in
let se, acc = static_exp_it funs.global_funs acc c.c_value in
{ c with c_type = ty; c_value = se }, acc
and type_dec_it funs acc t = funs.type_dec funs acc t
and type_dec funs acc t =
let tdesc, acc = tdesc_it funs acc t.t_desc in
{ t with t_desc = tdesc }, acc
and tdesc_it funs acc td =
try funs.tdesc funs acc td
with Fallback -> tdesc funs acc td
and tdesc funs acc td = match td with
| Type_struct s ->
let s, acc = structure_it funs.global_funs acc s in
Type_struct s, acc
| Type_alias ty ->
let ty, acc = ty_it funs.global_funs acc ty in
Type_alias ty, acc
| Type_abs | Type_enum _ -> td, acc
and program_it funs acc p = funs.program funs acc p
and program funs acc p =
let cd_list, acc = mapfold (const_dec_it funs) acc p.p_consts in
let td_list, acc = mapfold (type_dec_it funs) acc p.p_types in
let nd_list, acc = mapfold (node_dec_it funs) acc p.p_nodes in
{ p with p_types = td_list; p_consts = cd_list; p_nodes = nd_list }, acc
let defaults = {
app = app;
edesc = edesc;
eq = eq;
eqs = eqs;
exp = exp;
pat = pat;
var_dec = var_dec;
var_decs = var_decs;
contract = contract;
node_dec = node_dec;
const_dec = const_dec;
type_dec = type_dec;
tdesc = tdesc;
program = program;
global_funs = Global_mapfold.defaults }

210
compiler/minils/mls_printer.ml
View file

@ -1,42 +1,43 @@
open Minils
open Names
open Ident
open Idents
open Types
open Clocks
open Static
open Format
open Signature
open Global_printer
open Pp_tools
open Minils
(** Every print_ function is boxed, that is it doesn't export break points,
Exceptions are print_list* print_type_desc *)
Exceptions are [list] class functions *)
(** Every print_ function is without heading white space,
except for print_type_desc *)
(** Every print_ function is without heading carry return *)
(** Every print_ function is without heading carry return or white space *)
let iterator_to_string i =
match i with
| Imap -> "map"
| Ifold -> "fold"
| Ifoldi -> "foldi"
| Imapfold -> "mapfold"
let rec print_pat ff = function
| Evarpat n -> print_ident ff n
| Etuplepat pat_list ->
fprintf ff "@[<2>%a@]" (print_list_r print_pat "("","")") pat_list
fprintf ff "@[<2>(%a)@]" (print_list_r print_pat """,""") pat_list
let rec print_ck ff = function
| Cbase -> fprintf ff "base"
| Con (ck, c, n) ->
fprintf ff "%a on %a(%a)" print_ck ck print_longname c print_ident n
fprintf ff "%a on %a(%a)" print_ck ck print_qualname c print_ident n
| 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 "@[<2>%a@]" (print_list_r print_clock "("" *"")") ct_list
fprintf ff "@[<2>(%a)@]" (print_list_r print_clock """ *""") ct_list
let print_vd ff { v_ident = n; v_type = ty; v_clock = ck } =
if !Misc.full_type_info then
@ -47,152 +48,142 @@ let print_local_vars ff = function
| [] -> ()
| l -> fprintf ff "@[<4>%a@]@\n" (print_list_r print_vd "var "";"";") l
let rec print_c ff = function
| Cint i -> fprintf ff "%d" i
| Cfloat f -> fprintf ff "%f" f
| Cconstr tag -> print_longname ff tag
| Carray (n, c) -> fprintf ff "%a^%a" print_c c print_size_exp n
let print_const_dec ff c =
if !Misc.full_type_info then
fprintf ff "const %a : %a = %a"
print_qualname c.c_name print_type c.c_type print_static_exp c.c_value
else
fprintf ff "const %a = %a"
print_qualname c.c_name print_static_exp c.c_value;
fprintf ff "@."
let rec print_params ff l =
fprintf ff "@[<2>%a@]" (print_list_r print_size_exp "<<"","">>") l
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "<<"","">>") l
and print_node_params ff l =
fprintf ff "@[<2>%a@]" (print_list_r print_param "<<"","">>") l
and print_exp_tuple ff l =
fprintf ff "@[<2>%a@]" (print_list_r print_exp "("","")") l
fprintf ff "@[<2>(%a)@]" (print_list_r print_exp """,""") l
and print_vd_tuple ff l =
fprintf ff "@[<2>%a@]" (print_list_r print_vd "("","")") l
fprintf ff "@[<2>%a@]" (print_list_r print_vd "("";"")") l
and print_index ff idx =
fprintf ff "@[<2>%a@]" (print_list print_size_exp "[""][""]") idx
fprintf ff "@[<2>%a@]" (print_list print_static_exp "[""][""]") idx
and print_dyn_index ff idx =
fprintf ff "@[<2>%a@]" (print_list print_exp "[""][""]") idx
and print_op ff op =
fprintf ff "%a%a" print_longname op.op_name print_params op.op_params
and print_exp ff e =
if !Misc.full_type_info then
fprintf ff "%a : %a" print_exp_desc e.e_desc print_type e.e_ty
fprintf ff "(%a : %a :: %a)"
print_exp_desc e.e_desc print_type e.e_ty print_ck e.e_ck
else fprintf ff "%a" print_exp_desc e.e_desc
and print_every ff reset =
print_opt (fun ff id -> fprintf ff " every %a" print_ident id) ff reset
and print_exp_desc ff = function
| Econst c -> print_static_exp ff c
| Evar x -> print_ident ff x
| Econstvar x -> print_name ff x
| Econst c -> print_c ff c
| Efby ((Some c), e) -> fprintf ff "@[<2>%a fby@ %a@]" print_c c print_exp e
| Efby ((Some c), e) ->
fprintf ff "@[<2>%a fby@ %a@]" print_static_exp c print_exp e
| Efby (None, e) -> fprintf ff "pre %a" print_exp e
| Ecall (op, args, reset) ->
fprintf ff "@[<2>%a@,%a%a@]"
print_op op print_exp_tuple args print_every reset
| Eapp (app, args, reset) ->
fprintf ff "@[<2>%a@,%a@]"
print_app (app, args) print_every reset
| Ewhen (e, c, n) ->
fprintf ff "@[<2>(%a@ when %a(%a))@]"
print_exp e print_longname c print_ident n
| Eifthenelse (e1, e2, e3) ->
fprintf ff "@[<hv>if %a@ then %a@ else %a@]"
print_exp e1 print_exp e2 print_exp e3
print_exp e print_qualname c print_ident n
| Emerge (x, tag_e_list) ->
fprintf ff "@[<2>merge %a@ %a@]"
print_ident x print_tag_e_list tag_e_list
| Etuple e_list ->
print_exp_tuple ff e_list
| Efield (e, field) ->
fprintf ff "%a.%a" print_exp e print_longname field
| Efield_update (f, e1, e2) ->
fprintf ff "@[<2>{%a with .%a =@ %a}@]"
print_exp e1 print_longname f print_exp e2
| Estruct f_e_list ->
print_record (print_couple print_longname print_exp """ = """) ff f_e_list
| Earray e_list ->
fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") e_list
| Earray_op(array_op) -> print_array_op ff array_op
and print_array_op ff = function
| Erepeat (n, e) -> fprintf ff "%a^%a" print_exp e print_size_exp n
| Eselect (idx, e) -> fprintf ff "%a%a" print_exp e print_index idx
| Eselect_dyn (idx, e1, e2) ->
fprintf ff "%a%a default %a"
print_exp e1 print_dyn_index idx print_exp e2
| Eupdate (idx, e1, e2) ->
fprintf ff "@[<2>(%a with %a =@ %a)@]"
print_exp e1 print_index idx print_exp e2
| Eselect_slice (idx1, idx2, e) ->
fprintf ff "%a[%a..%a]"
print_exp e print_size_exp idx1 print_size_exp idx2
| Econcat (e1, e2) -> fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2
| Eiterator (it, f, n, e_list, r) ->
print_record (print_couple print_qualname print_exp """ = """) ff f_e_list
| Eiterator (it, f, param, args, reset) ->
fprintf ff "@[<2>(%s (%a)<<%a>>)@,%a@]%a"
(iterator_to_string it)
print_op f
print_size_exp n
print_exp_tuple e_list
print_every r
print_app (f, [])
print_static_exp param
print_exp_tuple args
print_every reset
and print_app ff (app, args) = match app.a_op, app.a_params, args with
| Eequal, _, [e1; e2] ->
fprintf ff "@[<2>%a@ = %a@]" print_exp e1 print_exp e2
| Etuple, _, a -> print_exp_tuple ff a
| (Efun(f)|Enode(f)), p, a ->
fprintf ff "@[%a@,%a@,%a@]"
print_qualname f print_params p print_exp_tuple a
| Eifthenelse, _, [e1; e2; e3] ->
fprintf ff "@[<hv>if %a@ then %a@ else %a@]"
print_exp e1 print_exp e2 print_exp e3
| Efield, [f], [r] -> fprintf ff "%a.%a" print_exp r print_static_exp f
| Efield_update, [f], [r; e] ->
fprintf ff "@[<2>{%a with .%a =@ %a}@]"
print_exp r print_static_exp f print_exp e
| Earray, _, a -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") a
| Earray_fill, [n], [e] -> fprintf ff "%a^%a" print_exp e print_static_exp n
| Eselect, idx, [e] -> fprintf ff "%a%a" print_exp e print_index idx
| Eselect_slice, [idx1; idx2], [e] ->
fprintf ff "%a[%a..%a]"
print_exp e print_static_exp idx1 print_static_exp idx2
| Eselect_dyn, _, r::d::e ->
fprintf ff "%a%a default %a"
print_exp r print_dyn_index e print_exp d
| Eupdate, _, e1::e2::idx ->
fprintf ff "@[<2>(%a with %a =@ %a)@]"
print_exp e1 print_dyn_index idx print_exp e2
| Econcat, _,[e1; e2] ->
fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2
and print_handler ff c =
fprintf ff "@[<2>%a@]" (print_couple print_longname print_exp "("" -> "")") c
fprintf ff "@[<2>%a@]" (print_couple print_qualname print_exp "("" -> "")") c
and print_tag_e_list ff tag_e_list =
fprintf ff "@[%a@]"
(print_list print_handler """""") tag_e_list
fprintf ff "@[%a@]" (print_list print_handler """""") tag_e_list
let print_eq ff { eq_lhs = p; eq_rhs = e } =
and print_eq ff { eq_lhs = p; eq_rhs = e } =
if !Misc.full_type_info
then fprintf ff "@[<2>%a :: %a =@ %a@]"
print_pat p print_ck e.e_ck print_exp e
else fprintf ff "@[<2>%a =@ %a@]" print_pat p print_exp e
let print_eqs ff = function
and print_eqs ff = function
| [] -> ()
| l -> fprintf ff "@[<v2>let@ %a@]@\ntel" (print_list_r print_eq """;""") l
let print_open_module ff name = fprintf ff "open %a@." print_name name
let rec print_type_def ff { t_name = name; t_desc = tdesc } =
fprintf ff "@[<2>type %s%a@]@." name print_type_desc tdesc
let rec print_type_dec ff { t_name = name; t_desc = tdesc } =
let print_type_desc ff = function
| Type_abs -> ()
| Type_alias ty -> fprintf ff " =@ %a" print_type ty
| Type_enum tag_name_list ->
fprintf ff " =@ %a" (print_list print_qualname """|""") tag_name_list
| Type_struct f_ty_list ->
fprintf ff " =@ %a" (print_record print_field) f_ty_list in
fprintf ff "@[<2>type %a%a@]@." print_qualname name print_type_desc tdesc
(** Small exception to the rule,
adding a heading space itself when needed and exporting a break*)
and print_type_desc ff = function
| Type_abs -> () (* that's the reason of the exception *)
| Type_enum tag_name_list ->
fprintf ff " =@ %a" (print_list print_name """|""") tag_name_list
| Type_struct f_ty_list ->
fprintf ff " =@ %a"
(print_record print_field) f_ty_list
and print_field ff field =
fprintf ff "@[%a: %a@]" print_name field.f_name print_type field.f_type
let print_const_dec ff c =
fprintf ff "const %a = %a" print_name c.c_name
print_size_exp c.c_value
let print_contract ff
{ c_local = l; c_eq = eqs;
c_assume = e_a; c_enforce = e_g; c_controllables = cl } =
fprintf ff "@[<v2>contract@\n%a%a@ assume %a;@ enforce %a@ with %a@]"
let print_contract ff { c_local = l; c_eq = eqs;
c_assume = e_a; c_enforce = e_g; } =
fprintf ff "@[<v2>contract@\n%a%a@ assume %a;@ enforce %a@]"
print_local_vars l
print_eqs eqs
print_exp e_a
print_exp e_g
print_vd_tuple cl
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%a%a@ returns %a@]@\n%a%a%a@]@\n@."
n
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 %a%a%a@ returns %a@]@\n%a%a%a@]@\n@."
print_qualname n
print_node_params params
print_vd_tuple ni
print_vd_tuple no
@ -201,21 +192,10 @@ let print_node ff
print_eqs ne
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; p_consts = pc } =
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_const_dec ff) pc;
List.iter (print_node ff) pn;
fprintf ff "@?" )
let ff = formatter_of_out_channel oc in
List.iter (print_open_module ff) pm;
List.iter (print_const_dec ff) pc;
List.iter (print_type_dec ff) pt;
List.iter (print_node ff) pn;
fprintf ff "@?"

147
compiler/minils/mls_utils.ml
View file

@ -1,41 +1,39 @@
open Minils
open Mls_mapfold
open Mls_printer
open Location
open Names
open Ident
open Idents
open Signature
open Static
open Types
open Clocks
open Misc
(** Error Kind *)
type err_kind = | Enot_size_exp
type err_kind = | Enot_static_exp
let err_message ?(exp=void) ?(loc=exp.e_loc) = function
| Enot_size_exp ->
Printf.eprintf "The expression %a should be a size_exp.@."
| Enot_static_exp ->
Format.eprintf "The expression %a should be a static_exp.@."
print_exp exp;
raise Error
let rec size_exp_of_exp e =
let rec static_exp_of_exp e =
match e.e_desc with
| Econstvar n -> Svar n
| Econst (Cint i) -> Sconst i
| Ecall(op, [e1;e2], _) ->
let sop = op_from_app_name op.op_name in
Sop(sop, size_exp_of_exp e1, size_exp_of_exp e2)
| _ -> err_message ~exp:e Enot_size_exp
| Econst se -> se
| _ -> err_message ~exp:e Enot_static_exp
(** @return the list of bounds of an array type*)
let rec bounds_list ty =
match ty with
match Modules.unalias_type ty with
| Tarray(ty, n) -> n::(bounds_list ty)
| _ -> []
(** @return 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
| [] -> Format.eprintf "Not found var %s@." (name n); raise Not_found
| vd::l ->
if vd.v_ident = n then vd else vd_find n l
@ -48,19 +46,24 @@ let rec vd_mem n = function
(** @return 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)
(match Modules.find_type n with
| Tstruct _ -> true
| _ -> false)
| _ -> false
let is_op = function
| Modname { qual = "Pervasives"; id = _ } -> true | _ -> false
| { qual = "Pervasives"; name = _ } -> true | _ -> false
let exp_list_of_static_exp_list se_list =
let mk_one_const se =
Minils.mk_exp ~exp_ty:se.se_ty (Minils.Econst se)
in
List.map mk_one_const se_list
module Vars =
struct
let add x acc =
if List.mem x acc then acc else x :: acc
let add x acc = if List.mem x acc then acc else x :: acc
let rec vars_pat acc = function
| Evarpat x -> x :: acc
@ -71,54 +74,30 @@ struct
| Cbase | Cvar { contents = Cindex _ } -> acc
| Cvar { contents = Clink ck } -> vars_ck acc ck
let rec read is_left acc e =
let acc =
match e.e_desc with
| Evar n -> add n acc
| 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
| Etuple(e_list) -> List.fold_left (read is_left) acc e_list
| Ecall(_, e_list, None) ->
List.fold_left (read is_left) acc e_list
| Ecall(_, e_list, Some 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
| 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
| Efield_update (_, e1, e2) ->
read is_left (read is_left acc e1) e2
(*Array operators*)
| Earray e_list -> List.fold_left (read is_left) acc e_list
| Earray_op op -> read_array_op is_left acc op
let read_exp read_funs (is_left, acc_init) e =
(* recursive call *)
let _,(_, acc) = Mls_mapfold.exp read_funs (is_left, acc_init) e in
(* special cases *)
let acc = match e.e_desc with
| Evar x | Emerge(x,_) | Ewhen(_, _, x)
| Eapp(_, _, Some x) | Eiterator (_, _, _, _, Some x) ->
add x acc
| Efby(_, e) ->
if is_left then
(* do not consider variables to the right
of the fby, only clocks*)
vars_ck acc_init e.e_ck
else acc
| _ -> acc
in
vars_ck acc e.e_ck
e, (is_left, vars_ck acc e.e_ck)
and read_array_op is_left acc = function
| 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) ->
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, None) ->
List.fold_left (read is_left) acc e_list
| Eiterator (_, _, _, e_list, Some x) ->
let acc = add x acc in
List.fold_left (read is_left) acc e_list
let read_exp is_left acc e =
let _, (_, acc) =
Mls_mapfold.exp_it
{ Mls_mapfold.defaults with Mls_mapfold.exp = read_exp }
(is_left, acc) e in
acc
let rec remove x = function
| [] -> []
@ -126,21 +105,19 @@ struct
let def acc { eq_lhs = pat } = vars_pat acc pat
let read is_left { eq_lhs = pat; eq_rhs = e } =
match pat, e.e_desc with
| Evarpat(n), Efby(_, e1) ->
if is_left
then remove n (read is_left [] e1)
else read is_left [] e1
| _ -> read is_left [] e
let read is_left { eq_lhs = pat; eq_rhs = e } = match pat, e.e_desc with
| Evarpat(n), Efby(_, e1) ->
if is_left
then remove n (read_exp is_left [] e1)
else read_exp is_left [] e1
| _ -> read_exp is_left [] e
let antidep { eq_rhs = e } =
match e.e_desc with Efby _ -> true | _ -> false
let clock { eq_rhs = e } =
match e.e_desc with
| Emerge(_, (_, e) :: _) -> e.e_ck
| _ -> e.e_ck
let clock { eq_rhs = e } = match e.e_desc with
| Emerge(_, (_, e) :: _) -> e.e_ck
| _ -> e.e_ck
let head ck =
let rec headrec ck l =
@ -153,12 +130,20 @@ struct
(** Returns a list of memory vars (x in x = v fby e)
appearing in an equation. *)
let memory_vars ({ eq_lhs = _; eq_rhs = e } as eq) =
match e.e_desc with
| Efby(_, _) -> def [] eq
| _ -> []
let memory_vars ({ eq_lhs = _; eq_rhs = e } as eq) = match e.e_desc with
| Efby(_, _) -> def [] eq
| _ -> []
end
let node_memory_vars n =
let eq funs acc ({ eq_lhs = pat; eq_rhs = e } as eq) =
match e.e_desc with
| Efby(_, _) -> eq, Vars.vars_pat acc pat
| _ -> eq, acc
in
let funs = { Mls_mapfold.defaults with eq = eq } in
let _, acc = node_dec_it funs [] n in
acc
(* data-flow dependences. pre-dependences are discarded *)
module DataFlowDep = Dep.Make

125
compiler/minils/parsing/mls_lexer.mll
View file

@ -2,6 +2,7 @@
{
open Location
open Lexing
open Mls_parser
@ -11,7 +12,7 @@ type lexical_error =
| Bad_char_constant
| Unterminated_string;;
exception Lexical_error of lexical_error * int * int;;
exception Lexical_error of lexical_error * location;;
let comment_depth = ref 0
@ -34,6 +35,7 @@ List.iter (fun (str,tok) -> Hashtbl.add keyword_table str tok) [
"not", NOT;
"open", OPEN;
"reset", RESET;
"const", CONST;
"if", IF;
"then", THEN;
"else", ELSE;
@ -49,7 +51,8 @@ List.iter (fun (str,tok) -> Hashtbl.add keyword_table str tok) [
"lxor", INFIX2("lxor");
"lsl", INFIX4("lsl");
"lsr", INFIX4("lsr");
"asr", INFIX4("asr")
"asr", INFIX4("asr");
"on", ON;
]
@ -102,36 +105,40 @@ let char_for_decimal_code lexbuf i =
(int_of_char(Lexing.lexeme_char lexbuf (i+2)) - 48) in
char_of_int(c land 0xFF)
}
let newline = '\n' | '\r' '\n'
rule token = parse
| [' ' '\010' '\013' '\009' '\012'] + { token lexbuf }
| "." {DOT}
| ".." {DOTDOT}
| "(" {LPAREN}
| ")" {RPAREN}
| newline { new_line lexbuf; token lexbuf }
| [' ' '\t'] + { token lexbuf }
| "." { DOT }
| ".." { DOTDOT }
| "(" { LPAREN }
| ")" { RPAREN }
| "*" { STAR }
| "{" {LBRACE}
| "}" {RBRACE}
| "[" {LBRACKET}
| "]" {RBRACKET}
| ":" {COLON}
| ";" {SEMICOL}
| "=" {EQUAL}
| "==" {EQUALEQUAL}
| "&" {AMPERSAND}
| "&&" {AMPERAMPER}
| "||" {BARBAR}
| "," {COMMA}
| "->" {ARROW}
| "|" {BAR}
| "-" {SUBTRACTIVE "-"}
| "-." {SUBTRACTIVE "-."}
| "^" {POWER}
| "@" {AROBASE}
| "<<" {DOUBLE_LESS}
| ">>" {DOUBLE_GREATER}
| "{" { LBRACE }
| "}" { RBRACE }
| "[" { LBRACKET }
| "]" { RBRACKET }
| ":" { COLON }
| "::" { COLONCOLON }
| ";" { SEMICOL }
| "=" { EQUAL }
| "==" { EQUALEQUAL }
| "&" { AMPERSAND }
| "&&" { AMPERAMPER }
| "||" { BARBAR }
| "," { COMMA }
| "->" { ARROW }
| "|" { BAR }
| "-" { SUBTRACTIVE "-" }
| "-." { SUBTRACTIVE "-." }
| "_" { UNDERSCORE }
| "^" { POWER }
| "@" { AROBASE }
| "<<" { 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)
@ -145,26 +152,25 @@ rule token = parse
{ INT (int_of_string(Lexing.lexeme lexbuf)) }
| '-'? ['0'-'9']+ ('.' ['0'-'9']*)? (['e' 'E'] ['+' '-']? ['0'-'9']+)?
{ FLOAT (float_of_string(Lexing.lexeme lexbuf)) }
| "(*@ " (['A'-'Z' 'a'-'z']('_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9']) * as id)
(* | "(*@ " (['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 l1 = lexbuf.lex_curr_p in
begin try
pragma lexbuf
with Lexical_error(Unterminated_comment, Loc(_, l2)) ->
raise(Lexical_error(Unterminated_comment, Loc (l1, l2)))
end;
PRAGMA(id,get_stored_string())
}*)
| "(*"
{ let comment_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in
{ let comment_start = lexbuf.lex_curr_p in
comment_depth := 1;
begin try
comment lexbuf
with Lexical_error(Unterminated_comment, _, comment_end) ->
with Lexical_error(Unterminated_comment, (Loc (_, comment_end))) ->
raise(Lexical_error(Unterminated_comment,
comment_start, comment_end))
Loc (comment_start, comment_end)))
end;
token lexbuf }
| ['!' '?' '~']
@ -193,29 +199,30 @@ rule token = parse
{ INFIX3(Lexing.lexeme lexbuf) }
| eof {EOF}
| _ {raise (Lexical_error (Illegal_character,
Lexing.lexeme_start lexbuf,
Lexing.lexeme_end lexbuf))}
Loc (Lexing.lexeme_start_p lexbuf,
Lexing.lexeme_end_p lexbuf)))}
and pragma = parse
"(*"
{ let comment_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in
| newline { new_line lexbuf; pragma lexbuf }
| "(*"
{ let comment_start = lexbuf.lex_curr_p in
comment_depth := 1;
begin try
comment lexbuf
with Lexical_error(Unterminated_comment, _, comment_end) ->
with Lexical_error(Unterminated_comment, Loc (_, comment_end)) ->
raise(Lexical_error(Unterminated_comment,
comment_start, comment_end))
Loc (comment_start, comment_end)))
end;
pragma lexbuf }
| "@*)"
{ }
| eof
{ raise(Lexical_error(Unterminated_comment,0,
Lexing.lexeme_start lexbuf)) }
{ raise(Lexical_error(Unterminated_comment, Loc (dummy_pos,
Lexing.lexeme_start_p lexbuf))) }
| _
{ store_string_char(Lexing.lexeme_char lexbuf 0);
pragma lexbuf }
pragma lexbuf }
and comment = parse
"(*"
@ -223,13 +230,14 @@ and comment = parse
| "*)"
{ 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
let string_start = lexbuf.lex_curr_p in
begin try
string lexbuf
with Lexical_error(Unterminated_string, _, string_end) ->
raise(Lexical_error(Unterminated_string, string_start, string_end))
with Lexical_error(Unterminated_string, Loc (_, string_end)) ->
raise(Lexical_error
(Unterminated_string, Loc (string_start, string_end)))
end;
comment lexbuf }
| "''"
@ -241,8 +249,8 @@ and comment = parse
| "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
{ comment lexbuf }
| eof
{ raise(Lexical_error(Unterminated_comment,0,
Lexing.lexeme_start lexbuf)) }
{ raise(Lexical_error(Unterminated_comment, Loc(dummy_pos,
Lexing.lexeme_start_p lexbuf))) }
| _
{ comment lexbuf }
@ -258,10 +266,11 @@ and string = parse
{ store_string_char(char_for_decimal_code lexbuf 1);
string lexbuf }
| eof
{ raise (Lexical_error
(Unterminated_string, 0, Lexing.lexeme_start lexbuf)) }
{ raise (Lexical_error(Unterminated_string, Loc (dummy_pos,
Lexing.lexeme_start_p lexbuf))) }
| _
{ store_string_char(Lexing.lexeme_char lexbuf 0);
string lexbuf }
(* eof *)

203
compiler/minils/parsing/mls_parser.mly
View file

@ -2,29 +2,24 @@
open Signature
open Names
open Ident
open Idents
open Types
open Clocks
open Location
open Minils
open Mls_parsetree
open Mls_utils
let mk_exp = mk_exp ~loc:(current_loc())
let mk_node = mk_node ~loc:(current_loc())
let mk_equation p e = mk_equation ~loc:(current_loc()) p e
let mk_type name desc = mk_type_dec ~loc:(current_loc()) ~type_desc: desc name
let mk_var name ty = mk_var_dec name ty
%}
%token DOT LPAREN RPAREN LBRACE RBRACE COLON SEMICOL
%token EQUAL EQUALEQUAL BARBAR COMMA BAR LET TEL
%token EQUAL EQUALEQUAL BARBAR COMMA BAR LET TEL CONST
%token <string> CONSTRUCTOR
%token <string> NAME
%token <int> INT
%token <float> FLOAT
%token <bool> BOOL
%token <string * string> PRAGMA
%token TYPE NODE RETURNS VAR OPEN
%token FBY PRE WHEN
%token OR STAR NOT
@ -39,6 +34,7 @@ let mk_var name ty = mk_var_dec name ty
%token AROBASE
%token WITH
%token DOTDOT
%token BASE UNDERSCORE ON COLONCOLON
%token DEFAULT
%token LBRACKET RBRACKET
%token MAP FOLD MAPFOLD
@ -52,6 +48,7 @@ let mk_var name ty = mk_var_dec name ty
%token EOF
%right AROBASE
%nonassoc DEFAULT
%left ELSE
%left OR
%left AMPERSAND
@ -67,7 +64,7 @@ let mk_var name ty = mk_var_dec name ty
%start program
%type <Minils.program> program
%type <Mls_parsetree.program> program
%%
@ -80,126 +77,164 @@ let mk_var name ty = mk_var_dec name ty
| P v=x { Some(v) }
qualified(x) :
| n=x { Name(n) }
| m=CONSTRUCTOR DOT n=x { Modname({ qual = m; id = n }) }
| n=x { Modules.qualname n }
| m=CONSTRUCTOR DOT n=x { { qual = m; name = n } }
structure(field): LBRACE s=snlist(SEMICOL,field) RBRACE {s}
localize(x): y=x { y, (Loc($startpos(y),$endpos(y))) }
program:
| pragma_headers open_modules type_decs node_decs EOF /*TODO const decs */
{{ p_pragmas = List.rev $1;
p_opened = List.rev $2;
p_types = $3;
p_nodes = $4;
p_consts = []}} /*TODO consts dans program*/
pragma_headers: l=list(PRAGMA) {l}
| o=open_modules c=const_decs t=type_decs n=node_decs EOF
{ mk_program o n t c }
open_modules: l=list(opens) {l}
opens: OPEN c=CONSTRUCTOR {c}
name: n=NAME | LPAREN n=infix_ RPAREN | LPAREN n=prefix_ RPAREN { n }
ident: n=name { ident_of_name n }
const_decs: c=list(const_dec) {c}
const_dec:
| CONST n=qualname COLON t=type_ident EQUAL e=const
{ mk_const_dec n t e (Loc($startpos,$endpos)) }
field_type : n=NAME COLON t=type_ident { mk_field n t }
name: n=NAME | LPAREN n=infix RPAREN | LPAREN n=prefix RPAREN { n }
qualname: n=name { Modules.qualname n }
type_ident: NAME { Tid(Name($1)) }
field_type : n=qualname COLON t=type_ident { mk_field n t }
type_ident: qualname { Tid($1) }
type_decs: t=list(type_dec) {t}
type_dec:
| TYPE n=NAME { mk_type n Type_abs }
| TYPE n=NAME EQUAL e=snlist(BAR,NAME) { mk_type n (Type_enum e) }
| TYPE n=NAME EQUAL s=structure(field_type) { mk_type n (Type_struct s) }
| TYPE n=qualname
{ mk_type_dec Type_abs n (Loc ($startpos,$endpos)) }
| TYPE n=qualname EQUAL e=snlist(BAR,constructor)
{ mk_type_dec (Type_enum e) n (Loc ($startpos,$endpos)) }
| TYPE n=qualname EQUAL s=structure(field_type)
{ mk_type_dec (Type_struct s) n (Loc ($startpos,$endpos)) }
node_decs: ns=list(node_dec) {ns}
node_dec:
NODE n=name p=params(n_param) LPAREN args=args RPAREN
NODE n=qualname p=params(n_param) LPAREN args=args RPAREN
RETURNS LPAREN out=args RPAREN vars=loc_vars eqs=equs
{ mk_node ~input:args ~output:out ~local:vars ~eq:eqs n }
{ mk_node p args out vars eqs ~loc:(Loc ($startpos,$endpos)) n }
args_t: SEMICOL p=args {p}
args:
| /* empty */ {[]}
| /* empty */ { [] }
| h=var t=loption(args_t) {h@t}
loc_vars_t: SEMICOL h=var t=loc_vars_t {h@t}
loc_vars_t:
| /*empty */ { [] }
| SEMICOL { [] }
| SEMICOL h=var t=loc_vars_t {h@t}
loc_vars_h: VAR h=var t=loc_vars_t {h@t}
loc_vars: l=loption(loc_vars_h) {l}
ck_base: | UNDERSCORE | BASE {}
ck:
| ck_base { Cbase }
| ck=ck ON c=constructor LPAREN x=NAME RPAREN { Con (ck, c, x) }
clock_annot:
| /*empty*/ { Cbase }
| COLONCOLON c=ck { c }
var:
| ns=snlist(COMMA, NAME) COLON t=type_ident
{ List.map (fun id -> mk_var (ident_of_name id) t) ns }
| ns=snlist(COMMA, NAME) COLON t=type_ident c=clock_annot
{ List.map (fun n -> mk_var_dec n t c (Loc ($startpos,$endpos))) ns }
equs: LET e=slist(SEMICOL, equ) TEL { e }
equ: p=pat EQUAL e=exp { mk_equation p e }
equ: p=pat EQUAL e=exp { mk_equation p e (Loc ($startpos,$endpos)) }
pat:
| n=NAME {Evarpat (ident_of_name n)}
| n=NAME {Evarpat n}
| LPAREN p=snlist(COMMA, pat) RPAREN {Etuplepat p}
longname: l=qualified(name) {l} /* qualified var (not a constructor) */
longname: l=qualified(name) {l}
constructor: /* of type longname */
| ln=qualified(CONSTRUCTOR) {ln}
| b=BOOL { Name(if b then "true" else "false") }
| ln=qualified(CONSTRUCTOR) { ln }
| b=BOOL { if b then Initial.ptrue else Initial.pfalse }
const:
| INT { Cint($1) }
| FLOAT { Cfloat($1) }
| constructor { Cconstr($1) }
field:
| c=constructor { mk_constructor_exp c (Loc($startpos,$endpos))}
const: c=_const { mk_static_exp ~loc:(Loc ($startpos,$endpos)) c }
_const:
| i=INT { Sint i }
| f=FLOAT { Sfloat f }
| c=constructor { Sconstructor c }
exps: LPAREN e=slist(COMMA, exp) RPAREN {e}
field_exp: longname EQUAL exp { ($1, $3) }
simple_exp:
| NAME { mk_exp (Evar (ident_of_name $1)) }
| s=structure(field_exp) { mk_exp (Estruct s) }
| t=tuple(exp) { mk_exp (Etuple t) }
| LPAREN e=exp RPAREN { e }
| e=_simple_exp {mk_exp e (Loc ($startpos,$endpos)) }
_simple_exp:
| n=NAME { Evar n }
| s=structure(field_exp) { Estruct s }
| t=tuple(exp_woc) { mk_call [] Etuple t None }
| t=tuple(const)
{Econst (mk_static_exp ~loc:(Loc ($startpos,$endpos)) (Stuple t))}
| LBRACKET es=slist(COMMA, exp) RBRACKET { mk_call [] Earray es None }
| LPAREN e=_exp RPAREN { e }
exp:
| e=simple_exp { e }
| c=const { mk_exp (Econst c) }
| const FBY exp { mk_exp (Efby(Some($1),$3)) }
| PRE exp { mk_exp (Efby(None,$2)) }
| op=funop a=exps r=reset { mk_exp (Ecall(op, a, r)) }
| e1=exp i_op=infix e2=exp
{ mk_exp (Ecall(mk_op ~op_kind:Efun i_op, [e1; e2], None)) }
| p_op=prefix e=exp %prec prefixs
{ mk_exp (Ecall(mk_op ~op_kind:Efun p_op, [e], None)) }
| IF e1=exp THEN e2=exp ELSE e3=exp { mk_exp (Eifthenelse(e1, e2, e3)) }
| e=simple_exp DOT m=longname { mk_exp (Efield(e, m)) }
| e=exp WHEN c=constructor LPAREN n=ident RPAREN
{ mk_exp (Ewhen(e, c, n)) }
| MERGE n=ident h=handlers { mk_exp (Emerge(n, h)) }
| LPAREN r=exp WITH DOT ln=longname EQUAL nv=exp /*ordre louche...*/
{ mk_exp (Efield_update(ln, r, nv)) }
| op=array_op { mk_exp (Earray_op op) }
| LBRACKET es=slist(COMMA, exp) RBRACKET { mk_exp (Earray es) }
| e=simple_exp { e }
| e=_exp { mk_exp e (Loc ($startpos,$endpos)) }
exp_woc:
| e=simple_exp { e }
| e=_exp_woc { mk_exp e (Loc ($startpos,$endpos)) }
array_op:
| e=exp POWER p=e_param { Erepeat(p, e) }
| e=simple_exp i=indexes(e_param) { Eselect(i, e) }
| e=exp i=indexes(exp) DEFAULT d=exp { Eselect_dyn(i, e ,d) }
| LPAREN e=exp WITH i=indexes(e_param) EQUAL nv=exp { Eupdate(i, e, nv) }
_exp:
| e=_exp_woc {e}
| c=const { Econst c }
_exp_woc:
| v=exp FBY e=exp { Efby(Some(v), e) }
| PRE exp { Efby(None,$2) }
| app=funapp a=exps r=reset { Eapp(app, a, r) }
| e1=exp i_op=infix e2=exp
{ mk_op_call i_op [e1; e2] }
| p_op=prefix e=exp %prec prefixs
{ mk_op_call p_op [e] }
| IF e1=exp THEN e2=exp ELSE e3=exp
{ mk_call [] Eifthenelse [e1; e2; e3] None }
| e=simple_exp DOT f=field
{ mk_call [f] Efield [e] None }
| e=exp WHEN c=constructor LPAREN n=name RPAREN { Ewhen(e, c, n) }
| MERGE n=name h=handlers { Emerge(n, h) }
| LPAREN r=exp WITH DOT f=field EQUAL nv=exp
{ mk_call [f] Efield_update [r; nv] None }
| e=exp POWER p=e_param
{ mk_call [p] Earray_fill [e] None }
| e=simple_exp i=indexes(exp) /* not e_params to solve conflicts */
{ mk_call i Eselect [e] None }
| e=simple_exp i=indexes(exp) DEFAULT d=exp
{ mk_call [] Eselect_dyn ([e; d]@i) None }
| LPAREN e=exp WITH i=indexes(e_param) EQUAL nv=exp
{ mk_call i Eupdate [e; nv] None }
| e=simple_exp LBRACKET i1=e_param DOTDOT i2=e_param RBRACKET
{ Eselect_slice(i1, i2, e) }
| e1=exp AROBASE e2=exp { Econcat(e1,e2) }
| LPAREN f=iterator LPAREN op=funop RPAREN
DOUBLE_LESS p=e_param DOUBLE_GREATER /* une seule dimension ? */
RPAREN a=exps r=reset { Eiterator(f,op,p,a,r) }
{ mk_call [i1; i2] Eselect_slice [e] None }
| e1=exp AROBASE e2=exp { mk_call [] Econcat [e1;e2] None }
| LPAREN f=iterator LPAREN op=funapp RPAREN
DOUBLE_LESS p=e_param DOUBLE_GREATER
RPAREN a=exps r=reset { Eiterator(f,op,p,a,r) }
/* Static indexes [p1][p2]... */
indexes(param): is=nonempty_list(index(param)) { is }
indexes(param): is=nonempty_list(index(param)) { is }
index(param): LBRACKET p=param RBRACKET { p }
/* Merge handlers ( B -> e)( C -> ec)... */
/* Merge handlers ( B -> e ) ( C -> ec )... */
handlers: hs=nonempty_list(handler) { hs }
handler: LPAREN c=constructor ARROW e=exp RPAREN { c,e }
@ -209,21 +244,20 @@ iterator:
| FOLD { Ifold }
| MAPFOLD { Imapfold }
reset: r=option(RESET,ident) { r }
reset: r=option(RESET,name) { r }
funop: ln=longname p=params(e_param) { mk_op ~op_kind:Enode ~op_params:p ln }
funapp: ln=longname p=params(e_param) { mk_app p (Enode ln) }
e_param: e=exp { size_exp_of_exp e }
n_param: n=NAME { mk_param n }
/* inline so that precendance of POWER is respected in exp */
%inline e_param: e=exp { e }
n_param: n=NAME COLON ty=type_ident { mk_param n ty }
params(param):
| /*empty*/ { [] }
| DOUBLE_LESS p=slist(COMMA, param) DOUBLE_GREATER { p }
/*Inlining is compulsory in order to preserve priorities*/
%inline infix: op=infix_ { Name(op) }
%inline infix_:
%inline infix:
| op=INFIX0 | op=INFIX1 | op=INFIX2 | op=INFIX3 | op=INFIX4 { op }
| STAR { "*" }
| EQUAL { "=" }
@ -231,8 +265,7 @@ params(param):
| AMPERSAND { "&" } | AMPERAMPER { "&&" }
| OR { "or" } | BARBAR { "||" }
prefix: op=prefix_ { Name(op) }
prefix_:
%inline prefix:
| op = PREFIX { op }
| NOT { "not" }
| op = SUBTRACTIVE { "~" ^ op } /*TODO test 3 * -2 and co */

119
compiler/minils/parsing/mls_parsetree.ml Normal file
View file

@ -0,0 +1,119 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
open Location
open Names
open Signature
open Static
open Types
open Clocks
type var_name = name
type ck =
| Cbase
| Con of ck * constructor_name * var_name
type exp = {
e_desc: edesc;
e_loc: location }
and app = { a_op: Minils.op; a_params: exp list }
and edesc =
| Econst of static_exp
| Evar of var_name
| Efby of exp option * exp
| Eapp of app * exp list * var_name option
| Ewhen of exp * constructor_name * var_name
| Emerge of var_name * (constructor_name * exp) list
| Estruct of (field_name * exp) list
| Eiterator of
Minils.iterator_type * app * exp * exp list * var_name option
and pat =
| Etuplepat of pat list
| Evarpat of var_name
and eq = {
eq_lhs : pat;
eq_rhs : exp;
eq_loc : location }
and var_dec = {
v_name : var_name;
v_type : ty;
v_clock : ck;
v_loc : location }
type node_dec = {
n_name : qualname;
n_input : var_dec list;
n_output : var_dec list;
n_contract : Minils.contract option;
n_local : var_dec list;
n_equs : eq list;
n_loc : location;
n_params : param list }
type program = {
p_modname : name;
p_format_version : string;
p_opened : name list;
p_types : Minils.type_dec list;
p_nodes : node_dec list;
p_consts : Minils.const_dec list }
(** {Helper functions to build the Parsetree *)
let mk_node params input output locals eqs ?(loc = no_location)
?(contract = None) ?(constraints = []) name =
{ n_name = name;
n_input = input;
n_output = output;
n_contract = contract;
n_local = locals;
n_equs = eqs;
n_loc = loc;
n_params = params }
let mk_program o n t c =
{ p_modname = Modules.current.Modules.modname;
p_format_version = "";
p_opened = o;
p_nodes = n;
p_types = t;
p_consts = c }
let mk_exp desc loc = { e_desc = desc; e_loc = loc }
let mk_app params op = { a_op = op; a_params = params }
let void = mk_exp (Eapp (mk_app [] Minils.Etuple, [], None))
let mk_call params op exps reset =
Eapp (mk_app params op, exps, reset)
let mk_op_call ?(params=[]) s exps =
mk_call params (Minils.Efun { qual = "Pervasives"; name = s }) exps None
let mk_iterator_call it ln params reset n exps =
Eiterator (it, mk_app params (Minils.Enode ln), n, exps, reset)
let mk_constructor_exp f loc =
mk_exp (Econst (mk_static_exp (Sconstructor f))) loc
let mk_equation lhs rhs loc =
{ eq_lhs = lhs; eq_rhs = rhs; eq_loc = loc }
let mk_var_dec name ty clock loc =
{ v_name = name; v_type = ty; v_clock = clock; v_loc = loc }

461
compiler/minils/sequential/mls2obc.ml
View file

@ -1,461 +0,0 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Translation from Minils to Obc. *)
open Misc
open Names
open Ident
open Signature
open Obc
open Control
open Static
let gen_obj_name n =
(shortname n) ^ "_mem" ^ (gen_symbol ())
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 op_from_string op = Modname { qual = "Pervasives"; id = op; }
let rec lhs_of_idx_list e = function
| [] -> e | idx :: l -> Array (lhs_of_idx_list e l, idx)
let array_elt_of_exp idx e =
match e with
| Const (Carray (_, c)) ->
Const c
| _ ->
Lhs (Array(lhs_of_exp e, Lhs idx))
(** 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 ]) -> Op (op_from_string "<", [ idx; Const (Cint n) ])
| (idx :: idx_list, n :: bounds) ->
Op (op_from_string "&",
[ Op (op_from_string "<", [ idx; Const (Cint n) ]);
bound_check_expr idx_list bounds ])
| (_, _) -> assert false
let rec translate_type const_env = function
| Types.Tid id when id = Initial.pint -> Tint
| Types.Tid id when id = Initial.pfloat -> Tfloat
| Types.Tid id when id = Initial.pbool -> Tbool
| Types.Tid id -> Tid id
| Types.Tarray (ty, n) ->
Tarray (translate_type const_env ty, int_of_size_exp const_env n)
| Types.Tprod ty -> assert false
let rec translate_const const_env = function
| Minils.Cint v -> Cint v
| Minils.Cfloat v -> Cfloat v
| Minils.Cconstr c -> Cconstr c
| Minils.Carray (n, c) ->
Carray (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.Ecall ({ Minils.op_name = n; Minils.op_kind = Minils.Efun },
e_list, _) when Mls_utils.is_op n ->
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 =
(match e.Minils.e_ty with
| Types.Tid name -> name
| _ -> assert false) 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_lit (type_name, f_e_list)
(*Array operators*)
| Minils.Earray e_list ->
Array_lit (List.map (translate const_env map (m, si, j, s)) e_list)
| Minils.Earray_op (Minils.Eselect (idx, e)) ->
let e = translate const_env map (m, si, j, s) e in
let idx_list =
List.map (fun e -> Const (Cint (int_of_size_exp const_env e))) idx
in
Lhs (lhs_of_idx_list (lhs_of_exp e) idx_list)
| _ -> (*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.eq_lhs = pat; Minils.eq_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 ->
(Assgn (x,
Const (translate_const const_env c))) :: si) in
let ty = translate_type const_env ty in
let m = (n, ty) :: m in
let action = Assgn (var_from_name map n,
translate const_env map (m, si, j, s) e)
in
m, si, j, (control map ck action) :: s
| pat, Minils.Ecall ({ Minils.op_name = n; Minils.op_params = params;
Minils.op_kind = (Minils.Enode
| Minils.Efun) as op_kind },
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_obj_name n in
let si =
(match op_kind with
| Minils.Enode -> (Reinit o) :: si
| Minils.Efun -> 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 action = Step_ap (name_list, Context o, c_list) in
let s = (match r, op_kind with
| Some r, Minils.Enode ->
let ra =
control map (Minils.Con (ck, Name "true", r))
(Reinit o) in
ra :: (control map ck action) :: s
| _, _ -> (control map ck action) :: 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.mk_equation pat e))
p_list act_list (m, si, j, s)
| Minils.Evarpat x, Minils.Efield_update (f, 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 (Field (x, f), 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.Earray_op (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 cpt = Ident.fresh "i" in
let e = translate const_env map (m, si, j, s) e in
let idx =
Op (op_from_string "+", [ Lhs (Var cpt); Const (Cint idx1) ]) in
let action =
For (cpt, 0, (idx2 - idx1) + 1,
Assgn (Array (var_from_name map x, Lhs (Var cpt)),
Lhs (Array (lhs_of_exp e, idx))))
in
m, si, j, (control map ck action) :: s
| Minils.Evarpat x,
Minils.Earray_op (Minils.Eselect_dyn (idx, e1, e2)) ->
let x = var_from_name map x in
let bounds = Mls_utils.bounds_list e1.Minils.e_ty in
let e1 = translate const_env map (m, si, j, s) e1 in
let bounds = List.map (int_of_size_exp const_env) bounds in
let idx = List.map (translate const_env map (m, si, j, s)) idx in
let true_act =
Assgn (x, Lhs (lhs_of_idx_list (lhs_of_exp e1) idx)) in
let false_act =
Assgn (x, translate const_env map (m, si, j, s) e2) in
let cond = bound_check_expr idx bounds in
let action =
Case (cond,
[ ((Name "true"), true_act); ((Name "false"), false_act) ])
in
m, si, j, (control map ck action) :: s
| Minils.Evarpat x,
Minils.Earray_op (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 idx =
List.map (fun se -> Const (Cint (int_of_size_exp const_env se)))
idx in
let action = Assgn (lhs_of_idx_list x 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.Earray_op (Minils.Erepeat (n, e)) ->
let cpt = Ident.fresh "i" in
let action =
For (cpt, 0, int_of_size_exp const_env n,
Assgn (Array (var_from_name map x, Lhs (Var cpt)),
translate const_env map (m, si, j, s) e))
in
m, si, j, (control map ck action) :: s
| Minils.Evarpat x,
Minils.Earray_op (Minils.Econcat (e1, e2)) ->
let cpt1 = Ident.fresh "i" in
let cpt2 = Ident.fresh "i" in
let x = var_from_name map x in
(match e1.Minils.e_ty, e2.Minils.e_ty with
| Types.Tarray (_, n1), Types.Tarray (_, n2) ->
let e1 = translate const_env map (m, si, j, s) e1 in
let e2 = translate const_env map (m, si, j, s) e2 in
let n1 = int_of_size_exp const_env n1 in
let n2 = int_of_size_exp const_env n2 in
let a1 =
For (cpt1, 0, n1,
Assgn (Array (x, Lhs (Var cpt1)),
Lhs (Array (lhs_of_exp e1, Lhs (Var cpt1))))) in
let idx =
Op (op_from_string "+", [ Const (Cint n1); Lhs (Var cpt2) ]) in
let a2 =
For (cpt2, 0, n2,
Assgn (Array (x, idx),
Lhs (Array (lhs_of_exp e2, Lhs (Var cpt2)))))
in
m, si, j, (control map ck a1) :: (control map ck a2) :: s
| _ -> assert false )
| pat, Minils.Earray_op (
Minils.Eiterator (it,
{ Minils.op_name = f; Minils.op_params = params;
Minils.op_kind = k },
n, e_list, reset)) ->
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_obj_name f in
let n = int_of_size_exp const_env n in
let si =
(match k with
| Minils.Efun -> si
| Minils.Enode -> (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 x = Ident.fresh "i" in
let action =
translate_iterator const_env map it x name_list 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)
| (pat, _) ->
let action = translate_act const_env map (m, si, j, s) pat e
in (m, si, j, ((control map ck action) :: s))
and translate_iterator const_env map it x name_list o n c_list =
match it with
| Minils.Imap ->
let c_list =
List.map (array_elt_of_exp (Var x)) c_list in
let name_list = List.map (fun l -> Array (l, Lhs (Var x))) name_list in
let objn = Array_context (o, Var x) in
For (x, 0, n, Step_ap (name_list, objn, c_list))
| Minils.Imapfold ->
let (c_list, acc_in) = split_last c_list in
let c_list = List.map (array_elt_of_exp (Var x)) c_list in
let objn = Array_context (o, Var x) in
let (name_list, acc_out) = split_last name_list in
let name_list = List.map (fun l -> Array (l, Lhs (Var x))) name_list in
Comp (Assgn (acc_out, acc_in),
For (x, 0, n,
Step_ap (name_list @ [ acc_out ], objn,
c_list @ [ Lhs acc_out ])))
| Minils.Ifold ->
let (c_list, acc_in) = split_last c_list in
let c_list = List.map (array_elt_of_exp (Var x)) c_list in
let objn = Array_context (o, Var x) in
let acc_out = last_element name_list in
Comp (Assgn (acc_out, acc_in),
For (x, 0, n,
Step_ap (name_list, objn, c_list @ [ Lhs acc_out ])))
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_ident = n } -> not (List.mem_assoc n m)) d_list
let var_decl l =
List.map (fun (x, t) -> mk_var_dec x t) l
let obj_decl l = List.map (fun (x, t, i) -> { obj = x; cls = t; size = i; }) l
let translate_var_dec const_env map l =
let one_var { Minils.v_ident = x; Minils.v_type = t } =
mk_var_dec x (translate_type const_env t)
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)
(** Returns a map, mapping variables names to the variables
where they will be stored. *)
let subst_map inputs outputs locals mems =
(* Create a map that simply maps each var to itself *)
let m =
List.fold_left (fun m { Minils.v_ident = 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
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_params = params
} =
let mem_vars = List.flatten (List.map Mls_utils.Vars.memory_vars eq_list) in
let subst_map = subst_map 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 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 { p_name = 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_name = f; f_type = ty } ->
(f, translate_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);
}

320
compiler/minils/sequential/obc.ml
View file

@ -1,320 +0,0 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Object code internal representation *)
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
| Tbool
| 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
| Carray of int * const
type lhs =
| Var of var_name
| Mem of var_name
| Field of lhs * field_name
| Array of lhs * exp
and exp =
| Lhs of lhs
| Const of const
| Op of op_name * exp list
| Struct_lit of type_name * (field_name * exp) list
| Array_lit of exp list
type obj_call =
| Context of obj_name
| Array_context of obj_name * lhs
type act =
| Assgn of lhs * exp
| Step_ap of lhs list * obj_call * exp list
| Comp of act * act
| Case of exp * (longname * act) list
| For of var_name * int * int * act
| Reinit of obj_name
| Nothing
type var_dec =
{ v_ident : var_name;
v_type : ty; }
type obj_dec =
{ obj : obj_name;
cls : instance_name;
size : 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 }
let mk_var_dec name ty =
{ v_ident = name; v_type = ty }
let rec var_name x =
match x with
| Var x -> x
| Mem x -> x
| Field(x,_) -> var_name x
| Array(l, _) -> var_name 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_ident = 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_ident = n then vd else vd_find n l
let lhs_of_exp = function
| Lhs l -> l
| _ -> assert false
module Printer =
struct
open Format
open Pp_tools
let rec print_type ff = function
| Tint -> fprintf ff "int"
| Tfloat -> fprintf ff "float"
| Tbool -> fprintf ff "bool"
| Tid(id) -> print_longname ff id
| Tarray(ty, n) ->
print_type ff ty;
fprintf ff "^%d" n
let print_vd ff vd =
fprintf ff "@[<v>";
print_ident ff vd.v_ident;
fprintf ff ": ";
print_type ff vd.v_type;
fprintf ff "@]"
let print_obj ff { cls = cls; obj = obj; size = n } =
fprintf ff "@[<v>"; 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
| Carray(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)
| Array(x, idx) ->
print_lhs ff x;
fprintf ff "[";
print_exp ff idx;
fprintf ff "]"
and print_exps ff e_list = print_list_r print_exp "" "," "" ff 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_lit(_,f_e_list) ->
fprintf ff "@[<v 1>";
print_list_r
(fun ff (field, e) -> print_longname ff field;fprintf ff " = ";
print_exp ff e)
"{" ";" "}" ff f_e_list;
fprintf ff "@]"
| Array_lit e_list ->
fprintf ff "@[";
print_list_r print_exp "[" ";" "]" ff e_list;
fprintf ff "@]"
and print_op ff op e_list =
print_longname ff op;
print_list_r print_exp "(" "," ")" ff e_list
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 print_obj_call ff = function
| Context o -> print_name ff o
| Array_context (o, i) ->
fprintf ff "%a[%a]"
print_name o
print_lhs i
let rec print_act ff a =
match a with
| Assgn (x, e) -> print_asgn ff "" x e
| Comp (a1, a2) ->
fprintf ff "@[<v>";
print_act ff a1;
fprintf ff ";@,";
print_act ff a2;
fprintf ff "@]"
| Case(e, tag_act_list) ->
fprintf ff "@[<v>@[<v 2>switch (";
print_exp ff e; fprintf ff ") {@,";
print_tag_act_list ff tag_act_list;
fprintf ff "@]@,}@]"
| For(x, i1, i2, act) ->
fprintf ff "@[<v>@[<v 2>for %s=%d to %d : {@, %a @]@,}@]"
(name x) i1 i2
print_act act
| Step_ap (var_list, o, es) ->
print_list print_lhs "(" "," ")" ff var_list;
fprintf ff " = "; print_obj_call 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 "()"
and print_tag_act_list ff tag_act_list =
print_list
(fun ff (tag, a) ->
fprintf ff "@[<hov 2>case@ ";
print_longname ff tag;
fprintf ff ":@ ";
print_act ff a;
fprintf ff "@]") "" "" "" ff tag_act_list
let print_step ff { inp = inp; out = out; local = nl; bd = bd } =
fprintf ff "@[<v 2>";
fprintf ff "step(@[";
print_list_r print_vd "(" ";" ")" ff inp;
fprintf ff "@]) returns ";
print_list_r print_vd "(" ";" ")" ff out;
fprintf ff "@]){@,";
if nl <> [] then begin
fprintf ff "@[<hov 4>var ";
print_list_r print_vd "" ";" "" ff nl;
fprintf ff ";@]@,"
end;
print_act ff bd;
fprintf ff "}@]"
let print_reset ff act =
fprintf ff "@[<v 2>";
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 "@[<v 2>machine "; print_name ff id; fprintf ff " =@,";
if mem <> [] then begin
fprintf ff "@[<hov 4>var ";
print_list_r print_vd "" ";" "" ff mem;
fprintf ff ";@]@,"
end;
if objs <> [] then begin
fprintf ff "@[<hov 4>obj ";
print_list print_obj "" ";" "" ff 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_r print_name "" "|" "" ff tag_name_list;
fprintf ff "@\n@]"
| Type_struct(f_ty_list) ->
fprintf ff "@[type %s = " name;
fprintf ff "@[<v 1>";
print_list
(fun ff (field, ty) ->
print_name ff field;
fprintf ff ": ";
print_type ff ty) "{" ";" "}" ff 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 "@[<v>"; print_prog ff p; fprintf ff "@]@]@."
end

396
compiler/minils/transformations/callgraph.ml
View file

@ -1,121 +1,309 @@
open Misc
open Minils
open Names
open Ident
open Format
open Types
open Misc
open Location
open Printf
open Static
open Signature
open Modules
open Static
open Global_mapfold
open Mls_mapfold
open Minils
open Global_printer
let nodes_instances = ref NamesEnv.empty
let global_env = ref NamesEnv.empty
module Error =
struct
type error =
| Enode_unbound of qualname
| Epartial_instanciation of static_exp
let rec string_of_int_list = function
| [] -> ""
| [n] -> (string_of_int n)
| n::l -> (string_of_int n)^", "^(string_of_int_list l)
let message loc kind =
begin match kind with
| Enode_unbound ln ->
Format.eprintf "%aUnknown node '%s'@."
print_location loc
(fullname ln)
| Epartial_instanciation se ->
Format.eprintf "%aUnable to fully instanciate the static exp '%a'@."
print_location se.se_loc
print_static_exp se
end;
raise Misc.Error
end
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
module Param_instances :
sig
type key = private static_exp (** Fully instantiated param *)
type env = key QualEnv.t
val instantiate: env -> static_exp list -> key list
val get_node_instances : QualEnv.key -> key list list
val add_node_instance : QualEnv.key -> key list -> unit
val build : env -> param list -> key list -> env
module Instantiate :
sig
val program : program -> program
end
end =
struct
type key = static_exp
type env = key QualEnv.t
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
(** An instance is a list of instantiated params *)
type instance = key list
(** two instances are equal if the desc of keys are equal *)
let compare_instances =
let compare se1 se2 = compare se1.se_desc se2.se_desc in
Misc.make_list_compare compare
let build env params_names params_values =
List.fold_left2 (fun m { p_name = n } v -> NamesEnv.add n (Sconst v) m)
env params_names params_values
module S = (** Instances set *)
Set.Make(
struct
type t = instance
let compare = compare_instances
end)
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, _) ->
collect_exp nodes env e
| Evar _ | Econstvar _ | Econst _ -> ()
| Estruct(f_e_list) ->
List.iter (fun (_, e) -> collect_exp nodes env e) f_e_list
| Etuple e_list | Earray e_list ->
List.iter (collect_exp nodes env) e_list
| Efield_update(_, e1, e2) ->
collect_exp nodes env e1;
collect_exp nodes env e2
(* Do the real work: call node *)
| Ecall( { op_name = ln; op_params = params; op_kind = _ },
e_list, _) ->
List.iter (collect_exp nodes env) e_list;
let params = List.map (int_of_size_exp env) params in
call_node_instance nodes ln params
| Earray_op op ->
collect_array_exp nodes env op
module M = (** Map instance to its instantiated node *)
Map.Make(
struct
type t = qualname * instance
let compare (l1,i1) (l2,i2) =
let cl = compare l1 l2 in
if cl = 0 then compare_instances i1 i2 else cl
end)
and collect_array_exp nodes env = function
| 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) ->
collect_exp nodes env e1;
collect_exp nodes env e2
| Eselect (_,e) | Eselect_slice (_ , _, e) | Erepeat (_,e) ->
collect_exp nodes env e
| Eiterator (_, { op_name = ln; op_params = params }, _, e_list, _) ->
List.iter (collect_exp nodes env) e_list;
let params = List.map (int_of_size_exp env) params in
call_node_instance nodes ln params
(** Maps a couple (node name, params) to the name of the instantiated node *)
let nodes_names = ref M.empty
and collect_eqs nodes env eq =
collect_exp nodes env eq.eq_rhs
(** Maps a node to its list of instances *)
let nodes_instances = ref QualEnv.empty
and call_node_instance nodes ln params =
match params with
| [] -> ()
| params ->
let n = node_by_name (shortname ln) nodes in
node_call nodes n params
(** create a params instance *)
let instantiate m se =
try List.map (eval m) se
with Partial_instanciation se ->
Error.message no_location (Error.Epartial_instanciation se)
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
(** @return the name of the node corresponding to the instance of
[ln] with the static parameters [params]. *)
let node_for_params_call ln params = match params with
| [] -> ln
| _ -> let ln = M.find (ln,params) !nodes_names in ln
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 }
(** Generates a fresh name for the the instance of
[ln] with the static parameters [params] and stores it. *)
let generate_new_name ln params = match params with
| [] -> nodes_names := M.add (ln, params) ln !nodes_names
| _ -> let { qual = q; name = n } = ln in
let new_ln = { qual = q;
(* TODO ??? c'est quoi ce nom ??? *)
(* l'utilite de fresh n'est vrai que si toute les fonctions
sont touchees.. ce qui n'est pas vrai cf main_nodes *)
(* TODO mettre les valeurs des params dans le nom *)
name = n^(Idents.name (Idents.fresh "")) } in
nodes_names := M.add (ln, params) new_ln !nodes_names
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
(** Adds an instance of a node. *)
let add_node_instance ln params =
(* get the already defined instances *)
let instances = try QualEnv.find ln !nodes_instances
with Not_found -> S.empty in
if S.mem params instances then () (* nothing to do *)
else ( (* it's a new instance *)
let instances = S.add params instances in
nodes_instances := QualEnv.add ln instances !nodes_instances;
generate_new_name ln params )
(** @return the list of instances of a node. *)
let get_node_instances ln =
let instances_set =
try QualEnv.find ln !nodes_instances
with Not_found -> S.empty in
S.elements instances_set
(** Build an environment by instantiating the passed params *)
let build env params_names params_values =
List.fold_left2 (fun m { p_name = n } v -> QualEnv.add (local_qn n) v m)
env params_names (instantiate env params_values)
(** This module creates an instance of a node with a given
list of static parameters. *)
module Instantiate =
struct
(** Replaces static parameters with their value in the instance. *)
let static_exp funs m se =
let se, _ = Global_mapfold.static_exp funs m se in
let se = match se.se_desc with
| Svar q ->
if q.qual = local_qualname
then (* This var is a static parameter, it has to be instanciated *)
(try QualEnv.find q m
with Not_found ->
Format.eprintf "local param not local";
assert false;)
else se
| _ -> se in
se, m
(** Replaces nodes call with the call to the correct instance. *)
let edesc funs m ed =
let ed, _ = Mls_mapfold.edesc funs m ed in
let ed = match ed with
| Eapp ({ a_op = Efun ln; a_params = params } as app, e_list, r) ->
let op = Efun (node_for_params_call ln (instantiate m params)) in
Eapp ({ app with a_op = op; a_params = [] }, e_list, r)
| Eapp ({ a_op = Enode ln; a_params = params } as app, e_list, r) ->
let op = Enode (node_for_params_call ln (instantiate m params)) in
Eapp ({ app with a_op = op; a_params = [] }, e_list, r)
| Eiterator(it, ({ a_op = Efun ln; a_params = params } as app),
n, e_list, r) ->
let op = Efun (node_for_params_call ln (instantiate m params)) in
Eiterator(it, {app with a_op = op; a_params = [] }, n, e_list, r)
| Eiterator(it, ({ a_op = Enode ln; a_params = params } as app),
n, e_list, r) ->
let op = Enode (node_for_params_call ln (instantiate m params)) in
Eiterator(it,{app with a_op = op; a_params = [] }, n, e_list, r)
| _ -> ed
in ed, m
let node_dec_instance modname n params =
let global_funs =
{ Global_mapfold.defaults with static_exp = static_exp } in
let funs =
{ Mls_mapfold.defaults with edesc = edesc;
global_funs = global_funs } in
let m = build QualEnv.empty n.n_params params in
let n, _ = Mls_mapfold.node_dec_it funs m n in
(* Add to the global environment the signature of the new instance *)
let node_sig = find_value n.n_name in
let node_sig, _ = Global_mapfold.node_it global_funs m node_sig in
let node_sig = { node_sig with node_params = [];
node_params_constraints = [] } in
(* Find the name that was associated to this instance *)
let ln = node_for_params_call n.n_name params in
if not (check_value ln) then
Modules.add_value ln node_sig;
{ n with n_name = ln; n_params = []; n_params_constraints = []; }
let node_dec modname n =
List.map (node_dec_instance modname n) (get_node_instances n.n_name)
let program p =
{ p
with p_nodes = List.flatten (List.map (node_dec p.p_modname) p.p_nodes)}
end
end
open Param_instances
type info =
{ mutable opened : program NamesEnv.t;
mutable called_nodes : ((qualname * static_exp list) list) QualEnv.t; }
let info =
{ (** opened programs*)
opened = NamesEnv.empty;
(** Maps a node to the list of (node name, params) it calls *)
called_nodes = QualEnv.empty }
(** Loads the modname.epo file. *)
let load_object_file modname =
Modules.open_module modname;
let name = String.uncapitalize modname in
try
let filename = Misc.findfile (name ^ ".epo") in
let ic = open_in_bin filename in
try
let p:program = input_value ic in
if p.p_format_version <> minils_format_version then (
Format.eprintf "The file %s was compiled with \
an older version of the compiler.@\n\
Please recompile %s.ept first.@." filename name;
raise Error
);
close_in ic;
info.opened <- NamesEnv.add p.p_modname p info.opened
with
| End_of_file | Failure _ ->
close_in ic;
Format.eprintf "Corrupted object file %s.@\n\
Please recompile %s.ept first.@." filename name;
raise Error
with
| Misc.Cannot_find_file(filename) ->
Format.eprintf "Cannot find the object file '%s'.@."
filename;
raise Error
(** @return the node with name [ln], loading the corresponding
object file if necessary. *)
let node_by_longname ({ qual = q; name = n } as node) =
if not (NamesEnv.mem q info.opened)
then load_object_file q;
try
let p = NamesEnv.find q info.opened in
List.find (fun n -> n.n_name = node) p.p_nodes
with
Not_found -> Error.message no_location (Error.Enode_unbound node)
(** @return the list of nodes called by the node named [ln], with the
corresponding params (static parameters appear as free variables). *)
let collect_node_calls ln =
let add_called_node ln params acc =
match params with
| [] -> acc
| _ ->
(match ln with
| { qual = "Pervasives" } -> acc
| _ -> (ln, params)::acc)
in
let edesc funs acc ed = match ed with
| Eapp ({ a_op = (Enode ln | Efun ln); a_params = params }, _, _) ->
ed, add_called_node ln params acc
| Eiterator(_, { a_op = (Enode ln | Efun ln); a_params = params },
_, _, _) ->
ed, add_called_node ln params acc
| _ -> raise Misc.Fallback
in
let funs = { Mls_mapfold.defaults with edesc = edesc } in
let n = node_by_longname ln in
let _, acc = Mls_mapfold.node_dec funs [] n in
acc
(** @return the list of nodes called by the node named [ln]. This list is
computed lazily the first time it is needed. *)
let called_nodes ln =
if not (QualEnv.mem ln info.called_nodes) then (
let called = collect_node_calls ln in
info.called_nodes <- QualEnv.add ln called info.called_nodes;
called
) else
QualEnv.find ln info.called_nodes
(** Generates the list of instances of nodes needed to call
[ln] with static parameters [params]. *)
let rec call_node (ln, params) =
(* First, add the instance for this node *)
let n = node_by_longname ln in
let m = build QualEnv.empty n.n_params params in
(* List.iter check_no_static_var params; *)
add_node_instance ln params;
(* Recursively generate instances for called nodes. *)
let call_list = called_nodes ln in
let call_list =
List.map (fun (ln, p) -> ln, instantiate m p) call_list in
List.iter call_node call_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 }
(* Find the nodes without static parameters *)
let main_nodes = List.filter (fun n -> is_empty n.n_params) p.p_nodes in
let main_nodes = List.map (fun n -> n.n_name, []) main_nodes in
info.opened <- NamesEnv.add p.p_modname p NamesEnv.empty;
(* Creates the list of instances starting from these nodes *)
List.iter call_node main_nodes;
let p_list = NamesEnv.fold (fun _ p l -> p::l) info.opened [] in
(* Generate all the needed instances *)
List.map Param_instances.Instantiate.program p_list

128
compiler/minils/transformations/itfusion.ml Normal file
View file

@ -0,0 +1,128 @@
open Signature
open Modules
open Names
open Static
open Mls_mapfold
open Minils
(* Iterator fusion *)
(* Functions to temporarily store anonymous nodes*)
let mk_fresh_node_name () =
current_qual (Idents.name (Idents.fresh "_n_"))
let anon_nodes = ref QualEnv.empty
let add_anon_node inputs outputs locals eqs =
let n = mk_fresh_node_name () in
let nd = mk_node ~input:inputs ~output:outputs ~local:locals
~eq:eqs n in
anon_nodes := QualEnv.add n nd !anon_nodes;
n
let replace_anon_node n nd =
anon_nodes := QualEnv.add n nd !anon_nodes
let find_anon_node n =
QualEnv.find n !anon_nodes
let is_anon_node n =
QualEnv.mem n !anon_nodes
let are_equal n m =
let n = simplify QualEnv.empty n in
let m = simplify QualEnv.empty m in
n = m
let pat_of_vd_list l =
match l with
| [vd] -> Evarpat (vd.v_ident)
| _ -> Etuplepat (List.map (fun vd -> Evarpat vd.v_ident) l)
let tuple_of_vd_list l =
let el = List.map (fun vd -> mk_exp ~exp_ty:vd.v_type (Evar vd.v_ident)) l in
let ty = Types.prod (List.map (fun vd -> vd.v_type) l) in
mk_exp ~exp_ty:ty (Eapp (mk_app Etuple, el, None))
let vd_of_arg ad =
let n = match ad.a_name with None -> "_v" | Some n -> n in
mk_var_dec (Idents.fresh n) ad.a_type
(** @return the lists of inputs and outputs (as var_dec) of
an app object. *)
let get_node_inp_outp app = match app.a_op with
| (Enode f | Efun f) when is_anon_node f ->
(* first check if it is an anonymous node *)
let nd = find_anon_node f in
nd.n_input, nd.n_output
| Enode f | Efun f ->
(* it is a regular node*)
let ty_desc = find_value f in
let new_inp = List.map vd_of_arg ty_desc.node_outputs in
let new_outp = List.map vd_of_arg ty_desc.node_outputs in
new_inp, new_outp
| _ -> assert false
(** Creates the equation to call the node [app].
@return the list of new inputs required by the call, the expression
used to retrieve the resul of the call and [acc_eq_list] with the
added equations. *)
let mk_call app acc_eq_list =
let new_inp, new_outp = get_node_inp_outp app in
let args = List.map (fun vd -> mk_exp ~exp_ty:vd.v_type
(Evar vd.v_ident)) new_inp in
let out_ty = Types.prod (List.map (fun vd -> vd.v_type) new_outp) in
let e = mk_exp ~exp_ty:out_ty (Eapp (app, args, None)) in
match List.length new_outp with
| 1 -> new_inp, e, acc_eq_list
| _ ->
(*more than one output, we need to create a new equation *)
let eq = mk_equation (pat_of_vd_list new_outp) e in
let e = tuple_of_vd_list new_outp in
new_inp, e, eq::acc_eq_list
let edesc funs acc ed =
let ed, acc = Mls_mapfold.edesc funs acc ed in
match ed with
| Eiterator(Imap, f, n, e_list, r) ->
(** @return the list of inputs of the anonymous function,
a list of created equations (the body of the function),
the args for the call of f in the lambda,
the args for the iterator (ie the arrays).
[b] is used to know whether some fusion can be done.
map f (map g (x, y), z) --->
fun x', y', z' -> o1, o2 with
_v1, _v2 = g(x',y')
o1, o2 = f (_v1, _v2, z')
*)
let mk_arg e (inp, acc_eq_list, largs, args, b) = match e.e_desc with
| Eiterator(Imap, g, m, local_args, _) when are_equal n m ->
let new_inp, e, acc_eq_list = mk_call g acc_eq_list in
new_inp @ inp, acc_eq_list, e::largs, local_args @ args, true
| _ ->
let vd = mk_var_dec (Idents.fresh "_x") e.e_ty in
let x = mk_exp (Evar vd.v_ident) in
vd::inp, acc_eq_list, x::largs, e::args, b
in
let inp, acc_eq_list, largs, args, can_be_fused =
List.fold_right mk_arg e_list ([], [], [], [], false) in
if can_be_fused then (
(* create the call to f in the lambda fun *)
let call = mk_exp (Eapp(f, largs, None)) in
let _, outp = get_node_inp_outp f in
let eq = mk_equation (pat_of_vd_list outp) call in
(* create the lambda *)
let anon = mk_app (Enode (add_anon_node inp outp [] (eq::acc_eq_list))) in
Eiterator(Imap, anon, n, args, r), acc
) else
ed, acc
| _ -> raise Misc.Fallback
let program p =
let funs = { Mls_mapfold.defaults with edesc = edesc } in
let p, _ = Mls_mapfold.program_it funs false p in
p

247
compiler/minils/transformations/normalize.ml
View file

@ -6,27 +6,47 @@
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* $Id$ *)
open Misc
open Initial
open Names
open Ident
open Idents
open Signature
open Minils
open Mls_utils
open Types
open Clocks
let ctrue = Name "true"
and cfalse = Name "false"
let flatten_e_list l =
let flatten = function
| { e_desc = Eapp({ a_op = Etuple }, l, _) } -> l
| e -> [e]
in
List.flatten (List.map flatten l)
let equation (d_list, eq_list) ({ e_ty = te; e_ck = ck } as e) =
let n = Ident.fresh "_v" in
let d_list = (mk_var_dec ~clock:ck n te) :: d_list in
let eq_list = (mk_equation (Evarpat n) e) :: eq_list in
(d_list, eq_list), n
let equation (d_list, eq_list) e =
let add_one_var ty d_list =
let n = Idents.fresh "_v" in
let d_list = (mk_var_dec ~clock:e.e_ck n ty) :: d_list in
n, d_list
in
match e.e_ty with
| Tprod ty_list ->
let var_list, d_list =
mapfold (fun d_list ty -> add_one_var ty d_list) d_list ty_list in
let pat_list = List.map (fun n -> Evarpat n) var_list in
let eq_list = (mk_equation (Etuplepat pat_list) e) :: eq_list in
let e_list = List.map2
(fun n ty -> mk_exp ~exp_ty:ty (Evar n)) var_list ty_list in
let e = Eapp(mk_app Etuple, e_list, None) in
(d_list, eq_list), e
| _ ->
let n, d_list = add_one_var e.e_ty d_list in
let eq_list = (mk_equation (Evarpat n) e) :: eq_list in
(d_list, eq_list), Evar n
let intro context e =
match e.e_desc with
| Evar n -> context, n
| Evar n -> context, Evar n
| _ -> equation context e
(* distribution: [(e1,...,ek) when C(n) = (e1 when C(n),...,ek when C(n))] *)
@ -35,13 +55,24 @@ let rec whenc context e c n =
{ 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) ->
| Eapp({ a_op = Etuple } as app, e_list, r) ->
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) }
context, { e with e_desc = Eapp (app, e_list, r);
e_ck = Con(e.e_ck, c, n) }
| Econst { se_desc = Stuple se_list } ->
let e_list = exp_list_of_static_exp_list se_list in
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 = Eapp (mk_app Etuple, e_list, None);
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
@ -70,21 +101,25 @@ let rec merge e x ci_a_list =
let rec erasetuple ci_a_list =
match ci_a_list with
| [] -> []
| (ci, { e_desc = Etuple(l) }) :: ci_a_list ->
| (ci, { e_desc = Eapp({ a_op = Etuple }, l, _) }) :: ci_a_list ->
(ci, false, l) :: erasetuple ci_a_list
| (ci, { e_desc = Econst { se_desc = Stuple se_list } }) :: ci_a_list ->
let l = exp_list_of_static_exp_list se_list in
(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) }
| l -> { e with e_desc = Eapp(mk_app Etuple, l, None) }
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 n = (match n with Evar n -> n | _ -> assert false) in
let context, e2 = whenc context e2 ptrue n in
let context, e3 = whenc context e3 pfalse n in
context, merge e1 n [ptrue, e2; pfalse, e3]
let const e c =
let rec const = function
@ -105,24 +140,25 @@ let function_args_kind = Exp
let merge_kind = Act
let rec constant e = match e.e_desc with
| Econst _ | Econstvar _ -> true
| Econst _ -> true
| Ewhen(e, _, _) -> constant e
| Evar _ -> true
| _ -> false
let add context expected_kind ({ e_desc = de } as e) =
let up = match de, expected_kind with
| (Evar _ | Efield _ ) , VRef -> false
| (Evar _ | Eapp ({ a_op = Efield }, _, _)) , VRef -> false
| _ , VRef -> true
| Ecall ({ op_kind = Efun; op_name = n }, _, _),
| Eapp ({ a_op = Efun n }, _, _),
(Exp|Act) when is_op n -> false
| ( Emerge _ | Etuple _
| Ecall _ | Efby _ | Earray_op _ ), Exp -> true
| ( Ecall _ | Efby _ ), Act -> true
| Eapp ({ a_op = Eequal }, _, _), (Exp|Act) -> false
| ( Emerge _ | Eapp _ | Eiterator _ | Efby _ ), Exp -> true
| ( Eapp({ a_op = Efun _ | Enode _ }, _, _)
| Eiterator _ | Efby _ ), Act -> true
| _ -> false in
if up then
let context, n = equation context e in
context, { e with e_desc = Evar n }
context, { e with e_desc = n }
else context, e
let rec translate kind context e =
@ -135,34 +171,14 @@ let rec translate kind context e =
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
| Ecall(op_desc, e_list, r) ->
let context, e_list =
translate_list function_args_kind context e_list in
context, { e with e_desc = Ecall(op_desc, e_list, r) }
| 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') }
let context, e1 = translate Act context e1 in
fby kind context e v e1
| 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) }
| Econst c -> context, { e with e_desc = const e (Econst c) }
| Estruct(l) ->
let context, l =
List.fold_right
@ -171,46 +187,85 @@ let rec translate kind context e =
context, ((field, e) :: field_desc_list))
l (context, []) in
context, { e with e_desc = Estruct l }
| 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) }
| Earray(e_list) ->
let context, e_list = translate_list kind context e_list in
context, { e with e_desc = Earray(e_list) }
| Earray_op op ->
let context, op = translate_array_exp kind context op in
context, { e with e_desc = Earray_op op }
| Eapp({ a_op = 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
| Eapp({ a_op = Efun _ | Enode _ } as app, e_list, r) ->
let context, e_list =
translate_list function_args_kind context e_list in
context, { e with e_desc = Eapp(app, flatten_e_list e_list, r) }
| Eapp(app, e_list, r) ->
let context, e_list = translate_app kind context app.a_op e_list in
context, { e with e_desc = Eapp(app, e_list, r) }
| Eiterator (it, app, n, e_list, reset) ->
(* normalize anonymous nodes *)
(match app.a_op with
| Enode f when Itfusion.is_anon_node f ->
let nd = Itfusion.find_anon_node f in
let d_list, eq_list = translate_eq_list nd.n_local nd.n_equs in
let nd = { nd with n_equs = eq_list; n_local = d_list } in
Itfusion.replace_anon_node f nd
| _ -> () );
(* Add an intermediate equation for each array lit argument. *)
let translate_iterator_arg_list context e_list =
let add e context =
let kind = match e.e_desc with
| Econst { se_desc = Sarray _; } -> VRef
| _ -> function_args_kind in
translate kind context e in
Misc.mapfold_right add e_list context in
let context, e_list =
translate_iterator_arg_list context e_list in
context, { e with e_desc = Eiterator(it, app, n,
flatten_e_list e_list, reset) }
in add context kind e
and translate_array_exp kind context op =
match op with
| Erepeat (n,e') ->
and translate_app kind context op e_list =
match op, e_list with
| Eequal, e_list ->
let context, e_list =
translate_list function_args_kind context e_list in
context, e_list
| Etuple, e_list ->
let context, e_list = translate_list kind context e_list in
context, e_list
| Efield, [e'] ->
let context, e' = translate Exp context e' in
context, [e']
| Efield_update, [e1; e2] ->
let context, e1 = translate VRef context e1 in
let context, e2 = translate Exp context e2 in
context, [e1; e2]
| Earray, e_list ->
let context, e_list = translate_list kind context e_list in
context, e_list
| Earray_fill, [e] ->
let context, e = translate Exp context e in
context, [e]
| Eselect, [e'] ->
let context, e' = translate VRef context e' in
context, Erepeat(n, e')
| Eselect (idx,e') ->
let context, e' = translate VRef context e' in
context, Eselect(idx, e')
| Eselect_dyn (idx, e1, e2) ->
context, [e']
| Eselect_dyn, e1::e2::idx ->
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, Eselect_dyn(idx, e1, e2)
| Eupdate (idx, e1, e2) ->
context, e1::e2::idx
| Eupdate, e1::e2::idx ->
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, Eupdate(idx, e1, e2)
| Eselect_slice (idx1, idx2, e') ->
context, e1::e2::idx
| Eselect_slice, [e'] ->
let context, e' = translate VRef context e' in
context, Eselect_slice(idx1, idx2, e')
| Econcat (e1, e2) ->
context, [e']
| Econcat, [e1; e2] ->
let context, e1 = translate VRef context e1 in
let context, e2 = translate VRef context e2 in
context, Econcat(e1, e2)
| Eiterator (it, op_desc, n, e_list, reset) ->
let context, e_list =
translate_list function_args_kind context e_list in
context, Eiterator(it, op_desc, n, e_list, reset)
context, [e1; e2]
and translate_list kind context e_list =
match e_list with
@ -220,7 +275,37 @@ and translate_list kind context e_list =
let context, e_list = translate_list kind context e_list in
context, e :: e_list
let rec translate_eq context eq =
and fby kind context e v e1 =
let mk_fby c e =
mk_exp ~exp_ty:e.e_ty ~loc:e.e_loc (Efby(Some c, e)) in
let mk_pre e =
mk_exp ~exp_ty:e.e_ty ~loc:e.e_loc (Efby(None, e)) in
match e1.e_desc, v with
| Eapp({ a_op = Etuple } as app, e_list, r),
Some { se_desc = Stuple se_list } ->
let e_list = List.map2 mk_fby se_list e_list in
let e = { e with e_desc = Eapp(app, e_list, r) } in
translate kind context e
| Econst { se_desc = Stuple se_list },
Some { se_desc = Stuple v_list } ->
let e_list = List.map2 mk_fby v_list
(exp_list_of_static_exp_list se_list) in
let e = { e with e_desc = Eapp(mk_app Etuple, e_list, None) } in
translate kind context e
| Eapp({ a_op = Etuple } as app, e_list, r), None ->
let e_list = List.map mk_pre e_list in
let e = { e with e_desc = Eapp(app, e_list, r) } in
translate kind context e
| Econst { se_desc = Stuple se_list }, None ->
context, e1
| _ ->
let context, e1' =
if constant e1 then context, e1
else let context, n = equation context e1 in
context, { e1 with e_desc = n } in
context, { e with e_desc = Efby(v, e1') }
and translate_eq context eq =
(* applies distribution rules *)
(* [x = v fby e] should verifies that x is local *)
(* [(p1,...,pn) = (e1,...,en)] into [p1 = e1;...;pn = en] *)
@ -230,8 +315,8 @@ let rec translate_eq context eq =
| Evarpat(x), Efby _ when not (vd_mem x d_list) ->
let (d_list, eq_list), n = equation context e in
d_list,
{ eq with eq_rhs = { e with e_desc = Evar n } } :: eq_list
| Etuplepat(pat_list), Etuple(e_list) ->
{ eq with eq_rhs = { e with e_desc = n } } :: eq_list
| Etuplepat(pat_list), Eapp({ a_op = Etuple }, e_list, _) ->
let eqs = List.map2 mk_equation pat_list e_list in
List.fold_left distribute context eqs
| _ -> d_list, eq :: eq_list in
@ -239,7 +324,7 @@ let rec translate_eq context eq =
let context, e = translate Any context eq.eq_rhs in
distribute context { eq with eq_rhs = e }
let translate_eq_list d_list eq_list =
and translate_eq_list d_list eq_list =
List.fold_left
(fun context eq -> translate_eq context eq)
(d_list, []) eq_list

25
compiler/minils/transformations/schedule.ml
View file

@ -27,6 +27,7 @@ let join ck1 ck2 =
let join eq1 eq2 = join (Vars.clock eq1) (Vars.clock eq2)
(* TODO *)
(* possible overlapping between nodes *)
(*let head e =
match e with
@ -72,14 +73,20 @@ let schedule eq_list =
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 eqs funs () eq_list =
let eqs, () = Mls_mapfold.eqs funs () eq_list in
schedule 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 edesc funs () = function
| Eiterator(it, ({ a_op = Enode f } as app),
n, e_list, r) when Itfusion.is_anon_node f ->
let nd = Itfusion.find_anon_node f in
let nd = { nd with n_equs = schedule nd.n_equs } in
Itfusion.replace_anon_node f nd;
Eiterator(it, app, n, e_list, r), ()
| _ -> raise Fallback
let program ({ p_nodes = p_node_list } as p) =
{ p with p_nodes = List.map node p_node_list }
let program p =
let p, () = Mls_mapfold.program_it
{ Mls_mapfold.defaults with Mls_mapfold.eqs = eqs;
Mls_mapfold.edesc = edesc } () p in p

1
compiler/obc/_tags Normal file
View file

@ -0,0 +1 @@
<c> or <java>:include

94
compiler/minils/sequential/c.ml → compiler/obc/c/c.ml
View file

@ -21,6 +21,21 @@ let rec print_list ff print sep l =
fprintf ff "%s@ " sep;
print_list ff print sep l
(** [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
(******************************)
@ -92,6 +107,8 @@ and cstm =
(** C type declarations ; will {b always} correspond to a typedef in emitted
source code. *)
type cdecl =
(** C typedef declaration (alias, name)*)
| Cdecl_typedef of cty * string
(** C enum declaration, with associated value tags. *)
| Cdecl_enum of string * string list
(** C structure declaration, with each field's name and type. *)
@ -141,13 +158,14 @@ 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 pp_string fmt s =
fprintf fmt "%s" (cname_of_name 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_id s -> pp_string fmt 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"
@ -161,17 +179,19 @@ let rec pp_array_decl cty =
ty, sprintf "%s[%d]" s n
| _ -> cty, ""
let rec pp_param_cty fmt = function
| Cty_arr(n, cty') ->
fprintf fmt "%a*" pp_param_cty cty'
| cty -> pp_cty fmt 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 ty, indices = pp_array_decl cty in
fprintf fmt "%a %s%s" pp_cty 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
fprintf fmt "%a %a%s" pp_cty ty pp_string s indices
| _ -> fprintf fmt "%a %a" pp_cty cty pp_string s
and pp_param_list fmt l = pp_list1 pp_vardecl "," fmt l
and pp_var_list fmt l = pp_list pp_vardecl ";" fmt l
let rec pp_cblock fmt cb =
@ -195,33 +215,35 @@ and pp_cstm fmt stm = match stm with
fprintf fmt "@[<v>@[<v 2>if (%a) {%a@]@ @[<v 2>} else {%a@]@ }@]"
pp_cexpr c pp_cstm_list t pp_cstm_list e
| Cfor(x, lower, upper, e) ->
fprintf fmt "@[<v>@[<v 2>for (int %s = %d; %s < %d; ++%s) {%a@]@ }@]"
x lower x upper x pp_cstm_list e
fprintf fmt "@[<v>@[<v 2>for (int %a = %d; %a < %d; ++%a) {%a@]@ }@]"
pp_string x lower pp_string x
upper pp_string x pp_cstm_list e
| Cwhile (e, b) ->
fprintf fmt "@[<v>@[<v 2>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
| 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
| Cfun_call (s, el) ->
fprintf fmt "%a(@[%a@])" pp_string 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 (Ctag t) -> pp_string fmt 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
fprintf fmt "(%a){@[%a@]}" pp_string s (pp_list1 pp_cexpr ",") el
| Carraylit el ->
fprintf fmt "((int []){@[%a@]})" (pp_list1 pp_cexpr ",") el (* WRONG *)
and pp_clhs fmt lhs = match lhs with
| Cvar s -> fprintf fmt "%s" s
| Cvar s -> pp_string fmt s
| Cderef lhs' -> fprintf fmt "*%a" pp_clhs lhs'
| Cfield (Cderef lhs, f) -> fprintf fmt "%a->%s" pp_clhs lhs f
| Cfield (Cderef lhs, f) -> fprintf fmt "%a->%a" pp_clhs lhs pp_string f
| Cfield (lhs, f) -> fprintf fmt "%a.%s" pp_clhs lhs f
| Carray (lhs, e) ->
fprintf fmt "%a[%a]"
@ -230,25 +252,28 @@ and pp_clhs fmt lhs = match lhs with
let pp_cdecl fmt cdecl = match cdecl with
| Cdecl_enum (s, sl) ->
fprintf fmt "@[<v>@[<v 2>typedef enum {@ %a@]@ } %s;@ @]@\n"
(pp_list1 pp_string ",") sl s
fprintf fmt "@[<v>@[<v 2>typedef enum {@ %a@]@ } %a;@ @]@\n"
(pp_list1 pp_string ",") sl pp_string s
| Cdecl_typedef (cty, n) ->
fprintf fmt "@[<v>@[<v 2>typedef %a;@ @]@\n"
pp_vardecl (n, cty)
| Cdecl_struct (s, fl) ->
let pp_field fmt (s, cty) =
fprintf fmt "@ %a;" pp_vardecl (s,cty) in
fprintf fmt "@[<v>@[<v 2>typedef struct %s {" s;
fprintf fmt "@[<v>@[<v 2>typedef struct %a {" pp_string s;
List.iter (pp_field fmt) fl;
fprintf fmt "@]@ } %s;@ @]@\n" s
fprintf fmt "@]@ } %a;@ @]@\n" pp_string s
| Cdecl_function (n, retty, args) ->
fprintf fmt "@[<v>%a %s(@[<hov>%a@]);@ @]@\n"
pp_cty retty n pp_param_list args
fprintf fmt "@[<v>%a %a(@[<hov>%a@]);@ @]@\n"
pp_cty retty pp_string n pp_param_list args
let pp_cdef fmt cdef = match cdef with
| Cfundef cfd ->
fprintf fmt
"@[<v>@[<v 2>%a %s(@[<hov>%a@]) {%a@]@ }@ @]@\n"
pp_cty cfd.f_retty cfd.f_name pp_param_list cfd.f_args
"@[<v>@[<v 2>%a %a(@[<hov>%a@]) {%a@]@ }@ @]@\n"
pp_cty cfd.f_retty pp_string 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
| Cvardef (s, cty) -> fprintf fmt "%a %a;@\n" pp_cty cty pp_string s
let pp_cfile_desc fmt filen cfile =
(** [filen_wo_ext] is the file's name without the extension. *)
@ -259,7 +284,6 @@ let pp_cfile_desc fmt filen cfile =
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;
@ -279,7 +303,7 @@ let pp_cfile_desc fmt filen cfile =
(** [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;
if !Misc.verbose then Format.printf "C-NG generating %s/%s@." 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
@ -292,22 +316,6 @@ let output 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

2
compiler/minils/sequential/c.mli → compiler/obc/c/c.mli
View file

@ -74,6 +74,8 @@ and cstm =
(** C type declarations ; will {b always} correspond to a typedef in emitted
source code. *)
type cdecl =
(** C typedef declaration (type, alias)*)
| Cdecl_typedef of cty * string
(** C enum declaration, with associated value tags. *)
| Cdecl_enum of string * string list
(** C structure declaration, with each field's name and type. *)

500
compiler/minils/sequential/cgen.ml → compiler/obc/c/cgen.ml
View file

@ -11,13 +11,15 @@ open Format
open List
open Misc
open Names
open Ident
open Idents
open Obc
open Types
open Modules
open Signature
open C
open Location
open Printf
open Format
module Error =
struct
@ -26,86 +28,51 @@ struct
| Enode of string
| Eno_unnamed_output
| Ederef_not_pointer
| Estatic_exp_compute_failed
let message loc kind = (match kind with
| Evar name ->
eprintf "%aCode generation : The variable name '%s' is unbound.\n"
output_location loc name
eprintf "%aCode generation : The variable name '%s' is unbound.@."
print_location loc name
| Enode name ->
eprintf "%aCode generation : The node name '%s' is unbound.\n"
output_location loc name
eprintf "%aCode generation : The node name '%s' is unbound.@."
print_location loc name
| Eno_unnamed_output ->
eprintf "%aCode generation : Unnamed outputs are not supported.\n"
output_location loc
eprintf "%aCode generation : Unnamed outputs are not supported.@."
print_location loc
| Ederef_not_pointer ->
eprintf "%aCode generation : Trying to deference a non pointer type.\n"
output_location loc );
eprintf "%aCode generation : Trying to deference a non pointer type.@."
print_location loc
| Estatic_exp_compute_failed ->
eprintf "%aCode generation : Computation of the value of the static \
expression failed.@."
print_location loc);
raise Misc.Error
end
let cname_of_qn q =
(q.qual ^ "__" ^ q.name)
let rec struct_name ty =
match ty with
| Cty_id n -> n
| _ -> assert false
let cname_of_name' name = match name with
| Name n -> Name (cname_of_name n)
| _ -> name
let int_of_static_exp se =
Static.int_of_static_exp QualEnv.empty se
(* Functions 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.node_outputs
List.map remove_option sig_info.node_outputs
let is_statefull n =
try
let _, sig_info = node_info n in
sig_info.info.node_statefull
let sig_info = find_value n in
sig_info.node_statefull
with
Not_found -> Error.message no_location (Error.Enode (fullname n))
@ -125,23 +92,13 @@ let is_statefull n =
*)
let rec ctype_of_otype oty =
match oty with
| Tint -> Cty_int
| Tfloat -> Cty_float
| Tbool -> Cty_int
| 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 = Mls2obc.translate_type NamesEnv.empty ty in
ctype_of_otype ty
| Types.Tid id when id = Initial.pint -> Cty_int
| Types.Tid id when id = Initial.pfloat -> Cty_float
| Types.Tid id when id = Initial.pbool -> Cty_int
| Tid id -> Cty_id (cname_of_qn id)
| Tarray(ty, n) -> Cty_arr(int_of_static_exp n,
ctype_of_otype ty)
| Tprod _ -> assert false
let cvarlist_of_ovarlist vl =
let cvar_of_ovar vd =
@ -189,19 +146,31 @@ let rec copy_array src dest bounds =
mapping strings to cty). *)
let rec assoc_type n var_env =
match var_env with
| [] -> (*Error.message no_location (Error.Evar n)*)assert false
| [] -> Error.message no_location (Error.Evar n)
| (vn,ty)::var_env ->
if vn = n then
ty
else
assoc_type n var_env
(** @return the unaliased version of a type. *)
let rec unalias_ctype = function
| Cty_id ty_name ->
(try
match find_type (current_qual ty_name) with
| Talias ty -> unalias_ctype (ctype_of_otype ty)
| _ -> Cty_id ty_name
with Not_found -> Cty_id ty_name)
| Cty_arr (n, cty) -> Cty_arr (n, unalias_ctype cty)
| Cty_ptr cty -> Cty_ptr (unalias_ctype cty)
| cty -> cty
(** 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
| Cvar x -> unalias_ctype (assoc_type x var_env)
| Carray (lhs, _) ->
let ty = assoc_type_lhs lhs var_env in
array_base_ctype ty [1]
@ -213,8 +182,8 @@ let rec assoc_type_lhs lhs var_env =
| Cfield(x, f) ->
let ty = assoc_type_lhs x var_env in
let n = struct_name ty in
let { info = fields } = find_struct (longname n) in
ctype_of_heptty (field_assoc (Name f) fields)
let fields = find_struct (current_qual n) in
ctype_of_otype (field_assoc (current_qual f) fields)
(** Creates the statement a = [e_1, e_2, ..], which gives a list
a[i] = e_i.*)
@ -244,48 +213,62 @@ and create_affect_stm dest src ty =
(** Returns the expression to use e as an argument of
a function expecting a pointer as argument. *)
let address_of e =
try
(* try *)
let lhs = lhs_of_exp e in
match lhs with
| Carray _ -> Clhs lhs
| Cderef lhs -> Clhs lhs
| _ -> Caddrof lhs
with _ ->
e
(* with _ ->
e *)
let rec cexpr_of_static_exp se =
match se.se_desc with
| Sint i -> Cconst (Ccint i)
| Sfloat f -> Cconst (Ccfloat f)
| Sbool b -> Cconst (Ctag (if b then "TRUE" else "FALSE"))
| Sconstructor c -> Cconst (Ctag (cname_of_qn c))
| Sarray sl -> Carraylit (List.map cexpr_of_static_exp sl)
| Sarray_power(n,c) ->
let cc = cexpr_of_static_exp c in
Carraylit (repeat_list cc (int_of_static_exp n))
| Svar ln ->
(try
let cd = find_const ln in
cexpr_of_static_exp (Static.simplify QualEnv.empty cd.c_value)
with Not_found -> assert false)
| Sop _ ->
let se' = Static.simplify QualEnv.empty se in
if se = se' then
Error.message se.se_loc Error.Estatic_exp_compute_failed
else
cexpr_of_static_exp se'
(** [cexpr_of_exp exp] translates the Obj action [exp] to a C expression. *)
let rec cexpr_of_exp var_env exp =
match exp with
match exp.e_desc with
(** Obj expressions that form valid C lhs are translated via clhs_of_exp. *)
| Lhs _ ->
| Elhs _ ->
Clhs (clhs_of_exp var_env exp)
(** Constants, the easiest translation. *)
| Const lit ->
(match lit with
| Cint i -> Cconst (Ccint i)
| Cfloat f -> Cconst (Ccfloat f)
| Cconstr c -> Cconst (Ctag (shortname c))
| Obc.Carray(n,c) ->
let cc = cexpr_of_exp var_env (Const c) in
Carraylit (repeat_list cc n)
)
| Econst lit ->
cexpr_of_static_exp lit
(** Operators *)
| Op(op, exps) ->
| Eop(op, exps) ->
cop_of_op var_env op exps
(** Structure literals. *)
| Struct_lit (tyn, fl) ->
| Estruct (tyn, fl) ->
let cexps = List.map (fun (_,e) -> cexpr_of_exp var_env e) fl in
let ctyn = shortname tyn in
let ctyn = cname_of_qn tyn in
Cstructlit (ctyn, cexps)
| Array_lit e_list ->
| Earray 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 } ->
and cop_of_op_aux var_env op_name cexps = match op_name with
| { qual = "Pervasives"; name = op } ->
begin match op,cexps with
| "~-", [e] -> Cuop ("-", e)
| "not", [e] -> Cuop ("!", e)
@ -298,19 +281,16 @@ and cop_of_op_aux var_env op_name cexps =
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) ->
| {qual = m; 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
and clhs_of_lhs var_env l = match l.l_desc with
(** Each Obc variable corresponds to a real local C variable. *)
| Var v ->
| Lvar v ->
let n = name v in
if List.mem_assoc n var_env then
let ty = assoc_type n var_env in
@ -321,17 +301,17 @@ and clhs_of_lhs var_env = function
else
Cvar n
(** Dereference our [self] struct holding the node's memory. *)
| Mem v -> Cfield (Cderef (Cvar "self"), name v)
| Lmem 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) ->
| Lfield (l, fn) -> Cfield(clhs_of_lhs var_env l, shortname fn)
| Larray (l, idx) ->
Carray(clhs_of_lhs var_env l, 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
and clhs_of_exp var_env exp = match exp.e_desc with
| Elhs 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"
@ -339,17 +319,15 @@ let rec assoc_obj instance obj_env =
match obj_env with
| [] -> raise Not_found
| od :: t ->
if od.obj = instance
if od.o_name = instance
then od
else assoc_obj instance t
let assoc_cn instance obj_env =
match instance with
| Context obj
| Array_context (obj, _) -> (assoc_obj obj obj_env).cls
(assoc_obj (obj_call_name instance) obj_env).o_class
let is_op = function
| Modname { qual = "Pervasives"; id = _ } -> true
| { qual = "Pervasives"; name = _ } -> true
| _ -> false
let out_var_name_of_objn o =
@ -362,8 +340,8 @@ let step_fun_call var_env sig_info objn out args =
if sig_info.node_statefull then (
let mem =
(match objn with
| Context o -> Cfield (Cderef (Cvar "self"), o)
| Array_context (o, l) ->
| Oobj o -> Cfield (Cderef (Cvar "self"), o)
| Oarray (o, l) ->
let l = clhs_of_lhs var_env l in
Carray (Cfield (Cderef (Cvar "self"), o), Clhs l)
) in
@ -378,8 +356,8 @@ let step_fun_call var_env sig_info objn out args =
let generate_function_call var_env obj_env outvl objn args =
(** 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 classn = cname_of_qn classln in
let sig_info = find_value classln in
let out = Cvar (out_var_name_of_objn classn) in
let fun_call =
@ -388,7 +366,7 @@ let generate_function_call var_env obj_env outvl objn args =
else
(** The step function takes scalar arguments and its own internal memory
holding structure. *)
let args = step_fun_call var_env sig_info.info objn out args in
let args = step_fun_call var_env sig_info objn out args in
(** Our C expression for the function call. *)
Cfun_call (classn ^ "_step", args)
in
@ -412,12 +390,17 @@ let generate_function_call var_env obj_env outvl objn args =
(** Create the statement dest = c where c = v^n^m... *)
let rec create_affect_const var_env dest c =
match c with
| Obc.Carray(n,c) ->
match c.se_desc with
| Sarray_power(c, n) ->
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))]
[Cfor(x, 0, int_of_static_exp n,
create_affect_const var_env (Carray (dest, Clhs (Cvar x))) c)]
| Sarray cl ->
let create_affect_idx c (i, affl) =
let dest = Carray (dest, Cconst (Ccint i)) in
(i - 1, create_affect_const var_env dest c @ affl) in
snd (List.fold_right create_affect_idx cl (List.length cl - 1, []))
| _ -> [Caffect (dest, cexpr_of_exp var_env (mk_exp (Econst c)))]
(** [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
@ -425,57 +408,56 @@ let rec create_affect_const var_env dest c =
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)]) ->
| Acase (c, [({name = "true"}, te); ({ name = "false" }, fe)])
| Acase (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
let cte = cstm_of_act_list var_env obj_env te in
let cfe = cstm_of_act_list 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) ->
| Acase (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
(fun (c,act) -> cname_of_qn c,
cstm_of_act_list 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. *)
| For (x, i1, i2, act) ->
[Cfor(name x, i1, i2, cstm_of_act var_env obj_env act)]
| 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
| Afor (x, i1, i2, act) ->
[Cfor(name x, int_of_static_exp i1,
int_of_static_exp i2, cstm_of_act_list var_env obj_env act)]
(** Reinitialization of an object variable, extracting the reset
function's name from our environment [obj_env]. *)
| Reinit on ->
| Acall ([], o, Mreset, []) ->
let on = obj_call_name o in
let obj = assoc_obj on obj_env in
let classn = shortname obj.cls in
if obj.size = 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.size,
[Csexpr (Cfun_call (classn ^ "_reset", elt ))] )]
let classn = cname_of_qn obj.o_class in
(match obj.o_size with
| None -> [Csexpr (Cfun_call (classn ^ "_reset",
[Caddrof (Cfield (Cderef (Cvar "self"), on))]))]
| Some size ->
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, int_of_static_exp size,
[Csexpr (Cfun_call (classn ^ "_reset", elt ))] )]
)
(** Special case for x = 0^n^n...*)
| Assgn (vn, Const c) ->
| Aassgn (vn, { e_desc = Econst 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) ->
| Aassgn (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
@ -484,13 +466,19 @@ let rec cstm_of_act var_env obj_env act =
(** 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) ->
| Acall (outvl, objn, Mstep, el) ->
let args = cexprs_of_exps var_env el in
let outvl = clhss_of_lhss var_env outvl in
generate_function_call var_env obj_env outvl objn args
(** Well, Nothing translates to no instruction. *)
| Nothing -> []
and cstm_of_act_list var_env obj_env b =
let l = List.map cvar_of_vd b.b_locals in
let var_env = l @ var_env in
let cstm = List.flatten (List.map (cstm_of_act var_env obj_env) b.b_body) in
match l with
| [] -> cstm
| _ ->
[Csblock { var_decls = l; block_body = cstm }]
(* TODO needed only because of renaming phase *)
let global_name = ref "";;
@ -499,15 +487,16 @@ let global_name = ref "";;
(** {2 step() and reset() functions generation *)
let mk_current_longname n =
{ qual = !global_name; name = n }
(** Builds the argument list of step function*)
let step_fun_args n sf =
let args = cvarlist_of_ovarlist sf.inp in
let out_arg = [("out", Cty_ptr (Cty_id (n ^ "_out")))] in
let step_fun_args n md =
let args = cvarlist_of_ovarlist md.m_inputs in
let out_arg = [("out", Cty_ptr (Cty_id ((cname_of_qn n) ^ "_out")))] in
let context_arg =
if is_statefull (longname n) then
[("self", Cty_ptr (Cty_id (n ^ "_mem")))]
if is_statefull n then
[("self", Cty_ptr (Cty_id ((cname_of_qn n) ^ "_mem")))]
else
[]
in
@ -520,56 +509,36 @@ let step_fun_args n sf =
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. *)
let fun_def_of_step_fun name obj_env mem objs sf =
let fun_name = name ^ "_step" in
let fun_def_of_step_fun n obj_env mem objs md =
let fun_name = (cname_of_qn n) ^ "_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
let args = step_fun_args n md in
(** Out vars for function calls *)
let out_vars =
unique
(List.map (fun obj -> out_var_name_of_objn (shortname obj.cls),
Cty_id ((cname_of_name (shortname obj.cls)) ^ "_out"))
(List.filter (fun obj -> not (is_op obj.cls)) objs)) in
(List.map (fun obj -> out_var_name_of_objn (cname_of_qn obj.o_class),
Cty_id ((cname_of_qn obj.o_class) ^ "_out"))
(List.filter (fun obj -> not (is_op obj.o_class)) objs)) 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 =
let addrof { v_ident = c_name } =
Caddrof (Cvar (Ident.name c_name)) in
List.map addrof 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 @ out_vars in
let body = cstm_of_act var_env obj_env sf.bd in
let mems = List.map cvar_of_vd (mem@md.m_outputs) in
let var_env = args @ mems @ out_vars in
let body = cstm_of_act_list var_env obj_env md.m_body in
(** Substitute the return value variables with the corresponding
context field*)
let map = Csubst.assoc_map_for_fun sf in
let map = Csubst.assoc_map_for_fun md in
let body = List.map (Csubst.subst_stm map) body in
use_ctrlr,
Cfundef {
f_name = fun_name;
f_retty = Cty_void;
f_args = args;
f_body = {
var_decls = local_vars @ out_vars;
block_body = ctrlr_calls @ body
var_decls = out_vars;
block_body = body
}
}
@ -579,37 +548,42 @@ 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_statefull od.cls then
let clsname = shortname od.cls in
let ty = Cty_id ((cname_of_name clsname) ^ "_mem") in
let ty = if od.size <> 1 then Cty_arr (od.size, ty) else ty in
(od.obj, ty)::l
if is_statefull od.o_class then
let clsname = cname_of_qn od.o_class in
let ty = Cty_id (clsname ^ "_mem") in
let ty = match od.o_size with
| Some se -> Cty_arr (int_of_static_exp se, ty)
| None -> ty in
(od.o_name, ty)::l
else
l
in
if is_statefull (longname cd.cl_id) then (
if is_statefull cd.cd_name then (
(** Fields corresponding to normal memory variables. *)
let mem_fields = List.map cvar_of_vd cd.mem in
let mem_fields = List.map cvar_of_vd cd.cd_mems in
(** Fields corresponding to object variables. *)
let obj_fields = List.fold_left struct_field_of_obj_dec [] cd.objs in
[Cdecl_struct (cd.cl_id ^ "_mem", mem_fields @ obj_fields)]
let obj_fields = List.fold_left struct_field_of_obj_dec [] cd.cd_objs in
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_mem",
mem_fields @ obj_fields)]
) else
[]
let out_decl_of_class_def cd =
(** Fields corresponding to output variables. *)
let out_fields = List.map cvar_of_vd cd.step.out in
[Cdecl_struct (cd.cl_id ^ "_out", out_fields)]
let step_m = find_step_method cd in
let out_fields = List.map cvar_of_vd step_m.m_outputs in
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_out", 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
let var_env = List.map cvar_of_vd cd.cd_mems in
let reset = find_reset_method cd in
let body = cstm_of_act_list var_env cd.cd_objs reset.m_body in
Cfundef {
f_name = (cd.cl_id ^ "_reset");
f_name = (cname_of_qn cd.cd_name) ^ "_reset";
f_retty = Cty_void;
f_args = [("self", Cty_ptr (Cty_id (cd.cl_id ^ "_mem")))];
f_args = [("self", Cty_ptr (Cty_id ((cname_of_qn cd.cd_name) ^ "_mem")))];
f_body = {
var_decls = [];
block_body = body;
@ -622,36 +596,35 @@ 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 step_m = find_step_method cd in
let memory_struct_decl = mem_decl_of_class_def cd in
let out_struct_decl = out_decl_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.objs cd.step in
let step_fun_def = fun_def_of_step_fun cd.cd_name
cd.cd_objs cd.cd_mems cd.cd_objs step_m 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
let fun_defs =
if is_statefull (longname cd.cl_id) then
let (decls, defs) =
if is_statefull cd.cd_name then
([res_fun_decl; step_fun_decl], [reset_fun_def; step_fun_def])
else
([step_fun_decl], [step_fun_def]) in
memory_struct_decl @ out_struct_decl,
use_ctrlr,
fun_defs
memory_struct_decl @ out_struct_decl @ decls,
defs
(** {2 Type translation} *)
let decls_of_type_decl otd =
let name = otd.t_name in
let name = cname_of_qn otd.t_name in
match otd.t_desc with
| Type_abs -> [] (*assert false*)
| Type_alias ty -> [Cdecl_typedef (ctype_of_otype ty, name)]
| Type_enum nl ->
let name = !global_name ^ "_" ^ name in
[Cdecl_enum (otd.t_name, nl);
[Cdecl_enum (name, nl);
Cdecl_function (name ^ "_of_string",
Cty_id name,
[("s", Cty_ptr Cty_char)]);
@ -659,14 +632,16 @@ let decls_of_type_decl otd =
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)];;
let decls = List.map (fun f -> cname_of_qn f.Signature.f_name,
ctype_of_otype f.Signature.f_type) fl in
[Cdecl_struct (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
let name = cname_of_qn otd.t_name in
match otd.t_desc with
| Type_abs -> [], [] (*assert false*)
| Type_alias ty -> [], [Cdecl_typedef (ctype_of_otype ty, name)]
| Type_enum nl ->
let of_string_fun = Cfundef
{ f_name = name ^ "_of_string";
@ -698,78 +673,39 @@ let cdefs_and_cdecls_of_type_decl otd =
Creturn (Clhs (Cvar "buf"))]; }
} in
([of_string_fun; to_string_fun],
[Cdecl_enum (otd.t_name, nl); cdecl_of_cfundef of_string_fun;
[Cdecl_enum (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
let decls = List.map (fun f -> cname_of_qn f.Signature.f_name,
ctype_of_otype f.Signature.f_type) fl in
let decl = Cdecl_struct (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 struct_decl,use_ctrlr,(cdecls, cdefs) =
cdefs_and_cdecls_of_class_def cd in
let l = get_opened_modules () 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 (l, struct_decl));
(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 cfile_list_of_oprog_ty_decls name oprog =
let cdefs_and_cdecls = List.map cdefs_and_cdecls_of_type_decl oprog.p_types in
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
Cheader (["stdbool"], 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
filename_types, [types_h; types_c]
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.objs cd.step in
cdecl_of_cfundef s
in
reset_opened_modules ();
List.iter add_opened_module prog.o_opened;
let dependencies = S.elements (Obc_utils.Deps.deps_program prog) in
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.flatten (List.map mem_decl_of_class_def
prog.o_defs) in
let reset_fun_decls =
let cdecl_of_reset_fun cd =
cdecl_of_cfundef (reset_fun_def_of_class_def cd) in
List.map cdecl_of_reset_fun prog.o_defs in
let step_fun_decls = List.map step_fun_decl prog.o_defs in
let (decls, defs) =
List.split (List.map cdefs_and_cdecls_of_class_def prog.p_defs) in
let decls = List.concat decls
and defs = List.concat defs in
(name ^ ".h", Cheader (get_opened_modules (),
ty_decls
@ mem_step_fun_decls
@ reset_fun_decls
@ step_fun_decls))
let (ty_fname, ty_files) = cfile_list_of_oprog_ty_decls name prog in
let header =
(name ^ ".h", Cheader (ty_fname :: dependencies, decls))
and source =
(name ^ ".c", Csource defs) in
[header; source] @ ty_files

112
compiler/minils/sequential/cmain.ml → compiler/obc/c/cmain.ml
View file

@ -11,39 +11,45 @@ open Format
open List
open Misc
open Names
open Ident
open Idents
open Obc
open Types
open Modules
open Signature
open C
open Cgen
open Location
open Printf
open Format
open Compiler_utils
(** {1 Main C function generation} *)
(* Unique names for C variables handling step counts. *)
let step_counter = Ident.fresh "step_c"
and max_step = Ident.fresh "step_max"
let step_counter = Idents.fresh "step_c"
and max_step = Idents.fresh "step_max"
let assert_node_res cd =
if List.length cd.step.inp > 0 then
(Printf.eprintf "Cannot generate run-time check for node %s with inputs.\n"
cd.cl_id;
let stepm = find_step_method cd in
if List.length stepm.m_inputs > 0 then
(Format.eprintf "Cannot generate run-time check for node %s with inputs.@."
(cname_of_qn cd.cd_name);
exit 1);
if (match cd.step.out with
| [{ v_type = Tbool; }] -> false
if (match stepm.m_outputs with
| [{ v_type = Tid nbool; }] when nbool = Initial.pbool -> false
| _ -> true) then
(Printf.eprintf
"Cannot generate run-time check for node %s with non-boolean output.\n"
cd.cl_id;
(Format.eprintf
"Cannot generate run-time check for node %s with non-boolean output.@."
(cname_of_qn cd.cd_name);
exit 1);
let name = cname_of_qn cd.cd_name in
let mem =
(name (Ident.fresh ("mem_for_" ^ cd.cl_id)), Cty_id (cd.cl_id ^ "_mem"))
(Idents.name (Idents.fresh ("mem_for_" ^ name)),
Cty_id (name ^ "_mem"))
and out =
(name (Ident.fresh ("out_for_" ^ cd.cl_id)), Cty_id (cd.cl_id ^ "_out")) in
(Idents.name (Idents.fresh ("out_for_" ^ name)),
Cty_id (name ^ "_out")) in
let reset_i =
Cfun_call (cd.cl_id ^ "_reset", [Caddrof (Cvar (fst mem))]) in
Cfun_call (name ^ "_reset", [Caddrof (Cvar (fst mem))]) in
let step_i =
(*
step(&out, &mem);
@ -52,20 +58,20 @@ let assert_node_res cd =
return 1;
}
*)
let outn = Ident.name ((List.hd cd.step.out).v_ident) in
let outn = Idents.name ((List.hd stepm.m_outputs).v_ident) in
Csblock
{ var_decls = [];
block_body =
[
Csexpr (Cfun_call (cd.cl_id ^ "_step",
Csexpr (Cfun_call (name ^ "_step",
[Caddrof (Cvar (fst out));
Caddrof (Cvar (fst mem))]));
Cif (Cuop ("!", Clhs (Cfield (Cvar (fst out), outn))),
[Csexpr (Cfun_call ("printf",
[Cconst (Cstrlit ("Node \\\"" ^ cd.cl_id
[Cconst (Cstrlit ("Node \\\"" ^ name
^ "\\\" failed at step" ^
" %d.\\n"));
Clhs (Cvar (name step_counter))]));
Clhs (Cvar (Idents.name step_counter))]));
Creturn (Cconst (Ccint 1))],
[]);
];
@ -79,26 +85,29 @@ let assert_node_res cd =
let main_def_of_class_def cd =
let format_for_type ty = match ty with
| Tarray _ -> assert false
| Tint | Tbool -> "%d"
| Tfloat -> "%f"
| Tid ((Name sid) | Modname { id = sid }) -> "%s" in
| Types.Tid id when id = Initial.pfloat -> "%f"
| Types.Tid id when id = Initial.pint -> "%d"
| Types.Tid id when id = Initial.pbool -> "%d"
| Tid _ -> "%s" in
(** Does reading type [ty] need a buffer? When it is the case,
[need_buf_for_ty] also returns the type's name. *)
let need_buf_for_ty ty = match ty with
| Tarray _ -> assert false
| Tint | Tfloat | Tbool -> None
| Tid (Name sid | Modname { id = sid; }) -> Some sid in
| Types.Tid id when id = Initial.pfloat -> None
| Types.Tid id when id = Initial.pint -> None
| Types.Tid id when id = Initial.pbool -> None
| Tid { name = n } -> Some n in
let cprint_string s = Csexpr (Cfun_call ("printf", [Cconst (Cstrlit s)])) in
(** Generates scanf statements. *)
let rec read_lhs_of_ty lhs ty = match ty with
| Tarray (ty, n) ->
let iter_var = Ident.name (Ident.fresh "i") in
let iter_var = Idents.name (Idents.fresh "i") in
let lhs = Carray (lhs, Clhs (Cvar iter_var)) in
let (reads, bufs) = read_lhs_of_ty lhs ty in
([Cfor (iter_var, 0, n, reads)], bufs)
([Cfor (iter_var, 0, int_of_static_exp n, reads)], bufs)
| _ ->
let rec mk_prompt lhs = match lhs with
| Cvar vn -> (vn, [])
@ -108,7 +117,7 @@ let main_def_of_class_def cd =
| _ -> assert false in
let (prompt, args_format_s) = mk_prompt lhs in
let scan_exp =
let printf_s = Printf.sprintf "%s ? " prompt in
let printf_s = Format.sprintf "%s ? " prompt in
let format_s = format_for_type ty in
Csblock { var_decls = [];
block_body = [
@ -121,7 +130,7 @@ let main_def_of_class_def cd =
match need_buf_for_ty ty with
| None -> ([scan_exp], [])
| Some tyn ->
let varn = Ident.name (Ident.fresh "buf") in
let varn = Idents.name (Idents.fresh "buf") in
([scan_exp;
Csexpr (Cfun_call (tyn ^ "_of_string",
[Clhs (Cvar varn)]))],
@ -131,13 +140,14 @@ let main_def_of_class_def cd =
resulting values of enum types. *)
let rec write_lhs_of_ty lhs ty = match ty with
| Tarray (ty, n) ->
let iter_var = Ident.name (Ident.fresh "i") in
let iter_var = Idents.name (Idents.fresh "i") in
let lhs = Carray (lhs, Clhs (Cvar iter_var)) in
let (reads, bufs) = write_lhs_of_ty lhs ty in
([cprint_string "[ "; Cfor (iter_var, 0, n, reads); cprint_string "]"],
bufs)
([cprint_string "[ ";
Cfor (iter_var, 0, int_of_static_exp n, reads);
cprint_string "]"], bufs)
| _ ->
let varn = Ident.name (Ident.fresh "buf") in
let varn = Idents.name (Idents.fresh "buf") in
let format_s = format_for_type ty in
let nbuf_opt = need_buf_for_ty ty in
let ep = match nbuf_opt with
@ -152,24 +162,25 @@ let main_def_of_class_def cd =
| None -> []
| Some id -> [(varn, Cty_arr (20, Cty_char))]) in
let stepm = find_step_method cd in
let (scanf_calls, scanf_decls) =
let read_lhs_of_ty_for_vd vd =
read_lhs_of_ty (Cvar (Ident.name vd.v_ident)) vd.v_type in
split (map read_lhs_of_ty_for_vd cd.step.inp) in
read_lhs_of_ty (Cvar (Idents.name vd.v_ident)) vd.v_type in
split (map read_lhs_of_ty_for_vd stepm.m_inputs) in
let (printf_calls, printf_decls) =
let write_lhs_of_ty_for_vd vd =
let (stm, vars) =
write_lhs_of_ty (Cfield (Cvar "res", name vd.v_ident)) vd.v_type in
(cprint_string "=> " :: stm, vars) in
split (map write_lhs_of_ty_for_vd cd.step.out) in
split (map write_lhs_of_ty_for_vd stepm.m_outputs) in
let printf_calls = List.concat printf_calls in
let cinp = cvarlist_of_ovarlist cd.step.inp in
let cout = ["res", (Cty_id (cd.cl_id ^ "_out"))] in
let cinp = cvarlist_of_ovarlist stepm.m_inputs in
let cout = ["res", (Cty_id ((cname_of_qn cd.cd_name) ^ "_out"))] in
let varlist =
("mem", Cty_id (cd.cl_id ^ "_mem"))
("mem", Cty_id ((cname_of_qn cd.cd_name) ^ "_mem"))
:: cinp
@ cout
@ concat scanf_decls
@ -180,9 +191,9 @@ let main_def_of_class_def cd =
let step_l =
let funcall =
let args =
map (fun vd -> Clhs (Cvar (name vd.v_ident))) cd.step.inp
map (fun vd -> Clhs (Cvar (name vd.v_ident))) stepm.m_inputs
@ [Caddrof (Cvar "res"); Caddrof (Cvar "mem")] in
Cfun_call (cd.cl_id ^ "_step", args) in
Cfun_call ((cname_of_qn cd.cd_name) ^ "_step", args) in
concat scanf_calls
@ [Csexpr funcall]
@ printf_calls
@ -191,7 +202,8 @@ let main_def_of_class_def cd =
(** Do not forget to initialize memory via reset. *)
let rst_i =
Csexpr (Cfun_call (cd.cl_id ^ "_reset", [Caddrof (Cvar "mem")])) in
Csexpr (Cfun_call ((cname_of_qn cd.cd_name) ^ "_reset",
[Caddrof (Cvar "mem")])) in
(varlist, rst_i, step_l)
@ -240,13 +252,13 @@ let main_skel var_list prologue body =
}
}
let mk_main p = match (!Misc.simulation_node, !Misc.assert_nodes) with
let mk_main name p = match (!Misc.simulation_node, !Misc.assert_nodes) with
| (None, []) -> []
| (_, n_names) ->
let find_class n =
try List.find (fun cd -> cd.cl_id = n) p.o_defs
try List.find (fun cd -> cd.cd_name.name = n) p.p_defs
with Not_found ->
Printf.eprintf "Unknown node %s.\n" n;
Format.eprintf "Unknown node %s.\n" n;
exit 1 in
let a_classes = List.map find_class n_names in
@ -267,7 +279,7 @@ let mk_main p = match (!Misc.simulation_node, !Misc.assert_nodes) with
res :: res_l, nstep_l @ step_l)) in
[("_main.c", Csource [main_skel var_l res_l step_l]);
("_main.h", Cheader (deps, []))];
("_main.h", Cheader ([name], []))];
;;
@ -276,5 +288,11 @@ let mk_main p = match (!Misc.simulation_node, !Misc.assert_nodes) with
let translate name prog =
let modname = (Filename.basename name) in
global_name := String.capitalize modname;
(global_file_header modname prog) :: (mk_main prog)
@ (cfile_list_of_oprog modname prog)
(global_file_header modname prog) @ (mk_main name prog)
let program p =
let filename = filename_of_name (cname_of_name p.p_modname) in
let dirname = build_path (filename ^ "_c") in
let dir = clean_dir dirname in
let c_ast = translate filename p in
C.output dir c_ast

6
compiler/minils/sequential/csubst.ml → compiler/obc/c/csubst.ml
View file

@ -1,5 +1,5 @@
open C
open Ident
open Idents
open Names
let rec subst_stm map stm = match stm with
@ -48,8 +48,8 @@ and subst_exp_list 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.Obc.out with
let assoc_map_for_fun md =
match md.Obc.m_outputs with
| [] -> NamesEnv.empty
| out ->
let fill_field map vd =

72
compiler/minils/sequential/control.ml → compiler/obc/control.ml
View file

@ -9,11 +9,12 @@
(* control optimisation *)
(* $Id$ *)
open Minils
open Ident
open Idents
open Misc
open Obc
open Clocks
let var_from_name map x =
begin try
@ -22,6 +23,10 @@ let var_from_name map x =
_ -> assert false
end
let fuse_blocks b1 b2 =
{ b1 with b_locals = b1.b_locals @ b2.b_locals;
b_body = b1.b_body @ b2.b_body }
let rec find c = function
| [] -> raise Not_found
| (c1, s1) :: h ->
@ -32,50 +37,39 @@ let rec control map ck s =
| 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 x = var_from_name map n in
control map ck (Acase(mk_exp (Elhs x), [(c, mk_block [s])]))
let rec simplify act =
match act with
| Obc.Assgn (lhs, e) ->
(match e with
| Obc.Lhs l when l = lhs -> Obc.Nothing
| _ -> act
let is_deadcode = function
| Aassgn (lhs, e) ->
(match e.e_desc with
| Elhs l -> l = lhs
| _ -> false
)
| Obc.Case(lhs, h) ->
(match simplify_handlers h with
| [] -> Obc.Nothing
| h -> Obc.Case(lhs, h)
)
| _ -> act
| Acase (e, []) -> true
| Afor(_, _, _, { b_body = [] }) -> true
| _ -> false
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 joinlist l =
let l = List.filter (fun a -> not (is_deadcode a)) l in
match l with
| [] -> []
| [s1] -> [s1]
| s1::s2::l ->
match s1, s2 with
| Acase(e1, h1),
Acase(e2, h2) when e1.e_desc = e2.e_desc ->
joinlist ((Acase(e1, joinhandlers h1 h2))::l)
| s1, s2 -> s1::(joinlist (s2::l))
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 join_block b =
{ b with b_body = joinlist b.b_body }
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)
try let s2, h2'' = find c1 h2 in fuse_blocks s1 s2, h2''
with Not_found -> s1, h2 in
(c1, join_block s1') :: joinhandlers h1' h2'

8
compiler/minils/sequential/java.ml → compiler/obc/java/java.ml
View file

@ -14,7 +14,7 @@ open Format
open Obc
open Misc
open Names
open Ident
open Idents
open Pp_tools
let jname_of_name name =
@ -164,8 +164,8 @@ let print_types java_dir headers tps =
(******************************)
type answer =
| Sing of var_name
| Mult of var_name list
| Sing of var_ident
| Mult of var_ident list
let print_const ff c ts =
match c with
@ -503,7 +503,7 @@ let print_step ff n s objs ts single =
(List.map (fun vd -> vd.v_ident) s.out) ts single;
fprintf ff "@ @ return ";
if single
then fprintf ff "%s" (jname_of_name (Ident.name (List.hd s.out).v_ident))
then fprintf ff "%s" (jname_of_name (Idents.name (List.hd s.out).v_ident))
else fprintf ff "step_ans";
fprintf ff ";@]@ }@ @]"

6
compiler/obc/java/javamain.ml Normal file
View file

@ -0,0 +1,6 @@
let program p =
let filename = filename_of_module p in
let dirname = build_path filename in
let dir = clean_dir dirname in
Java.print dir o

162
compiler/obc/obc.ml Normal file
View file

@ -0,0 +1,162 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Object code internal representation *)
open Misc
open Names
open Idents
open Types
open Signature
open Location
type class_name = qualname
type instance_name = qualname
type obj_name = name
type op_name = qualname
type type_dec =
{ t_name : qualname;
t_desc : tdesc;
t_loc : location }
and tdesc =
| Type_abs
| Type_alias of ty
| Type_enum of name list
| Type_struct of structure
type const_dec = {
c_name : qualname;
c_value : static_exp;
c_type : ty;
c_loc : location }
type lhs = { l_desc : lhs_desc; l_ty : ty; l_loc : location }
and lhs_desc =
| Lvar of var_ident
| Lmem of var_ident
| Lfield of lhs * field_name
| Larray of lhs * exp
and exp = { e_desc : exp_desc; e_ty : ty; e_loc : location }
and exp_desc =
| Elhs of lhs
| Econst of static_exp
| Eop of op_name * exp list
| Estruct of type_name * (field_name * exp) list
| Earray of exp list
type obj_call =
| Oobj of obj_name
| Oarray of obj_name * lhs
type method_name =
| Mreset
| Mstep
| Mmethod of name
type act =
| Aassgn of lhs * exp
| Acall of lhs list * obj_call * method_name * exp list
| Acase of exp * (constructor_name * block) list
| Afor of var_ident * static_exp * static_exp * block
and block =
{ b_locals : var_dec list;
b_body : act list }
and var_dec =
{ v_ident : var_ident;
v_type : ty; (* TODO should be here, v_controllable : bool*)
v_loc : location }
type obj_dec =
{ o_name : obj_name;
o_class : instance_name;
o_params : static_exp list;
o_size : static_exp option;
o_loc : location }
type method_def =
{ m_name : method_name;
m_inputs : var_dec list;
m_outputs : var_dec list;
m_body : block; }
type class_def =
{ cd_name : class_name;
cd_mems : var_dec list;
cd_objs : obj_dec list;
cd_params : param list;
cd_methods: method_def list;
cd_loc : location }
type program =
{ p_modname : name;
p_opened : name list;
p_types : type_dec list;
p_consts : const_dec list;
p_defs : class_def list }
let mk_var_dec ?(loc=no_location) name ty =
{ v_ident = name; v_type = ty; v_loc = loc }
let mk_exp ?(ty=invalid_type) ?(loc=no_location) desc =
{ e_desc = desc; e_ty = ty; e_loc = loc }
let mk_lhs ?(ty=invalid_type) ?(loc=no_location) desc =
{ l_desc = desc; l_ty = ty; l_loc = loc }
let mk_lhs_exp ?(ty=invalid_type) desc =
let lhs = mk_lhs ~ty:ty desc in
mk_exp ~ty:ty (Elhs lhs)
let mk_evar id =
mk_exp (Elhs (mk_lhs (Lvar id)))
let mk_block ?(locals=[]) eq_list =
{ b_locals = locals;
b_body = eq_list }
let rec var_name x =
match x.l_desc with
| Lvar x -> x
| Lmem x -> x
| Lfield(x,_) -> var_name x
| Larray(l, _) -> var_name 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_ident = 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.eprintf "Not found var %s@." (name n); raise Not_found
| vd::l ->
if vd.v_ident = n then vd else vd_find n l
let lhs_of_exp e = match e.e_desc with
| Elhs l -> l
| _ -> assert false
let find_step_method cd =
List.find (fun m -> m.m_name = Mstep) cd.cd_methods
let find_reset_method cd =
List.find (fun m -> m.m_name = Mreset) cd.cd_methods
let obj_call_name o =
match o with
| Oobj obj
| Oarray (obj, _) -> obj

206
compiler/obc/obc_mapfold.ml Normal file
View file

@ -0,0 +1,206 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Generic mapred over Obc Ast *)
open Misc
open Global_mapfold
open Obc
type 'a obc_it_funs = {
exp: 'a obc_it_funs -> 'a -> Obc.exp -> Obc.exp * 'a;
edesc: 'a obc_it_funs -> 'a -> Obc.exp_desc -> Obc.exp_desc * 'a;
lhs: 'a obc_it_funs -> 'a -> Obc.lhs -> Obc.lhs * 'a;
lhsdesc: 'a obc_it_funs -> 'a -> Obc.lhs_desc -> Obc.lhs_desc * 'a;
act: 'a obc_it_funs -> 'a -> Obc.act -> Obc.act * 'a;
block: 'a obc_it_funs -> 'a -> Obc.block -> Obc.block * 'a;
var_dec: 'a obc_it_funs -> 'a -> Obc.var_dec -> Obc.var_dec * 'a;
var_decs: 'a obc_it_funs -> 'a -> Obc.var_dec list
-> Obc.var_dec list * 'a;
obj_dec: 'a obc_it_funs -> 'a -> Obc.obj_dec -> Obc.obj_dec * 'a;
obj_decs: 'a obc_it_funs -> 'a -> Obc.obj_dec list
-> Obc.obj_dec list * 'a;
method_def: 'a obc_it_funs -> 'a -> Obc.method_def -> Obc.method_def * 'a;
class_def: 'a obc_it_funs -> 'a -> Obc.class_def -> Obc.class_def * 'a;
const_dec: 'a obc_it_funs -> 'a -> Obc.const_dec -> Obc.const_dec * 'a;
type_dec: 'a obc_it_funs -> 'a -> Obc.type_dec -> Obc.type_dec * 'a;
tdesc: 'a obc_it_funs -> 'a -> Obc.tdesc -> Obc.tdesc * 'a;
program: 'a obc_it_funs -> 'a -> Obc.program -> Obc.program * 'a;
global_funs:'a Global_mapfold.global_it_funs }
let rec exp_it funs acc e = funs.exp funs acc e
and exp funs acc e =
let ed, acc = edesc_it funs acc e.e_desc in
{ e with e_desc = ed }, acc
and edesc_it funs acc ed =
try funs.edesc funs acc ed
with Fallback -> edesc funs acc ed
and edesc funs acc ed = match ed with
| Elhs l ->
let l, acc = lhs_it funs acc l in
Elhs l, acc
| Econst se ->
let se, acc = static_exp_it funs.global_funs acc se in
Econst se, acc
| Eop (op, args) ->
let args, acc = mapfold (exp_it funs) acc args in
Eop (op, args), acc
| Estruct(tyn, f_e_list) ->
let aux acc (f,e) =
let e, acc = exp_it funs acc e in
(f,e), acc in
let f_e_list, acc = mapfold aux acc f_e_list in
Estruct(tyn, f_e_list), acc
| Earray args ->
let args, acc = mapfold (exp_it funs) acc args in
Earray args, acc
and lhs_it funs acc l = funs.lhs funs acc l
and lhs funs acc l =
let ld, acc = lhsdesc_it funs acc l.l_desc in
{ l with l_desc = ld }, acc
and lhsdesc_it funs acc ld =
try funs.lhsdesc funs acc ld
with Fallback -> lhsdesc funs acc ld
and lhsdesc funs acc ld = match ld with
| Lvar x -> Lvar x, acc
| Lmem x -> Lmem x, acc
| Lfield(lhs, f) ->
let lhs, acc = lhs_it funs acc lhs in
Lfield(lhs, f), acc
| Larray(lhs, e) ->
let lhs, acc = lhs_it funs acc lhs in
let e, acc = exp_it funs acc e in
Larray(lhs, e), acc
and act_it funs acc a =
try funs.act funs acc a
with Fallback -> act funs acc a
and act funs acc a = match a with
| Aassgn(lhs, e) ->
let lhs, acc = lhs_it funs acc lhs in
let e, acc = exp_it funs acc e in
Aassgn(lhs, e), acc
| Acall(lhs_list, obj, n, args) ->
let lhs_list, acc = mapfold (lhs_it funs) acc lhs_list in
let args, acc = mapfold (exp_it funs) acc args in
Acall(lhs_list, obj, n, args), acc
| Acase(x, c_b_list) ->
let aux acc (c,b) =
let b, acc = block_it funs acc b in
(c,b), acc in
let c_b_list, acc = mapfold aux acc c_b_list in
Acase(x, c_b_list), acc
| Afor(x, idx1, idx2, b) ->
let idx1, acc = static_exp_it funs.global_funs acc idx1 in
let idx2, acc = static_exp_it funs.global_funs acc idx2 in
let b, acc = block_it funs acc b in
Afor(x, idx1, idx2, b), acc
and block_it funs acc b = funs.block funs acc b
and block funs acc b =
let b_locals, acc = var_decs_it funs acc b.b_locals in
let b_body, acc = mapfold (act_it funs) acc b.b_body in
{ b with b_locals = b_locals; b_body = b_body }, acc
and var_dec_it funs acc vd = funs.var_dec funs acc vd
and var_dec funs acc vd =
let v_type, acc = ty_it funs.global_funs acc vd.v_type in
{ vd with v_type = v_type }, acc
and var_decs_it funs acc vds = funs.var_decs funs acc vds
and var_decs funs acc vds = mapfold (var_dec_it funs) acc vds
and obj_dec_it funs acc od = funs.obj_dec funs acc od
and obj_dec funs acc od =
let o_size, acc = optional_wacc
(static_exp_it funs.global_funs) acc od.o_size in
{ od with o_size = o_size }, acc
and obj_decs_it funs acc ods = funs.obj_decs funs acc ods
and obj_decs funs acc ods = mapfold (obj_dec_it funs) acc ods
and method_def_it funs acc md = funs.method_def funs acc md
and method_def funs acc md =
let m_inputs, acc = var_decs_it funs acc md.m_inputs in
let m_outputs, acc = var_decs_it funs acc md.m_outputs in
let m_body, acc = block_it funs acc md.m_body in
{ md with
m_inputs = m_inputs; m_outputs = m_outputs; m_body = m_body }
, acc
and class_def_it funs acc cd = funs.class_def funs acc cd
and class_def funs acc cd =
let cd_mems, acc = var_decs_it funs acc cd.cd_mems in
let cd_objs, acc = obj_decs_it funs acc cd.cd_objs in
let cd_params, acc = mapfold (param_it funs.global_funs) acc cd.cd_params in
let cd_methods, acc = mapfold (method_def_it funs) acc cd.cd_methods in
{ cd with
cd_mems = cd_mems; cd_objs = cd_objs;
cd_params = cd_params; cd_methods = cd_methods }
, acc
and const_dec_it funs acc c = funs.const_dec funs acc c
and const_dec funs acc c =
let ty, acc = ty_it funs.global_funs acc c.c_type in
let se, acc = static_exp_it funs.global_funs acc c.c_value in
{ c with c_type = ty; c_value = se }, acc
and type_dec_it funs acc t = funs.type_dec funs acc t
and type_dec funs acc t =
let tdesc, acc = tdesc_it funs acc t.t_desc in
{ t with t_desc = tdesc }, acc
and tdesc_it funs acc td =
try funs.tdesc funs acc td
with Fallback -> tdesc funs acc td
and tdesc funs acc td = match td with
| Type_struct s ->
let s, acc = structure_it funs.global_funs acc s in
Type_struct s, acc
| _ -> td, acc
and program_it funs acc p = funs.program funs acc p
and program funs acc p =
let td_list, acc = mapfold (type_dec_it funs) acc p.p_types in
let cd_list, acc = mapfold (const_dec_it funs) acc p.p_consts in
let nd_list, acc = mapfold (class_def_it funs) acc p.p_defs in
{ p with p_types = td_list; p_consts = cd_list; p_defs = nd_list }, acc
let defaults = {
lhs = lhs;
lhsdesc = lhsdesc;
exp = exp;
edesc = edesc;
act = act;
block = block;
var_dec = var_dec;
var_decs = var_decs;
obj_dec = obj_dec;
obj_decs = obj_decs;
method_def = method_def;
class_def = class_def;
const_dec = const_dec;
type_dec = type_dec;
tdesc = tdesc;
program = program;
global_funs = Global_mapfold.defaults }

197
compiler/obc/obc_printer.ml Normal file
View file

@ -0,0 +1,197 @@
open Obc
open Format
open Pp_tools
open Types
open Idents
open Names
open Global_printer
let print_vd ff vd =
fprintf ff "@[<v>";
print_ident ff vd.v_ident;
fprintf ff ": ";
print_type ff vd.v_type;
fprintf ff "@]"
let print_obj ff o =
fprintf ff "@[<v>"; print_name ff o.o_name;
fprintf ff " : "; print_qualname ff o.o_class;
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "<<"","">>") o.o_params;
(match o.o_size with
| Some se -> fprintf ff "[%a]" print_static_exp se
| None -> ());
fprintf ff "@]"
let rec print_lhs ff e =
match e.l_desc with
| Lvar x -> print_ident ff x
| Lmem x -> fprintf ff "mem("; print_ident ff x; fprintf ff ")"
| Lfield (l, f) -> print_lhs ff l; fprintf ff ".%s" (shortname f)
| Larray(x, idx) ->
print_lhs ff x;
fprintf ff "[";
print_exp ff idx;
fprintf ff "]"
and print_exps ff e_list = print_list_r print_exp "" "," "" ff e_list
and print_exp ff e =
match e.e_desc with
| Elhs lhs -> print_lhs ff lhs
| Econst c -> print_static_exp ff c
| Eop(op, e_list) -> print_op ff op e_list
| Estruct(_,f_e_list) ->
fprintf ff "@[<v 1>";
print_list_r
(fun ff (field, e) -> print_qualname ff field;fprintf ff " = ";
print_exp ff e)
"{" ";" "}" ff f_e_list;
fprintf ff "@]"
| Earray e_list ->
fprintf ff "@[";
print_list_r print_exp "[" ";" "]" ff e_list;
fprintf ff "@]"
and print_op ff op e_list = match e_list with
| [l; r] ->
fprintf ff "(@[%a@ %a %a@])" print_qualname op print_exp l print_exp r
| _ ->
print_qualname ff op;
print_list_l print_exp "(" "," ")" ff e_list
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 print_obj_call ff = function
| Oobj o -> print_name ff o
| Oarray (o, i) ->
fprintf ff "%a[%a]"
print_name o
print_lhs i
let print_method_name ff = function
| Mstep -> fprintf ff "step"
| Mreset -> fprintf ff "reset"
| Mmethod n -> fprintf ff "%s" n
let rec print_act ff a =
match a with
| Aassgn (x, e) -> print_asgn ff "" x e
| Acase(e, tag_act_list) ->
fprintf ff "@[<v>@[<hv 2>switch (";
print_exp ff e; fprintf ff ") {@ ";
print_tag_act_list ff tag_act_list;
fprintf ff "@]@,}@]"
| Afor(x, i1, i2, act_list) ->
fprintf ff "@[<v>@[<v 2>for %s = %a to %a {@, %a @]@,}@]"
(name x)
print_static_exp i1
print_static_exp i2
print_block act_list
| Acall (var_list, o, meth, es) ->
let print_lhs_tuple ff var_list = match var_list with
| [] -> ()
| _ ->
fprintf ff "@[(%a)@] =@ "
(print_list print_lhs "" "," "") var_list in
fprintf ff "@[<2>%a%a.%a(%a)@]"
print_lhs_tuple var_list
print_obj_call o
print_method_name meth
print_exps es
and print_var_dec_list ff var_dec_list = match var_dec_list with
| [] -> ()
| _ ->
fprintf ff "@[<hov 4>%a@]@ "
(print_list_r print_vd "var " ";" ";") var_dec_list
and print_block ff b =
fprintf ff "@[<v>%a%a@]"
print_var_dec_list b.b_locals
(print_list_r print_act "" ";" "") b.b_body
and print_tag_act_list ff tag_act_list =
print_list
(fun ff (tag, a) ->
fprintf ff "@[<v 2>case %a:@ %a@]"
print_qualname tag
print_block a)
"" "" "" ff tag_act_list
let print_method_name ff = function
| Mreset -> fprintf ff "reset"
| Mstep -> fprintf ff "step"
| Mmethod n -> fprintf ff "%s" n
let print_arg_list ff var_list =
fprintf ff "(@[%a@])" (print_list_r print_vd "" "," "") var_list
let print_method ff md =
fprintf ff "@[<v 2>@[%a%a@ returns %a {@]@ %a@]@\n}"
print_method_name md.m_name
print_arg_list md.m_inputs
print_arg_list md.m_outputs
print_block md.m_body
let print_class_def ff
{ cd_name = id; cd_mems = mem; cd_objs = objs; cd_methods = m_list } =
fprintf ff "@[<v 2>machine "; print_qualname ff id; fprintf ff " =@,";
if mem <> [] then begin
fprintf ff "@[<hov 4>var ";
print_list_r print_vd "" ";" "" ff mem;
fprintf ff ";@]@,"
end;
if objs <> [] then begin
fprintf ff "@[<hov 4>obj ";
print_list print_obj "" ";" "" ff objs;
fprintf ff ";@]@,"
end;
if mem <> [] || objs <> [] then fprintf ff "@,";
print_list_r print_method "" "\n" "" ff m_list;
fprintf ff "@]"
let print_type_def ff { t_name = name; t_desc = tdesc } =
match tdesc with
| Type_abs -> fprintf ff "@[type %a@\n@]" print_qualname name
| Type_alias ty ->
fprintf ff "@[type %a@ = %a@\n@]" print_qualname name print_type ty
| Type_enum(tag_name_list) ->
fprintf ff "@[type %a = " print_qualname name;
print_list_r print_name "" "|" "" ff tag_name_list;
fprintf ff "@\n@]"
| Type_struct(f_ty_list) ->
fprintf ff "@[type %a = " print_qualname name;
fprintf ff "@[<v 1>";
print_list
(fun ff { Signature.f_name = field; Signature.f_type = ty } ->
print_qualname ff field;
fprintf ff ": ";
print_type ff ty) "{" ";" "}" ff f_ty_list;
fprintf ff "@]@.@]"
let print_open_module ff name =
fprintf ff "@[open ";
print_name ff name;
fprintf ff "@.@]"
let print_const_dec ff c =
fprintf ff "const %a = %a@." print_qualname c.c_name
print_static_exp c.c_value
let print_prog ff { p_opened = modules; p_types = types;
p_consts = consts; p_defs = defs } =
List.iter (print_open_module ff) modules;
List.iter (print_type_def ff) types;
List.iter (print_const_dec ff) consts;
fprintf ff "@\n";
List.iter (fun def -> (print_class_def ff def; fprintf ff "@\n@\n")) defs
let print oc p =
let ff = formatter_of_out_channel oc in
fprintf ff "@[-- Code generated by the MiniLucid Compiler@.";
fprintf ff "@[<v>"; print_prog ff p; fprintf ff "@]@]@."

71
compiler/obc/obc_utils.ml Normal file
View file

@ -0,0 +1,71 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
open Names
open Misc
open Types
open Obc
open Obc_mapfold
open Global_mapfold
module Deps =
struct
let deps_longname deps { qual = modn; } = S.add modn deps
let deps_static_exp_desc funs deps sedesc =
let (sedesc, deps) = Global_mapfold.static_exp_desc funs deps sedesc in
match sedesc with
| Svar ln -> (sedesc, deps_longname deps ln)
| Sconstructor ln -> (sedesc, deps_longname deps ln)
| Srecord fnel ->
let add deps (ln, _) = deps_longname deps ln in
(sedesc, List.fold_left add deps fnel)
| Sop (ln, _) -> (sedesc, deps_longname deps ln)
| _ -> raise Fallback
let deps_lhsdesc funs deps ldesc =
let (ldesc, deps) = Obc_mapfold.lhsdesc funs deps ldesc in
match ldesc with
| Lfield (_, ln) -> (ldesc, deps_longname deps ln)
| _ -> raise Fallback
let deps_edesc funs deps edesc =
let (edesc, deps) = Obc_mapfold.edesc funs deps edesc in
match edesc with
| Eop (ln, _) -> (edesc, deps_longname deps ln)
| Estruct (ln, fnel) ->
let add deps (ln, _) = deps_longname deps ln in
(edesc, List.fold_left add (deps_longname deps ln) fnel)
| _ -> raise Fallback
let deps_act funs deps act =
let (act, deps) = Obc_mapfold.act funs deps act in
match act with
| Acase (_, cbl) ->
let add deps (ln, _) = deps_longname deps ln in
(act, List.fold_left add deps cbl)
| _ -> raise Fallback
let deps_obj_dec funs deps od =
let (od, deps) = Obc_mapfold.obj_dec funs deps od in
(od, deps_longname deps od.o_class)
let deps_program p =
let funs = { Obc_mapfold.defaults with
global_funs = { Global_mapfold.defaults with
static_exp_desc = deps_static_exp_desc; };
lhsdesc = deps_lhsdesc;
edesc = deps_edesc;
act = deps_act;
obj_dec = deps_obj_dec;
} in
let (_, deps) = Obc_mapfold.program funs S.empty p in
S.remove p.p_modname (S.remove "Pervasives" deps)
end

2
compiler/preproc.ml
View file

@ -24,7 +24,7 @@ let date =
let prefix s = String.sub s 0 3 in
(prefix days.(tm.tm_wday), prefix months.(tm.tm_mon)) in
Printf.sprintf "%s. %s. %d %d:%d:%d CET %d"
Format.sprintf "%s. %s. %d %d:%d:%d CET %d"
day month tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec (1900 + tm.tm_year)

58
compiler/utilities/global/compiler_utils.ml
View file

@ -8,40 +8,42 @@
(**************************************************************************)
open Misc
open Location
open Minils
let lexical_error err loc =
Printf.eprintf "%aIllegal character.\n" output_location loc;
Format.eprintf "%aIllegal character.@." print_location loc;
raise Error
let syntax_error loc =
Printf.eprintf "%aSyntax error.\n" output_location loc;
Format.eprintf "%aSyntax error.@." print_location loc;
raise Error
let language_error lang =
Printf.eprintf "Unknown language: %s.\n" lang
Format.eprintf "Unknown language: '%s'.@." lang
let comment s =
if !verbose then Printf.printf "** %s done **\n" s; flush stdout
let separateur = "\n*********************************************\
*********************************\n*** "
let comment ?(sep=separateur) s =
if !verbose then Format.printf "%s%s@." sep s
let do_pass f d p pp enabled =
let do_pass d f p pp =
comment (d^" ...\n");
let r = f p in
pp r;
comment ~sep:"*** " (d^" done.");
r
let do_silent_pass d f p = do_pass d f p (fun x -> ())
let pass d enabled f p pp =
if enabled
then
let r = f p in
if !verbose
then begin
comment d;
pp r;
end;
r
then do_pass d f p pp
else p
let do_silent_pass f d p enabled =
let silent_pass d enabled f p =
if enabled
then begin
let r = f p in
if !verbose then comment d; r
end
then do_silent_pass d f p
else p
let build_path suf =
@ -49,6 +51,9 @@ let build_path suf =
| None -> suf
| Some path -> Filename.concat path suf
let filename_of_name n =
String.uncapitalize n
let clean_dir dir =
if Sys.file_exists dir && Sys.is_directory dir
then begin
@ -57,19 +62,29 @@ let clean_dir dir =
end else Unix.mkdir dir 0o740;
dir
let init_compiler modname source_name ic =
Location.initialize source_name ic;
let init_compiler modname =
Modules.initialize modname;
Initial.initialize ()
let lexbuf_from_file file_name =
let ic = open_in file_name in
let lexbuf = Lexing.from_channel ic in
lexbuf.Lexing.lex_curr_p <-
{ lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = file_name };
ic, lexbuf
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 = "<dir>\t\tAdd <dir> to the list of include directories"
and doc_stdlib = "<dir>\t\tDirectory for the standard library"
and doc_object_file = "\t\tOnly generate a .epo object file"
and doc_sim = "<node>\t\tCreate simulation for node <node>"
and doc_locate_stdlib = "\t\tLocate standard libray"
and doc_no_pervasives = "\tDo not load the pervasives module"
and doc_flatten = "\t\tInline everything."
and doc_target =
"<lang>\tGenerate code in language <lang>\n\t\t\t(with <lang>=c,"
^ " java or z3z)"
@ -79,6 +94,7 @@ and doc_target_path =
^ " cleaned)"
and doc_noinit = "\t\tDisable initialization analysis"
and doc_assert = "<node>\t\tInsert run-time assertions for boolean node <node>"
and doc_inline = "<node>\t\tInline node <node>"
let errmsg = "Options are:"

2
compiler/utilities/global/dep.ml
View file

@ -9,7 +9,7 @@
(* dependences between equations *)
open Graph
open Ident
open Idents
module type READ =
sig

5
compiler/utilities/graph.ml
View file

@ -7,7 +7,7 @@
(* *)
(**************************************************************************)
(* graph manipulation *)
(* $Id$ *)
type 'a graph =
{ g_top: 'a node list;
g_bot: 'a node list }
@ -127,6 +127,7 @@ let accessible useful_nodes g_list =
let exists_path nodes n1 n2 =
List.mem n2 (accessible [n1] nodes)
(*
open Format
let print_node print g =
@ -142,5 +143,5 @@ let print_node print g =
printf "@]@ ")
g.g_depends_on;
printf "@]"
*)

85
compiler/utilities/misc.ml
View file

@ -35,10 +35,10 @@ let locate_stdlib () =
Sys.getenv "HEPTLIB"
with
Not_found -> standard_lib in
Printf.printf "Standard library in %s\n" stdlib
Format.printf "Standard library in %s@." stdlib
let show_version () =
Printf.printf "The Heptagon compiler, version %s (%s)\n"
Format.printf "The Heptagon compiler, version %s (%s)@."
version date;
locate_stdlib ()
@ -55,6 +55,8 @@ let set_simulation_node s =
simulation := true;
simulation_node := Some s
let create_object_file = ref false
(* Target languages list for code generation *)
let target_languages : string list ref = ref []
@ -79,6 +81,12 @@ let cse = ref false
let tomato = ref false
let inline = ref []
let add_inlined_node s = inline := s :: !inline
let flatten = ref false
(* Backward compatibility *)
let set_sigali () = add_target_language "z3z";;
@ -100,6 +108,10 @@ let optional f = function
| None -> None
| Some x -> Some (f x)
let optional_wacc f acc = function
| None -> None, acc
| Some x -> let x, acc = f acc x in Some x, acc
let optunit f = function
| None -> ()
| Some x -> f x
@ -167,6 +179,16 @@ let rec split_last = function
let remove x l =
List.filter (fun y -> x <> y) l
let make_list_compare c l1 l2 =
let rec aux l1 l2 = match (l1, l2) with
| (h1::t1, h2::t2) ->
let result = c h1 h2 in
if result = 0 then aux t1 t2 else result
| ([], [] ) -> 0
| (_, [] ) -> 1
| ([], _ ) -> -1
in aux l1 l2
let is_empty = function
| [] -> true
| _ -> false
@ -192,3 +214,62 @@ let rec assocd value = function
k
else
assocd value l
(** { 3 Compiler iterators } *)
exception Fallback
(** Mapfold *)
let mapfold f acc l =
let l,acc = List.fold_left
(fun (l,acc) e -> let e,acc = f acc e in e::l, acc)
([],acc) l in
List.rev l, acc
let mapfold_right f l acc =
List.fold_right (fun e (acc, l) -> let acc, e = f e acc in (acc, e :: l))
l (acc, [])
let mapi f l =
let rec aux i = function
| [] -> []
| v::l -> (f i v)::(aux (i+1) l)
in
aux 0 l
let mapi2 f l1 l2 =
let rec aux i l1 l2 =
match l1, l2 with
| [], [] -> []
| [], _ -> invalid_arg ""
| _, [] -> invalid_arg ""
| v1::l1, v2::l2 -> (f i v1 v2)::(aux (i+1) l1 l2)
in
aux 0 l1 l2
let mapi3 f l1 l2 l3 =
let rec aux i l1 l2 l3 =
match l1, l2, l3 with
| [], [], [] -> []
| [], _, _ -> invalid_arg ""
| _, [], _ -> invalid_arg ""
| _, _, [] -> invalid_arg ""
| v1::l1, v2::l2, v3::l3 ->
(f i v1 v2 v3)::(aux (i+1) l1 l2 l3)
in
aux 0 l1 l2 l3
exception Cannot_find_file of string
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

39
compiler/utilities/misc.mli
View file

@ -52,6 +52,9 @@ val simulation_node : string option ref
(* Set the simulation mode on *)
val set_simulation_node : string -> unit
(* If it is true, the compiler will only generate an object file (.epo).
Otherwise, it will generate obc code and possibily other targets.*)
val create_object_file : bool ref
(* List of target languages *)
val target_languages : string list ref
(* Add target language to the list *)
@ -80,6 +83,13 @@ val cse : bool ref
(* Automata minimization *)
val tomato : bool ref
(* List of nodes to inline *)
val inline : string list ref
(* Add a new node name to the list of nodes to inline. *)
val add_inlined_node : string -> unit
(* Inline every node. *)
val flatten : bool ref
(* Z/3Z back-end mode *)
val set_sigali : unit -> unit
@ -106,6 +116,8 @@ val use_new_reset_encoding : bool ref
(* Misc. functions *)
val optional : ('a -> 'b) -> 'a option -> 'b option
(** Optional with accumulator *)
val optional_wacc : ('a -> 'b -> 'c*'a) -> 'a -> 'b option -> ('c option * 'a)
val optunit : ('a -> unit) -> 'a option -> unit
val split_string : string -> char -> string list
@ -151,5 +163,30 @@ val repeat_list : 'a -> int -> 'a list
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
val assocd : 'b -> ('a * 'b) list -> 'a
(** [make_compare c] generates the lexicographical compare function on lists
induced by [c] *)
val make_list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int
(** Ast iterators *)
exception Fallback
(** Mapfold *)
val mapfold: ('a -> 'b -> 'c * 'a) -> 'a -> 'b list -> 'c list * 'a
(** Mapfold, right version. *)
val mapfold_right
: ('a -> 'acc -> 'acc * 'b) -> 'a list -> 'acc -> 'acc * 'b list
(** Mapi *)
val mapi: (int -> 'a -> 'b) -> 'a list -> 'b list
val mapi2: (int -> 'a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
val mapi3: (int -> 'a -> 'b -> 'c -> 'd) ->
'a list -> 'b list -> 'c list -> 'd list
exception Cannot_find_file of string
val findfile : string -> string

42
compiler/utilities/pp_tools.ml
View file

@ -53,38 +53,16 @@ let print_record print_field ff record =
let print_type_params ff pl =
print_list_r (fun ff s -> fprintf ff "'%s" s) "("","") " ff pl
fprintf ff "@[%a@]"
(print_list_r (fun ff s -> fprintf ff "'%s" s) "("","") ") pl
(* Map and Set redefinition to allow pretty printing
let print_set iter print_element ff set =
fprintf ff "@[{@ ";
iter (fun e -> fprintf ff "%a@ " print_element e) set;
fprintf ff "}@]"
module type P = sig
type t
val fprint : Format.formatter -> t -> unit
end
module type ELT = sig
type t
val compare : t -> t -> int
val fprint : Format.formatter -> t -> unit
end
module SetMake (Elt : ELT) = struct
module M = Set.Make(Elt)
include M
let fprint ff es =
Format.fprintf ff "@[<hov>{@ ";
iter (fun e -> Format.fprintf ff "%a@ " Elt.fprint e) es;
Format.fprintf ff "}@]";
end
module MapMake (Key : ELT) (Elt : P) = struct
module M = Map.Make(Key)
include M
let fprint prp eem =
Format.fprintf prp "[@[<hv 2>";
iter (fun k m ->
Format.fprintf prp "@ | %a -> %a" Key.fprint k Elt.fprint m) eem;
Format.fprintf prp "@]@ ]";
end
*)
let print_map iter print_key print_element ff map =
fprintf ff "@[<hv 2>[@ ";
iter (fun k x -> fprintf ff "| %a -> %a@ " print_key k print_element x) map;
fprintf ff "]@]"

35
examples/MissionComputer_for_Core/cstArrayInit.epi Normal file
View file

@ -0,0 +1,35 @@
open TypeTracks
open TypeBase
const kinitifftrackarray : TypeArray.tifftracksarray =
{ i_pos = { x = 0.0; y = 0.0 }; i_id = 0 } ^ TypeArray.ksizeifftracksarray
const kinitmissiontrackarray : TypeArray.tmissiontracksarray =
{ m_pos = { x = 0.0;
y = 0.0 };
m_speed = { sx = 0.0;
sy = 0.0 };
m_id = 0;
m_priority = 0;
m_d = 0.0;
m_sabs = 0.0;
m_sr = 0.0;
m_detectedbyradar = false;
m_detectedbyiff = false;
m_tracknumber = 0;
m_targettype = TypeBase.Ttargettype_unknown;
m_isvisible = false;
m_angle = 0.0 } ^ TypeArray.ksizemissiontracksarray
const kinitrdrtrackarray : TypeArray.trdrtracksarray =
{ r_pos = { x = 0.0;
y = 0.0 };
r_s = { sx = 0.0;
sy = 0.0 };
r_d = 0.0;
r_sabs = 0.0;
r_sr = 0.0 } ^ TypeArray.ksizerdrtracksarray
const kinittrackarray : TypeArray.ttracksarray =
{ t_pos = { x = 0.0; y = 0.0 }; t_id = 0 } ^ TypeArray.ksizetracksarray

4
examples/MissionComputer_for_Core/cstBaseInit.epi Normal file
View file

@ -0,0 +1,4 @@
open TypeBase
const kInitPosition : TypeBase.tposition = { x = 0.0; y = 0.0 }
const kInitSpeed : TypeBase.tspeed = { sx = 0.0; sy = 0.0 }

4
examples/MissionComputer_for_Core/cstPhysics.epi Normal file
View file

@ -0,0 +1,4 @@
const nm : float = 1852.0
const t : float = 0.01
const pi : float = 3.141592

34
examples/MissionComputer_for_Core/cstTracksInit.epi Normal file
View file

@ -0,0 +1,34 @@
open TypeTracks
open TypeBase
const kinittrack : TypeTracks.ttrack = { t_pos = { x = 0.0;
y = 0.0 };
t_id = 0 }
const kinitrdrtrack : TypeTracks.trdrtrack = { r_pos = { x = 0.0;
y = 0.0 };
r_s = { sx = 0.0;
sy = 0.0 };
r_d = 0.0;
r_sabs = 0.0;
r_sr = 0.0 }
const kinitmissiontrack : TypeTracks.tmissiontrack = { m_pos = { x = 0.0;
y = 0.0 };
m_speed = { sx = 0.0;
sy = 0.0 };
m_id = 0;
m_priority = 0;
m_d = 0.0;
m_sabs = 0.0;
m_sr = 0.0;
m_detectedbyradar = false;
m_detectedbyiff = false;
m_tracknumber = 0;
m_targettype = TypeBase.Ttargettype_unknown;
m_isvisible = false;
m_angle = 0.0 }
const kinitifftrack : TypeTracks.tifftrack = { i_pos = { x = 0.0;
y = 0.0 };
i_id = 0 }

44
examples/MissionComputer_for_Core/debug.ept Normal file
View file

@ -0,0 +1,44 @@
open Mc
open Mc_TypeSensors
(* Top node of the Mission Computer SCADE model.
The Fighter (MC + Radar + Iff), its environment
(CreateTracks) and links to the graphical interface (GUI)
are constituting this model. *)
node fighterdebug(res, rdronoffclicked, iffonoffclicked : bool)
returns (missiontracks : TypeArray.tmissiontracksarray)
var
l4 : TypeArray.trdrtracksarray;
l3 : trdrmode;
l6 : TypeArray.tifftracksarray;
l5 : tsensorstate;
l12, l11, l10 : bool;
l172 : tsensorstate;
l179 : TypeArray.ttracksarray;
l200, l201:bool; (*TODO*)
let
l179 = createalltracks(res);
(l10, l11, missiontracks, l12) =
mc(l172, l3, l4, rdronoffclicked, false, iffonoffclicked, l5, l6);
(l5, l6, l200) = iff(l179, false, [1, 2, 3], false -> pre l12);
(l201, l172, l3, l4) =
radar(false -> pre l10, false -> pre l11, false, [0, 1, 2, 3, 4],
l179);
tel
(* top node of the mission computer scade model.
the fighter (mc + radar + iff), its environment
(createtracks) and links to the graphical interface (gui)
are constituting this model. *)
node dv_fighterdebug(res, rdronoffclicked, iffonoffclicked : bool)
returns (proof3 : bool)
let
proof3 =
Dv.dv_proof3(fighterdebug(res, rdronoffclicked, iffonoffclicked));
tel
fun dv_debug(missiontracks : TypeArray.tmissiontracksarray)
returns (proof3 : bool)
let
proof3 = Dv.dv_proof3(missiontracks);
tel

7
examples/MissionComputer_for_Core/digital.ept Normal file
View file

@ -0,0 +1,7 @@
(* Detects a rising edge (false to true transition ).
The output is true during the transition clock cycle.
The output is initialized to false. *)
node risingEdge(re_Input : bool) returns (re_Output : bool)
let
re_Output = not (re_Input -> pre re_Input) & re_Input;
tel

82
examples/MissionComputer_for_Core/dv.ept Normal file
View file

@ -0,0 +1,82 @@
open TypeArray
open CstArrayInit
open Mc_TypeSensors
open Mc
fun dv_detectedbyiff(missiontrack : TypeTracks.tmissiontrack; accin : bool)
returns (accout : bool)
let
accout = accin & not (missiontrack.m_tracknumber <> 0);
tel
fun dv_sametracknumber(missiontrack1,
missiontrack2 : TypeTracks.tmissiontrack;
accin : bool)
returns (accout : bool)
let
accout =
accin or
missiontrack1.m_tracknumber = missiontrack2.m_tracknumber &
missiontrack2.m_tracknumber <> 0;
tel
fun dv_tracknumberexist(missiontrack : TypeTracks.tmissiontrack;
missiontracks : TypeArray.tmissiontracksarray;
accin : bool)
returns (accout : bool)
var l36 : bool;
let
l36 =
fold dv_sametracknumber <<ksizemissiontracksarray>>(
missiontrack^ksizemissiontracksarray, missiontracks, false);
accout = accin or l36;
tel
node dv_proof1(currentrdrstate : tsensorstate;
rdronoffbutton, rdronoffcmd : bool)
returns (proof1 : bool)
let
proof1 =
Verif.implies(Digital.risingEdge(rdronoffbutton) &
currentrdrstate = TState_FAIL, rdronoffcmd =
(false -> pre rdronoffcmd));
tel
fun dv_proof2(ifftracks : TypeArray.tifftracksarray;
missiontracks : TypeArray.tmissiontracksarray)
returns (proof2 : bool)
var l33 : bool;
let
l33 =
fold dv_detectedbyiff <<ksizemissiontracksarray>>(missiontracks, true);
proof2 = Verif.implies(ifftracks = kinitifftrackarray, l33);
tel
(* verifiy that all non null tracknumbers are different *)
fun dv_proof3(missiontracks : TypeArray.tmissiontracksarray)
returns (proof3 : bool)
var l33 : bool;
let
l33 =
fold dv_tracknumberexist <<ksizemissiontracksarray>>(
missiontracks, missiontracks^ksizemissiontracksarray, false);
proof3 = not l33;
tel
node dv_observer(currentrdrstate : tsensorstate;
currentrdrmode : trdrmode;
rdrtracks : TypeArray.trdrtracksarray;
rdronoffbutton, rdrmodebutton, iffonoffbutton : bool;
currentiffstate : tsensorstate;
ifftracks : TypeArray.tifftracksarray)
returns (proof1, proof2, proof3 : bool)
var l3 : TypeArray.tmissiontracksarray; l1,l4,l5 : bool;
let
proof3 = dv_proof3(l3);
proof2 = dv_proof2(ifftracks, l3);
proof1 = dv_proof1(currentrdrstate, rdronoffbutton, l1);
(l1, l4, l3, l5) =
mc(currentrdrstate, currentrdrmode, rdrtracks, rdronoffbutton,
rdrmodebutton, iffonoffbutton, currentiffstate, ifftracks);
tel

12
examples/MissionComputer_for_Core/math.ept Normal file
View file

@ -0,0 +1,12 @@
fun abs(a : float) returns (o : float)
let
o = if 0.0 <=. a then a else -. a;
tel
(* -- Returns 1.0 if input is greater than 0.0,
-- -1.0 if input is less than 0.0
-- and 0.0 if input is equal to 0.0 *)
fun sign(a : float) returns (o : float)
let
o = if a >. 0.0 then 1.0 else if 0.0 =. a then 0.0 else -. 1.0;
tel

14
examples/MissionComputer_for_Core/mathext.c Normal file
View file

@ -0,0 +1,14 @@
#include <math.h>
#include "mathext.h"
#define WRAP_FUN_DEF(FNAME, CNAME, TY_IN, TY_OUT) \
void FNAME ## _step(TY_IN a, FNAME ## _out *out) { \
out->o = CNAME(a); \
}
WRAP_FUN_DEF(atanr, atan, float, float)
WRAP_FUN_DEF(acosr, acos, float, float)
WRAP_FUN_DEF(cosr, cos, float, float)
WRAP_FUN_DEF(asinr, asin, float, float)
WRAP_FUN_DEF(sinr, sin, float, float)
WRAP_FUN_DEF(sqrtr, sqrt, float, float)

17
examples/MissionComputer_for_Core/mathext.epi Normal file
View file

@ -0,0 +1,17 @@
(* atan() *)
val fun atanr(a : float) returns (o : float)
(* acos() *)
val fun acosr(a : float) returns (o : float)
(* cos() *)
val fun cosr(a : float) returns (o : float)
(* asin() *)
val fun asinr(a : float) returns (o : float)
(* sin() *)
val fun sinr(a : float) returns (o : float)
(* sqrt() *)
val fun sqrtr(a : float) returns (o : float)

18
examples/MissionComputer_for_Core/mathext.h Normal file
View file

@ -0,0 +1,18 @@
#ifndef MATHEXT_H
#define MATHEXT_H
#define WRAP_FUN_DECL(FNAME, TY_IN, TY_OUT) \
typedef struct { \
TY_OUT o; \
} FNAME ## _out; \
\
void FNAME ## _step(TY_IN, FNAME ## _out *)
WRAP_FUN_DECL(atanr, float, float);
WRAP_FUN_DECL(acosr, float, float);
WRAP_FUN_DECL(cosr, float, float);
WRAP_FUN_DECL(asinr, float, float);
WRAP_FUN_DECL(sinr, float, float);
WRAP_FUN_DECL(sqrtr, float, float);
#endif

484
examples/MissionComputer_for_Core/mc.ept Normal file
View file

@ -0,0 +1,484 @@
open CstArrayInit
open Mc_TypeSensors
open Mc_ext
open TypeTracks
open TypeBase
open TypeArray
const trackarrayinit : bool = false
(* safe state machine for the computing of radar or iff state
state ident: state.0 *)
node statecmd(onoffbuttonpressed : bool (*last = false*);
currentstate : tsensorstate)
returns (onoffcmd : bool)
let
automaton
state Off
do onoffcmd = false;
unless onoffbuttonpressed & currentstate = TState_OFF then On
state On
do onoffcmd = true;
unless onoffbuttonpressed & currentstate = TState_ON then Off
end
tel
(* compute the new radar state each time on/off button
is pressed *)
node mc_rdrstatecmd(rdronoffbutton : bool; currentrdrstate : tsensorstate)
returns (rdronoffcmd : bool)
let
rdronoffcmd =
statecmd(Digital.risingEdge(rdronoffbutton), currentrdrstate);
tel
(* compute the new iff state each time on/off button
is pressed *)
node mc_iffstatecmd(iffonoffbutton : bool; currentiffstate : tsensorstate)
returns (iffonoffcmd : bool)
let
iffonoffcmd =
statecmd(Digital.risingEdge(iffonoffbutton), currentiffstate);
tel
(* safe state machine for the computing of radar mode
state ident: state.6 *)
node rdrmodecmd(currentstate : tsensorstate;
modebuttonpressed : bool(* last = false*);
currentmode : trdrmode)
returns (modecmd : bool)
let
automaton
state Wide
do modecmd = false;
unless (modebuttonpressed &
(currentstate = TState_ON &
currentmode = TRdrMode_WIDE)) then Narrow
state Narrow
do modecmd = true;
unless (modebuttonpressed &
(currentstate = TState_ON &
currentmode = TRdrMode_NARROW)) then Wide
end
tel
(* compute the new radar mode each time on/off button
is pressed *)
node mc_rdrmodecmd(currentrdrstate : tsensorstate;
rdrmodebutton : bool;
currentrdrmode : trdrmode)
returns (rdrmodecmd : bool)
let
rdrmodecmd =
rdrmodecmd(currentrdrstate, Digital.risingEdge(rdrmodebutton),
currentrdrmode);
tel
(* compute the radar mode, according to the corresponding
input command from the mission computer *)
fun radar_mode(modecmd : bool) returns (mode : trdrmode)
let
mode = if modecmd then TRdrMode_NARROW else TRdrMode_WIDE;
tel
(* compute the radar state, according to:
- the corresponding input command from the mission computer
- the failure state of the radar *)
node radar_state(onoffcmd, failure : bool)
returns (initializing : bool; st : tsensorstate)
var x : bool;
let
initializing = st = TState_OFF & onoffcmd;
(* x = fby (onoffcmd; 5; false) *)
x = false fby false fby false fby false fby false fby onoffcmd;
st =
if failure
then TState_FAIL
else if (if onoffcmd then x else false)
then TState_ON
else TState_OFF;
tel
(* elaborate and generate the (up to 2) tracks detected
by the radar (position + speed + distance + rate of
closing) *)
node radar_tracks(st : tsensorstate;
tracks : TypeArray.ttracksarray;
rdrdetectedtracks : TypeArray.tdetectedrdrtracksarray)
returns (rdrtracks : TypeArray.trdrtracksarray)
var
l22 : TypeTracks.ttrack^ksizerdrtracksarray;
l30 : TypeTracks.trdrtrack^ksizerdrtracksarray;
let
rdrtracks = if st = TState_ON then l30 else kinitrdrtrackarray;
l30 = map Trackslib.elaboraterdrtrack <<ksizerdrtracksarray>>(l22);
l22 =
map Trackslib.selectdetectedtrack <<ksizerdrtracksarray>>(
rdrdetectedtracks, tracks^ksizerdrtracksarray,
CstTracksInit.kinittrack^ksizerdrtracksarray);
tel
(* scade representation for the radar, generating:
1) the radar state
2) the radar mode
3) the (up to 2) tracks detected by the radar *)
node radar(onoffcmd, modecmd, failure : bool;
rdrdetectedtracks : TypeArray.tdetectedrdrtracksarray;
tracks : TypeArray.ttracksarray)
returns (initializing : bool;
st : tsensorstate;
mode : trdrmode;
rdrtracks : TypeArray.trdrtracksarray)
let
rdrtracks = radar_tracks(st, tracks, rdrdetectedtracks);
mode = radar_mode(modecmd);
(initializing, st) = radar_state(onoffcmd, failure);
tel
(* compute the iff state, according to:
- the corresponding input command from the mission computer
- the failure state of the iff *)
node iff_state(onoffcmd, failure : bool)
returns (initializing : bool; st : tsensorstate)
var x : bool;
let
initializing = st = TState_OFF & onoffcmd;
(* x = fby (onoffcmd; 5; false) *)
x = false fby false fby false fby false fby false fby onoffcmd;
st =
if failure
then TState_FAIL
else if (if onoffcmd then x else false)
then TState_ON
else TState_OFF;
tel
fun ifftrack_of_track(track : TypeTracks.ttrack)
returns (ifftrack : TypeTracks.tifftrack)
let
ifftrack = { i_pos = track.t_pos; i_id = track.t_id };
tel
(* elaborate and generate the (up to 2) tracks detected
by the iff (position + identifier) *)
fun iff_tracks(st : tsensorstate;
tracks : TypeArray.ttracksarray;
iffdetectedtracks : TypeArray.tdetectedifftracksarray)
returns (ifftracks : TypeArray.tifftracksarray)
var l34 : TypeTracks.ttrack^TypeArray.ksizeifftracksarray;
l40 : TypeArray.tifftracksarray;
let
l34 =
map Trackslib.selectdetectedtrack <<ksizeifftracksarray>>(
iffdetectedtracks, tracks^ksizeifftracksarray,
CstTracksInit.kinittrack^ksizeifftracksarray);
l40 = map ifftrack_of_track <<ksizeifftracksarray>>(l34);
ifftracks = if st = TState_ON then l40 else kinitifftrackarray;
tel
(* scade representation for the iff, generating:
1) the iff state
2) the (up to 2) tracks detected by the iff *)
node iff(tracks : TypeArray.ttracksarray;
failure : bool;
iffdetectedtracks : TypeArray.tdetectedifftracksarray;
onoffcmd : bool)
returns (st : tsensorstate;
ifftracks : TypeArray.tifftracksarray;
initializing : bool)
let
ifftracks = iff_tracks(st, tracks, iffdetectedtracks);
(initializing, st) = iff_state(onoffcmd, failure);
tel
node advrandr(min, max : float) returns (output1 : float)
let
output1 = (max -. min) *. rand() +. min;
tel
node advrandi(min, max, step : int) returns (output1 : int)
var l8 : int;
let
l8 = if 0 <> step then step else 1;
output1 = (int_of_float (float_of_int (max - min) *. rand())
+ min) / (l8 * l8);
tel
(* for one given track, generate:
1) its new position according to:
- its previous position, the input speed and slope
if set/reset button not pressed
- the input initial position if set/reset button pressed
2) its identifier according to the input identifier *)
node createtracks_createonetrack_init_rand()
returns (sloperadinit, speedinit, xmeterinit, ymeterinit : float;
idinit : int)
let
speedinit = advrandr(250.0, 1000.0) *. CstPhysics.t;
ymeterinit = CstPhysics.nm *. advrandr(-. 10.0, 10.0);
xmeterinit = advrandr(-. 10.0, 10.0) *. CstPhysics.nm;
sloperadinit = 2.0 *. CstPhysics.pi *. advrandr(0.0, 360.0) /. 360.0;
idinit = advrandi(0, 1000, 10);
tel
(* for one given track, generate:
1) its new position according to:
- its previous position, the input speed and slope
if set/reset button not pressed
- the input initial position if set/reset button pressed
2) its identifier according to the input identifier *)
node createtracks_createonetrack_rand(res : bool)
returns (track : TypeTracks.ttrack)
var id : int; sloperad, speedt, x0, y0, l9, l18 : float;
let
(* (sloperad, speedt, x0, y0, id) =
(activate createtracks_createonetrack_init_rand every reset initial default (
0., 0., 0., 0., 0))(); *)
(sloperad, speedt, x0, y0, id) =
if res then createtracks_createonetrack_init_rand()
else (0.0, 0.0, 0.0, 0.0, 0) -> pre (sloperad, speedt, x0, y0, id);
l18 = y0 -> Mathext.sinr(sloperad) *. speedt +. (y0 -> pre l18);
l9 = x0 -> (x0 -> pre l9) +. speedt *. Mathext.cosr(sloperad);
track = { t_pos = { x = l9; y = l18 }; t_id = id };
tel
(* generate up to 4 tracks (position + identifier) according
to the graphical track inputs panel. *)
node createtracks_rand(res : bool)
returns (tracks : TypeArray.ttracksarray)
let
tracks =
map
createtracks_createonetrack_rand
<<ksizetracksarray>>(res^ksizetracksarray);
tel
node createalltracks(res : bool)
returns (tracks : TypeArray.ttracksarray)
let
(* tracks = (restart createtracks_rand every res)(res); *)
reset
tracks = createtracks_rand(res);
every res
tel
(* merge a mission track detected by the radar with a
mission track detected by the iff if they have the same
position and speed.
in that case, newrdrmissiontrack is the merged track, and newiffmissiontrack is reset to "empty".
otherwise, outputs = inputs *)
fun fusionrdrifftracks(iffmissiontrack, rdrmissiontrack
: TypeTracks.tmissiontrack)
returns (newiffmissiontrack, newrdrmissiontrack
: TypeTracks.tmissiontrack)
var l90 : bool;
let
newrdrmissiontrack =
if l90
then { m_pos = rdrmissiontrack.m_pos;
m_speed = rdrmissiontrack.m_speed;
m_id = iffmissiontrack.m_id;
m_priority = rdrmissiontrack.m_priority;
m_d = rdrmissiontrack.m_d;
m_sabs = rdrmissiontrack.m_sabs;
m_sr = rdrmissiontrack.m_sr;
m_detectedbyradar = rdrmissiontrack.m_detectedbyradar;
m_detectedbyiff = iffmissiontrack.m_detectedbyiff;
m_tracknumber = 0;
m_targettype = iffmissiontrack.m_targettype;
m_isvisible = rdrmissiontrack.m_isvisible;
m_angle = rdrmissiontrack.m_angle }
else rdrmissiontrack;
l90 =
Trackslib.comparetracks(rdrmissiontrack.m_pos, iffmissiontrack.m_pos,
rdrmissiontrack.m_speed, iffmissiontrack.m_speed);
newiffmissiontrack =
if l90
then CstTracksInit.kinitmissiontrack
else iffmissiontrack;
tel
(* merge tracks data received from both radar and iff sensors *)
fun mc_tracks_fusion_onerdrwithifftracks(rdrtrack : TypeTracks.tmissiontrack;
ifftracks : TypeTracks.tmissiontrack^ksizeifftracksarray)
returns (fusionnedrdrtrack : TypeTracks.tmissiontrack;
fusionnedifftracks : TypeTracks.tmissiontrack^ksizeifftracksarray)
let
(fusionnedifftracks, fusionnedrdrtrack) =
mapfold fusionrdrifftracks <<ksizeifftracksarray>>(ifftracks, rdrtrack);
tel
(* merge tracks data received from both radar and iff sensors *)
node mc_tracks_fusion(rdrtracks : TypeArray.trdrtracksarray;
ifftracks : TypeArray.tifftracksarray)
returns (missiontracks : TypeArray.tmissiontracksarray)
var
mergedrdrtracks : TypeTracks.tmissiontrack^ksizerdrtracksarray;
mergedifftracks : TypeTracks.tmissiontrack^ksizeifftracksarray;
l140 : TypeTracks.tmissiontrack^ksizerdrtracksarray;
l139 : TypeTracks.tmissiontrack^ksizeifftracksarray;
let
missiontracks = mergedrdrtracks @ mergedifftracks;
(mergedrdrtracks, mergedifftracks) =
mapfold mc_tracks_fusion_onerdrwithifftracks <<ksizerdrtracksarray>>(
l140, l139);
l140 =
map
Trackslib.convertrdrtracktomissiontrack
<<ksizerdrtracksarray>>(rdrtracks);
l139 =
map
Trackslib.convertifftracktomissiontrack
<<ksizeifftracksarray>>(ifftracks);
tel
fun prio_tracknumbernotinarray(missiontracktracknumber,
prioritytrack : int; acc : bool)
returns (notinarray : bool)
let
notinarray = acc & missiontracktracknumber <> prioritytrack;
tel
(* replace the lowest priority track in priorityarray by missiontrack *)
node prio_selecthighestprioritynotinpriorityarray(
missiontrack : TypeTracks.tmissiontrack;
prioritiesarray : Mc_TypeLists.tpriorityList;
accprioritymissiontrack : TypeTracks.tmissiontrack)
returns (prioritymissiontrack : TypeTracks.tmissiontrack)
var
missiontracknotinpriorittiesarray,
missiontrackhashigherprioritythanacc : bool;
let
missiontrackhashigherprioritythanacc =
not Trackslib.trackalowerprioritythanb(missiontrack,
accprioritymissiontrack);
missiontracknotinpriorittiesarray =
fold prio_tracknumbernotinarray <<4>>(missiontrack.m_tracknumber^4,
prioritiesarray, true);
prioritymissiontrack =
if missiontracknotinpriorittiesarray & missiontrackhashigherprioritythanacc
then missiontrack
else accprioritymissiontrack;
tel
(* for each missiontrack
if priority higher than all in priorityarray and not in priorityarray
then, copy in priorityarray at index *)
node prio_selectprioritarymissiontracks(missiontracks : TypeArray.tmissiontracksarray;
prioritiesarray : Mc_TypeLists.tpriorityList;
indexpriority : int)
returns (newprioritiesarray : Mc_TypeLists.tpriorityList)
var missiontrackwithhighestpriority : TypeTracks.tmissiontrack;
let
newprioritiesarray =
[ prioritiesarray with [indexpriority] =
missiontrackwithhighestpriority.m_tracknumber ];
missiontrackwithhighestpriority =
fold
prio_selecthighestprioritynotinpriorityarray
<<ksizemissiontracksarray>>(
missiontracks,
prioritiesarray^ksizemissiontracksarray, CstTracksInit.kinitmissiontrack);
tel
fun prio_setpriorityinmissiontrack(prioritytracknumber : int;
priorityindex : int;
missiontrack : TypeTracks.tmissiontrack)
returns (missiontrackwithprio : TypeTracks.tmissiontrack)
let
missiontrackwithprio =
if prioritytracknumber = missiontrack.m_tracknumber
then Trackslib.setmissiontrackpriority(missiontrack, priorityindex + 1)
else missiontrack;
tel
fun prio_setpriorityinmissiontrackarray(priorityarray : Mc_TypeLists.tpriorityList;
missiontrack : TypeTracks.tmissiontrack)
returns (missiontrackwithprio : TypeTracks.tmissiontrack)
let
missiontrackwithprio =
foldi prio_setpriorityinmissiontrack <<4>>(priorityarray, missiontrack);
tel
(* set the priority in missiontracks:
1) set the highest prority
2) set the second priority=highest different from the previous
3) set the 3rd priority=highest different from the previous
3) set the 4th priority=highest different from the previous
=> the 4 priority track should be in an array (initialized to "empty")
operator selectprioritymissiontracks inputs
- missiontracks
- prioritytrack set (to perform the "different from the previous")
*test for each missiontrack: the higest, and not already in prioritytracks.
*then, set the ith element of prioritytracks with the one found
for each missiontrack, if prioritary higher than the lowest 4 prioritary
old: compute each detected track priority, and sort tracks
according to their priority *)
node mc_tracks_prio(missiontracks : TypeArray.tmissiontracksarray)
returns (missiontrackswithprio : TypeArray.tmissiontracksarray)
var prioritytracknumbers : Mc_TypeLists.tpriorityList;
let
missiontrackswithprio =
map prio_setpriorityinmissiontrackarray <<ksizemissiontracksarray>>(
prioritytracknumbers^ksizemissiontracksarray, missiontracks);
prioritytracknumbers =
prio_selectprioritarymissiontracks(missiontracks,
prio_selectprioritarymissiontracks(missiontracks,
prio_selectprioritarymissiontracks(missiontracks,
prio_selectprioritarymissiontracks(missiontracks, 0^4, 0), 1), 2),
3);
tel
(* associate a track number to each detected track *)
node mc_tracks_tracknumber(withouttracknb : TypeArray.tmissiontracksarray)
returns (withtracknumber : TypeArray.tmissiontracksarray)
var l81 : int;
let
(withtracknumber, l81) =
mapfold
Trackslib.calculatemissiontracknumber
<<ksizemissiontracksarray>>((kinitmissiontrackarray ->
pre withtracknumber)^ksizemissiontracksarray,
withouttracknb, 0 -> pre l81);
tel
(* 1) merge tracks data received from both radar and iff sensors
2) associate a track number to each detected track
3) compute each detected track priority, and sort tracks
according to their priority *)
node mc_tracks(rdrtracks : TypeArray.trdrtracksarray;
ifftracks : TypeArray.tifftracksarray)
returns (missiontracks : TypeArray.tmissiontracksarray)
let
missiontracks =
mc_tracks_prio(mc_tracks_tracknumber(mc_tracks_fusion(rdrtracks,
ifftracks)));
tel
(* scade representation for the mission computer, computing:
- the new radar state
- the new radar mode
- the new iff state
- the (up to 4) tracks detected by the fighter *)
node mc(currentrdrstate : tsensorstate;
currentrdrmode : trdrmode;
rdrtracks : TypeArray.trdrtracksarray;
rdronoffbutton, rdrmodebutton, iffonoffbutton : bool;
currentiffstate : tsensorstate;
ifftracks : TypeArray.tifftracksarray)
returns (rdronoffcmd, rdrmodecmd : bool;
missiontracks : Typearray.tmissiontracksarray;
iffonoffcmd : bool)
let
missiontracks = mc_tracks(rdrtracks, ifftracks);
iffonoffcmd = mc_iffstatecmd(iffonoffbutton, currentiffstate);
rdrmodecmd = mc_rdrmodecmd(currentrdrstate, rdrmodebutton, currentrdrmode);
rdronoffcmd = mc_rdrstatecmd(rdronoffbutton, currentrdrstate);
tel

10
examples/MissionComputer_for_Core/mc_TypeInputs.epi Normal file
View file

@ -0,0 +1,10 @@
type tinputspanel = {
p_slope : float;
p_speed : float;
p_id : int;
p_x0 : float;
p_y0 : float;
p_reset : bool
}
type tinputspanelarray = tinputspanel^4

5
examples/MissionComputer_for_Core/mc_TypeLists.epi Normal file
View file

@ -0,0 +1,5 @@
type tpriority = { missionTrackIndex : int; trackNumber : int }
(* TrackNumbers of the tracks with highest priority,
sorted from the highest priority *)
type tpriorityList = int^4

3
examples/MissionComputer_for_Core/mc_TypeSensors.epi Normal file
View file

@ -0,0 +1,3 @@
type trdrmode = TRdrMode_WIDE | TRdrMode_NARROW
type tsensorstate = TState_OFF | TState_ON | TState_FAIL

127
examples/MissionComputer_for_Core/mc_ext.c Normal file
View file

@ -0,0 +1,127 @@
#include <math.h>
#include <stdlib.h>
#include "mc_ext.h"
/*$**************************************
NAME : MC_Tracks_Prio_SortTracks
INPUTS :
InputTrack1 : TMissionTrack
InputTrack2 : TMissionTrack
InputTrack3 : TMissionTrack
InputTrack4 : TMissionTrack
OUPUTS :
OutputTrack1 : TMissionTrack
OutputTrack2 : TMissionTrack
OutputTrack3 : TMissionTrack
OutputTrack4 : TMissionTrack
***************************************$*/
void mc_tracks_prio_sorttracks(
const TMissionTrack *InputTrack1, const TMissionTrack *InputTrack2,
const TMissionTrack *InputTrack3, const TMissionTrack *InputTrack4,
mc_tracks_prio_sorttracks_out *out)
{
TMissionTrack _LO1_newA = *InputTrack1;
TMissionTrack _LO1_newB = *InputTrack1;
TMissionTrack _LO2_newA = *InputTrack1;
TMissionTrack _LO2_newB = *InputTrack1;
TMissionTrack _LO3_newA = *InputTrack1;
TMissionTrack _LO3_newB = *InputTrack1;
TMissionTrack _LO4_newA = *InputTrack1;
TMissionTrack _LO4_newB = *InputTrack1;
TMissionTrack _LO5_newA = *InputTrack1;
TMissionTrack _LO5_newB = *InputTrack1;
TMissionTrack _LO6_newA = *InputTrack1;
TMissionTrack _LO6_newB = *InputTrack1;
TMissionTrack _LI_A = *InputTrack1;
TMissionTrack _LI_B = *InputTrack2;
SortBlockPriorities(&_LI_A, &_LI_B, &_LO4_newA, &_LO4_newB);
_LI_A = *InputTrack3;
_LI_B = *InputTrack4;
SortBlockPriorities(&_LI_A, &_LI_B, &_LO6_newA, &_LO6_newB);
SortBlockPriorities(&_LO4_newB, &_LO6_newA, &_LO2_newA, &_LO2_newB);
SortBlockPriorities(&_LO4_newA, &_LO2_newA, &_LO1_newA, &_LO1_newB);
out->OutputTrack1 = _LO1_newA;
SortBlockPriorities(&_LO2_newB, &_LO6_newB, &_LO5_newA, &_LO5_newB);
SortBlockPriorities(&_LO1_newB, &_LO5_newA, &_LO3_newA, &_LO3_newB);
out->OutputTrack2 = _LO3_newA;
out->OutputTrack3 = _LO3_newB;
out->OutputTrack4 = _LO5_newB;
}
/* ROLE :,
Sort two mission tracks according to:,
1) their (rate of closing / distance) ratio,
2) target type,
3) detection or not by the Radar */
void SortBlockPriorities(const TMissionTrack *InputTrackA, const TMissionTrack *InputTrackB, TMissionTrack *OutputTrackA, TMissionTrack *OutputTrackB)
{
bool bInvertTracks = false;
real vrDivDResultTrackA = 0.0;
real vrDivDResultTrackB = 0.0;
vrDivDResultTrackA = CalculateVrDivD(InputTrackA->Vr, InputTrackA->D);
vrDivDResultTrackB = CalculateVrDivD(InputTrackB->Vr, InputTrackB->D);
bInvertTracks = (InputTrackA->targetType == TTargetType_FRIEND);
bInvertTracks = bInvertTracks || !(InputTrackA->detectedByRadar);
if ( ( fabs(vrDivDResultTrackA) < 0.0001 ) && ( fabs(vrDivDResultTrackB) < 0.0001 ) ) {
bInvertTracks = bInvertTracks ||
( (InputTrackA->detectedByRadar) &&
(InputTrackB->detectedByRadar) &&
( InputTrackA->D > InputTrackB->D ) );
} else {
bInvertTracks = bInvertTracks ||
( (InputTrackA->detectedByRadar) &&
(InputTrackB->detectedByRadar) &&
(vrDivDResultTrackA < vrDivDResultTrackB) );
}
if (bInvertTracks) {
*OutputTrackA = *InputTrackB;
*OutputTrackB = *InputTrackA;
} else {
*OutputTrackA = *InputTrackA;
*OutputTrackB = *InputTrackB;
}
}
/* ROLE :,
Calculate: result = rate of closing / distance */
real CalculateVrDivD(const float _I0_Vr, const float _I1_D)
{
bool bDIsNotZero = (_I1_D > 0.1);
if (bDIsNotZero) {
return ( _I0_Vr / _I1_D ) ;
} else {
return ( 0.0 );
}
}
void rand_step(rand_out *out)
{
float a = (float)(rand());
kcg_real b = (float)RAND_MAX;
out->o = a/b;
}
void int_of_float_step(float a, int_of_float_out *out)
{
return (int) a;
}
void float_of_int_step(int a, int_of_float_out *out)
{
return (float) a;
}

14
examples/MissionComputer_for_Core/mc_ext.epi Normal file
View file

@ -0,0 +1,14 @@
(* compute each detected track priority, and sort tracks
according to their priority *)
val fun mc_tracks_prio_sorttracks(inputtrack1 : TypeTracks.tmissiontrack;
inputtrack2 : TypeTracks.tmissiontrack;
inputtrack3 : TypeTracks.tmissiontrack;
inputtrack4 : TypeTracks.tmissiontrack)
returns (outputtrack1 : TypeTracks.tmissiontrack;
outputtrack2 : TypeTracks.tmissiontrack;
outputtrack3 : TypeTracks.tmissiontrack;
outputtrack4 : TypeTracks.tmissiontrack)
val fun int_of_float(a:float) returns (o:int)
val fun float_of_int(a:int) returns (o:float)
val fun rand() returns (output1 : float)

48
examples/MissionComputer_for_Core/mc_ext.h Normal file
View file

@ -0,0 +1,48 @@
#ifndef MC_EXT_H
#define MC_EXT_H
#include "typeArray_types.h"
typedef struct mc_tracks_prio_sorttracks_out {
TMissionTrack OutputTrack1;
TMissionTrack OutputTrack2;
TMissionTrack OutputTrack3;
TMissionTrack OutputTrack4;
} mc_tracks_prio_sorttracks_out;
/* =============== */
/* CYCLIC FUNCTION */
/* =============== */
void mc_tracks_prio_sorttracks(
const TMissionTrack *InputTrack1, const TMissionTrack *InputTrack2,
const TMissionTrack *InputTrack3, const TMissionTrack *InputTrack4,
mc_tracks_prio_sorttracks_out *out);
void SortBlockPriorities(const TMissionTrack *InputTrackA, const TMissionTrack *InputTrackB, TMissionTrack *OutputTrackA, TMissionTrack *OutputTrackB);
real CalculateVrDivD(const float _I0_Vr, const float _I1_D);
/* rand() */
typedef struct {
float o;
} rand_out;
void rand_step(rand_out *out);
/* int_of_float */
typedef struct {
int o;
} int_of_float_out;
void int_of_float_step(float a, int_of_float_out *out);
/* float_of_int */
typedef struct {
float o;
} float_of_int_out;
void float_of_int_step(int a, float_of_int_out *out);
#endif

419
examples/MissionComputer_for_Core/trackslib.ept Normal file
View file

@ -0,0 +1,419 @@
(* calculate arctan(y/x) *)
open TypeBase
open TypeTracks
node myarctan(y, x : float) returns (atan : float)
var l6 : float; l4 : bool; l1 : float;
let
atan =
if l4
then if x <. 0.0 then CstPhysics.pi +. l1 else l1
else CstPhysics.pi /. 2.0 *. Math.sign(y);
(* l6 = (activate div every l4 initial default 0.0)(y, x); *)
l6 = if l4 then y /. x else 0.0 -> pre l6;
l4 = Math.abs(x) >. 0.1;
l1 = Mathext.atanr(l6);
tel
(* compute if a given track is equal to one of the mission tracks
belonging to the mission track array at the previous tick *)
fun missiontrackequalsprevious(previousone, actualone : TypeTracks.tmissiontrack)
returns (equal : bool)
let
equal =
0 <> previousone.m_id & previousone.m_id = actualone.m_id or
Math.abs(previousone.m_pos.x -. actualone.m_pos.x) <. 100.0 &
Math.abs(previousone.m_pos.y -. actualone.m_pos.y) <. 100.0 &
not (Math.abs(previousone.m_pos.x) <. 0.1 &
Math.abs(previousone.m_pos.y) <. 0.1 &
Math.abs(actualone.m_pos.x) <. 0.1 &
Math.abs(actualone.m_pos.y) <. 0.1 )
tel
(* compute track visibility (appearance on radar screen)
according to track position and speed *)
fun calctrackvisible1(position : TypeBase.tposition;
speed : TypeBase.tspeed)
returns (trackvisible : bool)
let
trackvisible =
not (Math.abs(position.x) <. 0.001 & Math.abs(position.y) <. 0.001 &
Math.abs(speed.sx) <. 0.001 &
Math.abs(speed.sy) <. 0.001);
tel
fun missiontrackexist1(acc_tracknumber : int;
missiontrack,
previousmissiontrack : TypeTracks.tmissiontrack)
returns (tracknumbertoset : int)
let
tracknumbertoset =
if missiontrackequalsprevious(missiontrack, previousmissiontrack) &
0 <> previousmissiontrack.m_tracknumber
then previousmissiontrack.m_tracknumber
else acc_tracknumber;
tel
(* compute if a given track is equal to one of the mission tracks
belonging to the mission track array at the previous tick *)
fun missiontrackequalsprevious_orig(previousone, actualone : TypeTracks.tmissiontrack)
returns (equal : bool)
var l43 : bool;
let
l43 = previousone.m_tracknumber <> 0;
equal =
l43 &
(l43 & 0 <> previousone.m_id & previousone.m_id = actualone.m_id or
Math.abs(previousone.m_pos.x -. actualone.m_pos.x) <. 100.0 &
Math.abs(previousone.m_pos.y -. actualone.m_pos.y) <. 100.0 &
not (Math.abs(previousone.m_pos.x) <. 0.1 &
Math.abs(previousone.m_pos.y) <. 0.1 &
Math.abs(actualone.m_pos.x) <. 0.1 &
Math.abs(actualone.m_pos.y) <. 0.1));
tel
fun util_radtodeg(input1 : float) returns (output1 : float)
let
output1 = input1 /. (2.0 *. CstPhysics.pi) *. 360.0;
tel
fun util_degtorad(input1 : float) returns (output1 : float)
let
output1 = 2.0 *. CstPhysics.pi *. input1 /. 360.0;
tel
(* if speedabs is small (speed.x and speed.y are also small), trackangle is set to 0.
otherwise, trackangle is computed to be in the range [-180, 180]
degrees thanks to the acosr; sign is given, from the asinr. *)
fun calctrackangle(speed : TypeBase.tspeed; speedabs : TypeBase.tmetresseconde)
returns (trackangle : float)
var l51 : bool; l48, l47 : float;
let
trackangle =
util_radtodeg(if l51 then 0.0 else Mathext.acosr(l47) *. l48) *.
(l48 *.
Math.sign(Mathext.asinr(speed.sy /. (if l51 then 1.0 else speedabs))));
l51 = speedabs <. 0.01;
l48 = Math.sign(l47);
l47 = speed.sx /. (if l51 then 1.0 else speedabs);
tel
(* compute track visibility (appearance on radar screen)
according to track position *)
fun calctrackvisible(position : TypeBase.tposition)
returns (trackvisible : bool)
let
trackvisible =
not (Math.abs(position.x) <. 0.001 & Math.abs(position.y) <. 0.001);
tel
fun missiontrackexist( missiontrack,
previousmissiontrack : TypeTracks.tmissiontrack;
acc_tracknumber : int)
returns (tracknumbertoset : int)
let
tracknumbertoset =
if missiontrackequalsprevious(missiontrack, previousmissiontrack)
then previousmissiontrack.m_tracknumber
else acc_tracknumber;
tel
(* calculate: result = rate of closing / distance *)
node calculatevrdivd(vr, d : float) returns (result : float)
var l13 : float; l11 : bool;
let
result = if l11 then l13 else 0.0;
(* l13 = (activate div every l11 initial default 0.0)(vr, d); *)
l13 = if l11 then vr /. d else 0.0 -> pre l13;
l11 = d >. 0.1;
tel
(* sort two mission tracks according to:
1) their (rate of closing / distance) ratio
2) target type
3) detection or not by the radar *)
node trackalowerprioritythanb(a, b : TypeTracks.tmissiontrack)
returns (prioritary : bool)
let
prioritary =
a.m_targettype = TypeBase.Ttargettype_friend or not a.m_detectedbyradar or
a.m_detectedbyradar &
calculatevrdivd(a.m_sr, a.m_d) <. calculatevrdivd(b.m_sr, b.m_d) &
b.m_detectedbyradar;
tel
(* compute if two tracks speeds are equal *)
fun comparespeeds(speed1, speed2 : TypeBase.tspeed)
returns (equal : bool)
let
equal =
Math.abs(speed1.sx -. speed2.sx) <. 1.0 &
Math.abs(speed1.sy -. speed2.sy) <. 1.0;
tel
(* compute a "prioritized" track number according to its
priority and target type *)
fun calculateprioritizedtracknb(missiontrack : TypeTracks.tmissiontrack)
returns (prioritizedtracknb : int)
let
prioritizedtracknb =
if missiontrack.m_targettype <> TypeBase.Ttargettype_friend &
missiontrack.m_priority <> 0
then missiontrack.m_tracknumber
else 0;
tel
(* sort two real inputs *)
fun sortreals(a, b : float) returns (newa, newb : float)
var l2 : bool;
let
l2 = a <. b;
newb = if l2 then a else b;
newa = if l2 then b else a;
tel
(* compute if two tracks positions are equal *)
fun comparepositions(pos1, pos2 : TypeBase.tposition)
returns (equal : bool)
let
equal =
Math.abs(pos1.x -. pos2.x) <. 0.1 & Math.abs(pos1.y -. pos2.y) <. 0.1;
tel
(* compute if two tracks are equal (according to their position
and speed) *)
fun comparetracks(pos1, pos2 : TypeBase.tposition;
v1, v2 : TypeBase.tspeed)
returns (equal : bool)
let
equal = comparepositions(pos1, pos2) & comparespeeds(v1, v2);
tel
(* set the track number of a mission track *)
fun setmissiontracknumber(missiontrack : TypeTracks.tmissiontrack; number : int)
returns (newmissiontrack : TypeTracks.tmissiontrack)
let
newmissiontrack = { missiontrack with .m_tracknumber = number };
tel
(* compute if a mission track is null (or empty) according to
its position and speed *)
fun missiontrackisnull(missiontrack : TypeTracks.tmissiontrack)
returns (isnull : bool)
let
isnull =
comparetracks(missiontrack.m_pos, CstBaseInit.kInitPosition,
missiontrack.m_speed, CstBaseInit.kInitSpeed);
tel
(* calculate the new track number for a mission track, according to:
1) the mission track data
2) the previous mission tracks array
3) the current (highest) track number *)
fun calculatemissiontracknumber(
previousmissiontracks : TypeArray.tmissiontracksarray;
missiontrack : TypeTracks.tmissiontrack;
currenttracknumber : int)
returns (newmissiontrack : TypeTracks.tmissiontrack;
newtracknumber : int)
var setnewtracknumber : bool; previoustracknumber : int;
let
setnewtracknumber =
previoustracknumber = 0 & not missiontrackisnull(missiontrack);
newtracknumber =
if setnewtracknumber then currenttracknumber + 1 else currenttracknumber;
previoustracknumber =
fold missiontrackexist <<TypeArray.ksizemissiontracksarray>>
(missiontrack^TypeArray.ksizemissiontracksarray,
previousmissiontracks, 0);
newmissiontrack =
setmissiontracknumber(missiontrack, if setnewtracknumber
then newtracknumber
else previoustracknumber);
tel
(* compute a mission track target type according to its identifier *)
fun calculatetracktargettypefromid(id : int)
returns (targettype : TypeBase.ttargettype)
let
targettype =
if 0 = id
then Typebase.Ttargettype_unknown
else if id <= 500
then TypeBase.Ttargettype_friend
else TypeBase.Ttargettype_foe;
tel
(* calculate the derivative of a value x(n) according to its
ante-previous value x(n-2) *)
node myderivative(in, period : float) returns (out : float)
var l2 : float;
let
(* l2 = fby (in; 2; 0.0); *)
l2 = 0.0 fby (0.0 fby in);
out =
if Math.abs(l2) <. 0.1 or Math.abs(in) <. 0.1
then 0.0
else 0.0 -> (in -. l2) /. (2.0 *. period);
tel
(* calculate a track speed vector according to the position vector *)
node calculatetrackspeedfrompos(position : TypeBase.tposition)
returns (speed : TypeBase.tspeed)
let
speed =
{ sx = myderivative(position.x, CstPhysics.t);
sy = myderivative(position.y, CstPhysics.t) };
tel
(* generate the (up to 2) tracks detected by a sensor (radar
or iff) from the environment (made of 4 tracks) *)
fun selectdetectedtrack(index : int;
tracks : TypeArray.ttracksarray;
defaulttrack : TypeTracks.ttrack)
returns (trackselected : TypeTracks.ttrack)
let
trackselected = tracks.[index] default defaulttrack;
tel
(* set the priority of a mission track *)
fun setmissiontrackpriority(missiontrack : TypeTracks.tmissiontrack;
priority : int)
returns (newmissiontrack : TypeTracks.tmissiontrack)
let
newmissiontrack =
{ missiontrack with .m_priority =
if missiontrack.m_detectedbyradar then priority else 0 }
tel
(* invert two mission tracks if the first one is null (or empty) *)
fun sortblockmissiontrack(a, b : TypeTracks.tmissiontrack)
returns (newa, newb : TypeTracks.tmissiontrack)
var l7 : bool;
let
l7 = missiontrackisnull(a);
newb = if l7 then a else b;
newa = if l7 then b else a;
tel
(* sort two mission tracks according to:
1) their (rate of closing / distance) ratio
2) target type
3) detection or not by the radar *)
node sortblockpriorities(a, b : TypeTracks.tmissiontrack)
returns (newa, newb : TypeTracks.tmissiontrack)
var l25 : bool;
let
l25 = trackalowerprioritythanb(a, b);
newb = if l25 then a else b;
newa = if l25 then b else a;
tel
(* convert an iff track (position + identifier) into a mission
track (position + speed + distance + rate of closing +
detected by radar/iff + tracknumber + target type) *)
node convertifftracktomissiontrack(ifftrack : TypeTracks.tifftrack)
returns (missiontrack : TypeTracks.tmissiontrack)
let
missiontrack =
{ m_pos = ifftrack.i_pos;
m_speed = if CstBaseInit.kInitPosition = ifftrack.i_pos
then CstBaseInit.kInitSpeed
else calculatetrackspeedfrompos(ifftrack.i_pos);
m_id = ifftrack.i_id;
m_priority = 0;
m_d = 0.0;
m_sabs = 0.0;
m_sr = 0.0;
m_detectedbyradar = false;
m_detectedbyiff = not (ifftrack.i_pos = CstBaseInit.kInitPosition &
ifftrack.i_id = 0);
m_tracknumber = 0;
m_targettype = calculatetracktargettypefromid(ifftrack.i_id);
m_isvisible = calctrackvisible(ifftrack.i_pos);
m_angle = 0.0 };
tel
(* convert an radar track (position + speed + distance +
rate of closing) into a mission track (position + speed +
distance + rate of closing + detected by radar/iff +
tracknumber + target type) *)
fun convertrdrtracktomissiontrack(rdrtrack : TypeTracks.trdrtrack)
returns (missiontrack : TypeTracks.tmissiontrack)
let
missiontrack =
{ m_pos = rdrtrack.r_pos;
m_speed = rdrtrack.r_s;
m_id = 0;
m_priority = 0;
m_d = rdrtrack.r_d;
m_sabs = rdrtrack.r_sabs;
m_sr = rdrtrack.r_sr;
m_detectedbyradar = not (rdrtrack.r_pos = CstBaseInit.kInitPosition &
rdrtrack.r_s = CstBaseInit.kInitSpeed &
rdrtrack.r_d = 0.0 &
rdrtrack.r_sabs = 0.0 &
rdrtrack.r_sr = 0.0);
m_detectedbyiff = false;
m_tracknumber = 0;
m_targettype = TypeBase.Ttargettype_unknown;
m_isvisible = calctrackvisible(rdrtrack.r_pos);
m_angle = calctrackangle(rdrtrack.r_s, rdrtrack.r_sabs) };
tel
(* calculate the magnitude of a vector (2d) *)
fun vectnorme(a, b : float) returns (c : float)
let
c = Mathext.sqrtr(a *. a +. b *. b);
tel
(* extract the x and y (position) values from a track (ttrack type) *)
fun extracttrackposxy(track : TypeTracks.ttrack)
returns (x, y : TypeBase.tmetres)
let
y = track.t_pos.y;
x = track.t_pos.x;
tel
(* elaborate radar track data (position, speed, distance, rate of closing)
according to an environment track (position only) *)
node elaboraterdrtrack(track : TypeTracks.ttrack)
returns (rdrtrack : TypeTracks.trdrtrack)
var d, v, vr, vx, vy, x, y : float; l142 : TypeBase.tspeed;
let
(*activate ifblock1 if d = 0.0
then vr = 0.0;
else var xnorm, ynorm : real;
let
ynorm = y / d;
xnorm = x / d;
vr = - (vx * xnorm + vy * ynorm);
tel
returns vr;*)
switch d = 0.0
| true do vr = 0.0
| false
var xnorm, ynorm : float;
do
ynorm = y /. d;
xnorm = x /. d;
vr = -. (vx *. xnorm +. vy *. ynorm);
end;
(x, y) = extracttrackposxy(track);
rdrtrack =
{ r_pos = { x = x;
y = y };
r_s = { sx = vx;
sy = vy };
r_d = d;
r_sabs = v;
r_sr = vr };
v = vectnorme(vx, vy);
d = vectnorme(x, y);
vy = l142.sy;
vx = l142.sx;
l142 = calculatetrackspeedfrompos({ x = x; y = y });
tel

Some files were not shown because too many files have changed in this diff Show more