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

Merge branch 'clocked_inputs' into decade

Browse source 
Conflicts:
	compiler/heptagon/analysis/typing.ml
	compiler/heptagon/parsing/hept_scoping.ml
	compiler/heptagon/parsing/hept_static_scoping.ml
	compiler/main/mls2obc.ml
	compiler/obc/c/cmain.ml
This commit is contained in:
Léonard Gérard 2011-06-28 14:45:15 +02:00
commit 83b0182874
103 changed files with 1774 additions and 4644 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
.gitignore vendored
View file

@ -28,3 +28,19 @@ _build
test/*.ml
test/_check_builds
lib/java/.classpath
/test/async/build/convolutions_a.ept
/test/async/build/convolutions.ept
/test/async/build/fork_join_a.ept
/test/async/build/fork_join.ept
/test/async/build/java/.classpath
/test/async/build/kill.ept
/test/async/build/kill_node.ept
/test/async/build/moyen_lent_rapide_a.ept
/test/async/build/moyen_lent_rapide.ept
/test/async/build/rapide_lent_a2.ept
/test/async/build/reset_6_a.ept
/test/async/build/reset_6.ept
/test/async/build/reset_a.ept
/test/async/build/reset.ept
/test/async/build/t.ept
/test/async/build/tt.ept

80
compiler/global/clocks.ml
View file

@ -38,12 +38,25 @@ let gen_index () = (incr index; !index)
(** returns a new clock variable *)
let fresh_clock () = Cvar { contents = Cindex (gen_index ()); }
(** returns a new clock type corresponding to the data type [ty] *)
let rec fresh_ct ty = match ty with
| Tprod ty_list ->
(match ty_list with
| [] -> Ck (fresh_clock())
| _ -> Cprod (List.map fresh_ct ty_list))
| Tarray (t, _) -> fresh_ct t
| Tid _ | Tinvalid -> Ck (fresh_clock())
(** 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
| Cbase | Con _
| Cvar { contents = Cindex _ } -> ck
| Cvar (({ contents = Clink ck } as link)) ->
let ck = ck_repr ck in (link.contents <- Clink ck; ck)
let ck = ck_repr ck in
link.contents <- Clink ck;
ck
(** verifies that index is fresh in ck. *)
@ -55,32 +68,31 @@ let rec occur_check index ck =
| Con (ck, _, _) -> occur_check index ck
| _ -> raise Unify
(** unify ck *)
let rec unify_ck ck1 ck2 =
and unify_ck ck1 ck2 =
let ck1 = ck_repr ck1 in
let ck2 = ck_repr ck2 in
if ck1 == ck2
then ()
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)
match (ck1, ck2) with
| Cbase, Cbase -> ()
| Cvar { contents = Cindex n1 }, Cvar { contents = Cindex n2 } when n1 = n2 -> ()
| Con (ck1, c1, n1), Con (ck2, c2, n2) when (c1 = c2) & (n1 = n2) ->
unify_ck ck1 ck2
| Cvar ({ contents = Cindex n } as v), ck
| ck, Cvar ({ contents = Cindex n } as v) ->
occur_check n ck;
v.contents <- Clink ck
| _ -> raise Unify
(** unify ct *)
let rec unify t1 t2 =
if t1 == t2 then () else
match (t1, t2) with
| (Ck (Cbase | Cvar { contents = Cindex _; }), Cprod [])
| (Cprod [], Ck (Cbase | Cvar { contents = Cindex _; })) ->
()
| (Cprod [], Ck (Cbase | Cvar { contents = Cindex _; })) -> ()
| (Ck ck1, Ck ck2) -> unify_ck ck1 ck2
| (Cprod t1_list, Cprod t2_list) -> unify_list t1_list t2_list
| _ -> raise Unify
@ -93,16 +105,30 @@ and unify_list t1_list t2_list =
let rec skeleton ck = function
| Tprod ty_list ->
(match ty_list with
| [] -> Ck ck
| _ -> Cprod (List.map (skeleton ck) ty_list))
| Tarray (t, _) -> skeleton ck t
| Tid _ | Tinvalid -> Ck ck
(* TODO here it implicitely says that the base clock is Cbase
and that all tuple is on Cbase *)
let ckofct = function | Ck ck -> ck_repr ck | Cprod _ -> Cbase
| [_] -> Ck ck
| l -> Cprod (List.map (skeleton ck) l))
| Tarray _ | Tid _ | Tinvalid -> Ck ck
let unprod ct =
let rec f acc ct = match ct with
| Ck ck -> ck::acc
| Cprod ct_l -> List.fold_left f acc ct_l
in
f [] ct
let prod ck_l = match ck_l with
| [ck] -> Ck ck
| _ -> Cprod (List.map (fun ck -> Ck ck) ck_l)
let rec root_ck_of ck = match ck_repr ck with
| Cbase
| Cvar { contents = Cindex _ } -> ck
| Con(ck,_,_) -> root_ck_of ck
| Cvar { contents = Clink _ } -> Misc.internal_error "Clocks, wrong repr"
let rec last_clock ct = match ct with
| Ck ck -> ck
| Cprod l -> last_clock (Misc.last_element l)

89
compiler/global/global_printer.ml
View file

@ -24,6 +24,7 @@ let _print_modul ?(full=false) ff m = match m with
| Module m -> fprintf ff "%a" print_name m
| QualModule { qual = m; name = n } ->
fprintf ff "%a%a" (_aux_print_modul ~full:full) m print_name n
let print_full_modul ff m = _print_modul ~full:true ff m
let print_modul ff m = _print_modul ~full:false ff m
@ -32,11 +33,30 @@ let _print_qualname ?(full=false) ff { qual = q; name = n} = match q with
| LocalModule -> print_name ff n
| _ when q = g_env.current_mod && not full -> print_name ff n
| _ -> fprintf ff "%a%a" (_aux_print_modul ~full:full) q print_name n
let print_qualname ff qn = _print_qualname ~full:false ff qn
let print_full_qualname ff qn = _print_qualname ~full:true ff qn
let print_shortname ff {name = n} = print_name ff n
let print_ident ff id = Format.fprintf ff "%s" (name id)
let rec print_ck ff = function
| Cbase -> fprintf ff "."
| Con (ck, c, n) -> fprintf ff "%a on %a(%a)" print_ck ck print_qualname c print_ident n
| Cvar { contents = Cindex i } -> fprintf ff "'a%i" i
| Cvar { contents = Clink ck } -> print_ck ff ck
let rec print_ct ff = function
| Ck ck -> print_ck ff ck
| Cprod ct_list ->
fprintf ff "@[<2>(%a)@]" (print_list_r print_ct """ *""") ct_list
let rec print_sck ff = function
| Signature.Cbase -> fprintf ff "."
| Signature.Con (ck, c, n) -> fprintf ff "%a on %a(%a)" print_sck ck print_qualname c print_name n
let rec print_static_exp_desc ff sed = match sed with
| Sint i -> fprintf ff "%d" i
@ -55,7 +75,7 @@ let rec print_static_exp_desc ff sed = match sed with
fprintf ff "@[<2>%a@,%a@]"
print_qualname op print_static_exp_tuple se_list
| Sarray_power (se, n_list) ->
fprintf ff "%a^%a" print_static_exp se (print_list print_static_exp """^""") n_list
fprintf ff "%a^%a" print_static_exp se (print_list print_static_exp """^""") n_list
| 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
@ -86,17 +106,15 @@ let print_field ff field =
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_constrnt ff c = print_static_exp ff c
let print_constraints ff c_l =
fprintf ff "@[%a@]" (print_list_r print_constrnt "|"";"";") c_l
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 =
let print_interface_type ff (name,tdesc) =
match tdesc with
| Tabstract -> fprintf ff "@[type %s@]" name
| Tenum tag_name_list ->
@ -107,50 +125,41 @@ let print_interface_type ff name tdesc =
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 =
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_sarg ff arg = match arg.a_name with
| None ->
fprintf ff "@[%a :: %a@]" print_type arg.a_type print_sck arg.a_clock
| Some(name) ->
fprintf ff "@[%a : %a :: %a@]"
print_name name
print_type arg.a_type
print_sck arg.a_clock
let print_interface_value ff (name,node) =
let print_node_params ff (p_list, constraints) =
fprintf ff "@[<2><<@[%a@]%a>>@]"
(print_list_r (fun ff p -> print_name ff p.p_name) "" "," "") p_list
print_constraints constraints
in
fprintf ff "@[<v 2>val %a%a@[%a@] returns @[%a@]@]"
print_name name
print_node_params (node.node_params, node.node_param_constraints)
(print_list_r print_sarg "(" ";" ")") node.node_inputs
(print_list_r print_sarg "(" ";" ")") node.node_outputs
let print_interface ff =
let m = Modules.current_module () in
NamesEnv.iter
(fun key typdesc -> print_interface_type ff key typdesc) m.m_types;
(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;
(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;
(fun key sigtype -> print_interface_value ff (key,sigtype)) m.m_values;
Format.fprintf ff "@."
let print_ident ff id = Format.fprintf ff "%s" (name id)
let rec print_ck ff = function
| Cbase -> fprintf ff "base"
| Con (ck, c, n) ->
fprintf ff "%a on %a(%a)" print_ck ck print_qualname c print_ident n
| Cvar { contents = Cindex _ } -> 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

27
compiler/global/idents.ml
View file

@ -19,8 +19,11 @@ type ident = {
num : int; (* a unique index *)
source : string; (* the original name in the source *)
is_generated : bool;
is_reset : bool;
}
let is_reset id = id.is_reset
type var_ident = ident
let num = ref 0
@ -93,14 +96,14 @@ module S = Set.Make (struct type t = string
module UniqueNames =
struct
open Names
let used_names = ref (ref S.empty) (** Used strings in the current node *)
let used_names = ref (ref NamesSet.empty) (** Used strings in the current node *)
let env = ref Env.empty (** Map idents to their string *)
let (node_env : S.t ref QualEnv.t ref) = ref QualEnv.empty
let (node_env : NamesSet.t ref QualEnv.t ref) = ref QualEnv.empty
(** This function should be called every time we enter a node *)
let enter_node n =
(if not (QualEnv.mem n !node_env)
then node_env := QualEnv.add n (ref S.empty) !node_env);
then node_env := QualEnv.add n (ref NamesSet.empty) !node_env);
used_names := QualEnv.find n !node_env
(** @return a unique string for each identifier. Idents corresponding
@ -113,31 +116,33 @@ struct
s ^ "_" ^ (string_of_int !num) in
let rec fresh_string base =
let fs = fresh base in
if S.mem fs !(!used_names) then fresh_string base else fs in
if NamesSet.mem fs !(!used_names) then fresh_string base else fs in
if not (Env.mem n !env) then
(let s = n.source in
let s = if S.mem s !(!used_names) then fresh_string s else s in
!used_names := S.add s !(!used_names);
let s = if NamesSet.mem s !(!used_names) then fresh_string s else s in
!used_names := NamesSet.add s !(!used_names);
env := Env.add n s !env)
let name id =
Env.find id !env
end
let gen_fresh pass_name kind_to_string kind =
let gen_fresh pass_name kind_to_string ?(reset=false) kind =
let s = kind_to_string kind in
let s = if !Compiler_options.full_name then "__"^pass_name ^ "_" ^ s else s in
num := !num + 1;
let id = { num = !num; source = s; is_generated = true } in
let id = { num = !num; source = s; is_generated = true; is_reset = reset } in
UniqueNames.assign_name id; id
let gen_var pass_name name = gen_fresh pass_name (fun () -> name) ()
let gen_var pass_name ?(reset=false) name =
gen_fresh pass_name (fun () -> name) ~reset:reset ()
let ident_of_name s =
let ident_of_name ?(reset=false) s =
num := !num + 1;
let id = { num = !num; source = s; is_generated = false } in
let id = { num = !num; source = s; is_generated = false; is_reset = reset } in
UniqueNames.assign_name id; id
let source_name id = id.source
let name id = UniqueNames.name id
let enter_node n = UniqueNames.enter_node n

13
compiler/global/idents.mli
View file

@ -18,18 +18,23 @@ val ident_compare : ident -> ident -> int
(** Get the full name of an identifier (it is guaranteed to be unique) *)
val name : ident -> string
(** Get the source name of an identifier (useful when dealing with signatures *)
val source_name : ident -> string
(** [gen_fresh pass_name kind_to_string kind]
generate a fresh ident with a sweet [name].
It should be used to define a [fresh] function specific to a pass. *)
val gen_fresh : string -> ('a -> string) -> 'a -> ident
val gen_fresh : string -> ('a -> string) -> ?reset:bool -> 'a -> ident
(** [gen_var pass_name name]
generates a fresh ident with a sweet [name] *)
val gen_var : string -> string -> ident
val gen_var : string -> ?reset:bool -> string -> ident
(** [ident_of_name n] returns an identifier corresponding
(** [ident_of_name n] returns an fresh identifier corresponding
to a _source_ variable (do not use it for generated variables). *)
val ident_of_name : string -> ident
val ident_of_name : ?reset:bool -> string -> ident
val is_reset : ident -> bool
(** /!\ This function should be called every time we enter a node *)
val enter_node : Names.qualname -> unit

4
compiler/global/modules.ml
View file

@ -93,8 +93,8 @@ let _load_module modul =
let modname = match modul with
| Names.Pervasives -> "Pervasives"
| Names.Module n -> n
| Names.LocalModule -> Misc.internal_error "modules" 0
| Names.QualModule _ -> Misc.unsupported "modules" 0
| Names.LocalModule -> Misc.internal_error "modules"
| Names.QualModule _ -> Misc.unsupported "modules"
in
let name = String.uncapitalize modname in
try

6
compiler/global/names.ml
View file

@ -42,9 +42,9 @@ module QualEnv = struct
let append env' env = fold (fun key v env -> add key v env) env' env
end
module NamesSet = Set.Make (struct type t = string let compare = compare end)
module QualSet = Set.Make (struct type t = qualname let compare = compare end)
module ModulSet = Set.Make (struct type t = modul let compare = compare end)
module S = Set.Make (struct type t = string let compare = compare end)
let shortname { name = n; } = n
@ -53,7 +53,7 @@ let modul { qual = m; } = m
let rec modul_to_string m = match m with
| Pervasives -> "Pervasives"
| LocalModule -> "\#$%@#_LOCAL_MODULE"
| LocalModule -> "#$%@#_LOCAL_MODULE"
| Module n -> n
| QualModule {qual = q; name = n} -> (modul_to_string q) ^"."^ n
@ -68,7 +68,7 @@ let rec modul_of_string_list = function
let qualname_of_string s =
let q_l_n = Misc.split_string s "." in
match List.rev q_l_n with
| [] -> Misc.internal_error "Names" 0
| [] -> Misc.internal_error "Names"
| n::q_l -> { qual = modul_of_string_list q_l; name = n }
let modul_of_string s =

102
compiler/global/signature.ml
View file

@ -9,30 +9,37 @@
(* global data in the symbol tables *)
open Names
open Types
open Location
(** Warning: Whenever these types are modified,
interface_format_version should be incremented. *)
let interface_format_version = "20"
let interface_format_version = "30"
(** Node argument *)
type arg = { a_name : name option; a_type : ty }
type ck =
| Cbase
| Con of ck * constructor_name * name
(** Node argument : inputs and outputs *)
type arg = {
a_name : name option;
a_type : ty;
a_clock : ck; (** [a_clock] set to [Cbase] means at the node activation clock *)
}
(** 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
type constrnt = static_exp
(** Node signature *)
type node = {
node_inputs : arg list;
node_outputs : arg list;
node_stateful : bool;
node_params : param list;
node_params_constraints : size_constraint list }
node_inputs : arg list;
node_outputs : arg list;
node_stateful : bool;
node_params : param list;
node_param_constraints : constrnt list;
node_loc : location}
type field = { f_name : field_name; f_type : ty }
type structure = field list
@ -45,11 +52,75 @@ type type_def =
type const_def = { c_type : ty; c_value : static_exp }
(** { 3 Signature helper functions } *)
type error =
| Eckvar_unbound_input of name option * name
| Eckvar_unbound_ouput of name option * name
exception SignatureError of name option * name
let message loc e = begin match e with
| Eckvar_unbound_input(var_name,ck_name) ->
let a,name = match var_name with None -> "A","" | Some n -> "The"," "^n in
Format.eprintf "%a%s sampled input%s should come together with its sampling variable %s.@."
print_location loc
a name ck_name
| Eckvar_unbound_ouput (var_name,ck_name) ->
let a,name = match var_name with None -> "A","" | Some n -> "The"," "^n in
Format.eprintf "%a%s sampled ouput%s should be returned with its sampling value %s.@."
print_location loc
a name ck_name
end;
raise Errors.Error
(** @raise Errors.Error after printing the error *)
let check_signature s =
(* a simple env of defined names will be used, represented by a Set *)
let rec append env sa_l = match sa_l with
| [] -> env
| sa::sa_l -> match sa.a_name with
| None -> append env sa_l
| Some x -> append (NamesSet.add x env) sa_l
in
(* the clock of [arg] is correct if all the vars used are in [env] *)
let check env arg =
let n = arg.a_name in
let rec f = function
| Cbase -> ()
| Con(ck,_,x) ->
if not (NamesSet.mem x env)
then raise (SignatureError (n,x));
f ck
in
f arg.a_clock
in
(*initial env with only the inputs*)
let env = append NamesSet.empty s.node_inputs in
(try List.iter (check env) s.node_inputs
with SignatureError (x,c) ->
message s.node_loc (Eckvar_unbound_input (x,c)));
let env = append env s.node_outputs in
try List.iter (check env) s.node_outputs
with SignatureError (x,c) ->
message s.node_loc (Eckvar_unbound_ouput (x,c))
let rec ck_to_sck ck =
let ck = Clocks.ck_repr ck in
match ck with
| Clocks.Cbase -> Cbase
| Clocks.Con (ck,c,x) -> Con(ck_to_sck ck, c, Idents.source_name x)
| _ -> Misc.internal_error "Signature couldn't translate ck"
let names_of_arg_list l = List.map (fun ad -> ad.a_name) l
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_arg name ty ck = { a_type = ty; a_name = name; a_clock = ck }
let mk_param name ty = { p_name = name; p_type = ty }
@ -58,12 +129,13 @@ let mk_field n ty = { f_name = n; f_type = ty }
let mk_const_def ty value =
{ c_type = ty; c_value = value }
let mk_node ?(constraints = []) ins outs stateful params =
let mk_node ?(constraints = []) loc ins outs stateful params =
{ node_inputs = ins;
node_outputs = outs;
node_stateful = stateful;
node_params = params;
node_params_constraints = constraints }
node_param_constraints = constraints;
node_loc = loc}
let rec field_assoc f = function
| [] -> raise Not_found

97
compiler/global/static.ml
View file

@ -58,36 +58,53 @@ let message exn =
(** When not [partial],
@raise Partial_evaluation when the application of the operator can't be evaluated (only Unknown_op).
@raise Partial_evaluation when the application of the operator can't be evaluated.
Otherwise keep as it is unknown operators. *)
let apply_op partial loc 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 = "/" } ->
if n2 = 0 then raise (Evaluation_failed (Division_by_zero, loc));
Sint (n1 / n2)
| { 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*)
)
| _ -> if partial then Sop(op, se_list) (* partial evaluation *)
else raise (Partial_evaluation (Unknown_op op, loc))
let has_var_desc acc se =
let has_var _ _ sed = match sed with
| Svar _ -> sed,true
| _ -> raise Errors.Fallback
in
let se, acc =
Global_mapfold.static_exp_it
{Global_mapfold.defaults with Global_mapfold.static_exp_desc = has_var}
acc se
in
se.se_desc, acc
in
let sed_l, has_var = Misc.mapfold has_var_desc false se_list in
if (op.qual = Pervasives) && not has_var
then (
match op.name, sed_l with
| "+", [Sint n1; Sint n2] -> Sint (n1 + n2)
| "-", [Sint n1; Sint n2] -> Sint (n1 - n2)
| "*", [Sint n1; Sint n2] -> Sint (n1 * n2)
| "/", [Sint n1; Sint n2] ->
if n2 = 0 then raise (Evaluation_failed (Division_by_zero, loc));
Sint (n1 / n2)
| "=", [Sint n1; Sint n2] -> Sbool (n1 = n2)
| "<=", [Sint n1; Sint n2] -> Sbool (n1 <= n2)
| ">=", [Sint n1; Sint n2] -> Sbool (n1 >= n2)
| "<", [Sint n1; Sint n2] -> Sbool (n1 < n2)
| ">", [Sint n1; Sint n2] -> Sbool (n1 > n2)
| "&", [Sbool b1; Sbool b2] -> Sbool (b1 && b2)
| "or", [Sbool b1; Sbool b2] -> Sbool (b1 || b2)
| "not", [Sbool b] -> Sbool (not b)
| "~-", [Sint n] -> Sint (-n)
| f,_ -> Misc.internal_error ("Static evaluation failed of the pervasive operator "^f)
)
else
if partial
then Sop(op, se_list) (* partial evaluation *)
else raise (Partial_evaluation (Unknown_op op, loc))
(** When not [partial],
@raise Partial_evaluation when a static var cannot be evaluated, a local static parameter for example.
@raise Partial_evaluation when a static var cannot be evaluated,
a local static parameter for example.
Otherwise evaluate in a best effort manner. *)
let rec eval_core partial env se = match se.se_desc with
| Sint _ | Sfloat _ | Sbool _ | Sstring _ | Sconstructor _ | Sfield _ -> se
@ -143,30 +160,18 @@ let eval env se =
@raise [Errors.Error] if it cannot be computed.*)
let int_of_static_exp env se = match (eval env se).se_desc with
| Sint i -> i
| _ -> Misc.internal_error "static int_of_static_exp" 1
| _ -> Misc.internal_error "static int_of_static_exp"
(** [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)
| Cequal (e1, e2) ->
let e1 = simplify env e1 in
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.se_desc, e2.se_desc with
| Sint n1, Sint n2 -> Some (n1 <= n2), Clequal (e1, e2)
| _, _ -> None, Clequal (e1, e2))
| Cfalse -> None, Cfalse
let is_true env c =
let c = simplify env c in
match c.se_desc with
| Sbool b -> Some b, c
| _ -> None, c
exception Solve_failed of size_constraint
exception Solve_failed of constrnt
(** [solve env constr_list solves a list of constraints. It
removes equations that can be decided and simplify others.
@ -180,7 +185,7 @@ let rec solve const_env =
(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 static_exp_subst m se =
@ -209,5 +214,5 @@ let instanciate_constr m constr =
| Clequal (e1, e2) -> Clequal (static_exp_subst m e1, static_exp_subst m e2)
| Cfalse -> Cfalse in
List.map (replace_one m) constr
*)

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

@ -108,7 +108,7 @@ let rec typing e =
candlist l
| Eiterator (_, _, _, pe_list, e_list, _) ->
ctuplelist (List.map typing (pe_list@e_list))
| Ewhen (e, c, x) ->
| Ewhen (e, _, x) ->
let t = typing e in
let tc = read x in
cseq tc t
@ -135,7 +135,7 @@ and apply op e_list =
let i2 = typing e2 in
let i3 = typing e3 in
cseq t1 (cor i2 i3)
| (Eequal | Efun _| Enode _ | Econcat | Eselect_slice
| ( Efun _| Enode _ | Econcat | Eselect_slice
| Eselect_dyn | Eselect_trunc | Eselect _ | Earray_fill) ->
ctuplelist (List.map typing e_list)
| (Earray | Etuple) ->

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

@ -41,7 +41,7 @@ type error =
| Esubscripted_value_not_an_array of ty
| Earray_subscript_should_be_const
| Eundefined_const of qualname
| Econstraint_solve_failed of size_constraint
| Econstraint_solve_failed of constrnt
| Etype_should_be_static of ty
| Erecord_type_expected of ty
| Eno_such_field of ty * qualname
@ -52,6 +52,7 @@ type error =
| Emerge_missing_constrs of QualSet.t
| Emerge_uniq of qualname
| Emerge_mix of qualname
| Estatic_constraint of constrnt
exception Unify
exception TypingError of error
@ -136,7 +137,7 @@ let message loc kind =
| Econstraint_solve_failed c ->
eprintf "%aThe following constraint cannot be satisified:@\n%a.@."
print_location loc
print_size_constraint c
print_constrnt c
| Etype_should_be_static ty ->
eprintf "%aThis type should be static : %a.@."
print_location loc
@ -168,6 +169,10 @@ let message loc kind =
as the last argument (found: %a).@."
print_location loc
print_type ty
| Estatic_constraint c ->
eprintf "%aThis application doesn't respect the static constraint :@\n%a.@."
print_location loc
print_location c.se_loc
end;
raise Errors.Error
@ -181,14 +186,6 @@ let find_value v = find_with_error find_value v
let find_constrs c = find_with_error find_constrs c
let find_field f = find_with_error find_field f
(** Constraints related functions *)
let (curr_size_constr : size_constraint list ref) = ref []
let add_size_constraint c =
curr_size_constr := c::(!curr_size_constr)
let get_size_constraint () =
let l = !curr_size_constr in
curr_size_constr := [];
l
(** Helper functions to work with types *)
let element_type ty =
@ -209,25 +206,6 @@ let flatten_ty_list l =
List.fold_right
(fun arg args -> match arg with Tprod l -> l@args | a -> a::args ) l []
let rec unify t1 t2 =
match t1, t2 with
| b1, b2 when b1 = b2 -> ()
| Tprod t1_list, Tprod t2_list ->
(try
List.iter2 unify t1_list t2_list
with
_ -> raise Unify
)
| Tarray (ty1, e1), Tarray (ty2, e2) ->
add_size_constraint (Cequal(e1,e2));
unify ty1 ty2
| _ -> raise Unify
let unify t1 t2 =
let ut1 = unalias_type t1 in
let ut2 = unalias_type t2 in
try unify ut1 ut2 with Unify -> error (Etype_clash(t1, t2))
let kind f ty_desc =
let ty_of_arg v = v.a_type in
let op = if ty_desc.node_stateful then Enode f else Efun f in
@ -272,10 +250,10 @@ let add_distinct_qualset n acc =
QualSet.add n acc
let add_distinct_S n acc =
if S.mem n acc then
if NamesSet.mem n acc then
error (Ealready_defined n)
else
S.add n acc
NamesSet.add n acc
(** Add two sets of names provided they are distinct *)
let add env1 env2 =
@ -337,23 +315,23 @@ let last = function | Var -> false | Last _ -> true
of field name, exp.*)
let check_field_unicity l =
let add_field acc (f,e) =
if S.mem (shortname f) acc then
if NamesSet.mem (shortname f) acc then
message e.e_loc (Ealready_defined (fullname f))
else
S.add (shortname f) acc
NamesSet.add (shortname f) acc
in
ignore (List.fold_left add_field S.empty l)
ignore (List.fold_left add_field NamesSet.empty l)
(** Checks that a field is not defined twice in a list
of field name, exp.*)
let check_static_field_unicity l =
let add_field acc (f,se) =
if S.mem (shortname f) acc then
if NamesSet.mem (shortname f) acc then
message se.se_loc (Ealready_defined (fullname f))
else
S.add (shortname f) acc
NamesSet.add (shortname f) acc
in
ignore (List.fold_left add_field S.empty l)
ignore (List.fold_left add_field NamesSet.empty l)
(** @return the qualified name and list of fields of
the type with name [n].
@ -383,17 +361,64 @@ let struct_info_from_field f =
with
Not_found -> error (Eundefined (fullname f))
let rec _unify cenv t1 t2 =
match t1, t2 with
| b1, b2 when b1 = b2 -> ()
| Tprod t1_list, Tprod t2_list ->
(try
List.iter2 (_unify cenv) t1_list t2_list
with
_ -> raise Unify
)
| Tarray (ty1, e1), Tarray (ty2, e2) ->
add_constraint_eq cenv e1 e2;
_unify cenv ty1 ty2
| _ -> raise Unify
(** { 3 Constraints related functions } *)
and (curr_constrnt : constrnt list ref) = ref []
and solve c_l =
try Static.solve Names.QualEnv.empty c_l
with Solve_failed c -> error (Estatic_constraint c)
(** [cenv] is the constant env which will be used to simplify the given constraints *)
and add_constraint cenv c =
let c = expect_static_exp cenv Initial.tbool c in
curr_constrnt := (solve [c])@(!curr_constrnt)
(** Add the constraint [c1=c2] *)
and add_constraint_eq cenv c1 c2 =
let c = mk_static_exp tbool (Sop (mk_pervasives "=",[c1;c2])) in
add_constraint cenv c
(** Add the constraint [c1<=c2] *)
and add_constraint_leq cenv c1 c2 =
let c = mk_static_exp tbool (Sop (mk_pervasives "<=",[c1;c2])) in
add_constraint cenv c
and get_constraints () =
let l = !curr_constrnt in
curr_constrnt := [];
l
and unify cenv t1 t2 =
let ut1 = unalias_type t1 in
let ut2 = unalias_type t2 in
try _unify cenv ut1 ut2 with Unify -> error (Etype_clash(t1, t2))
(** [check_type t] checks that t exists *)
let rec check_type const_env = function
and check_type cenv = function
| Tarray(ty, e) ->
let typed_e = expect_static_exp const_env (Tid Initial.pint) e in
Tarray(check_type const_env ty, typed_e)
let typed_e = expect_static_exp cenv (Tid Initial.pint) e in
Tarray(check_type cenv ty, typed_e)
| Tid ty_name -> Tid ty_name (* TODO bug ? should check that ty_name exists ? *)
| Tprod l ->
Tprod (List.map (check_type const_env) l)
| Tprod l -> Tprod (List.map (check_type cenv) l)
| Tinvalid -> Tinvalid
and typing_static_exp const_env se =
and typing_static_exp cenv se =
try
let desc, ty = match se.se_desc with
| Sint v -> Sint v, Tid Initial.pint
@ -405,30 +430,36 @@ and typing_static_exp const_env se =
let cd = Modules.find_const ln in
Svar ln, cd.Signature.c_type
with Not_found -> (* or a static parameter *)
Svar ln, QualEnv.find ln const_env)
Svar ln, QualEnv.find ln cenv)
| Sconstructor c -> Sconstructor c, find_constrs c
| Sfield c -> Sfield c, Tid (find_field c)
| Sop ({name = "="} as op, se_list) ->
let se1, se2 = assert_2 se_list in
let typed_se1, t1 = typing_static_exp cenv se1 in
let typed_se2 = expect_static_exp cenv t1 se2 in
Sop (op, [typed_se1;typed_se2]), Tid Initial.pbool
| Sop (op, se_list) ->
let ty_desc = find_value op in
let typed_se_list = typing_static_args const_env
(types_of_arg_list ty_desc.node_inputs) se_list in
Sop (op, typed_se_list),
let typed_se_list = typing_static_args cenv
(types_of_arg_list ty_desc.node_inputs) se_list
in
Sop (op, typed_se_list),
prod (types_of_arg_list ty_desc.node_outputs)
| Sarray_power (se, n_list) ->
let typed_n_list = List.map (expect_static_exp const_env Initial.tint) n_list in
let typed_se, ty = typing_static_exp const_env se in
let typed_n_list = List.map (expect_static_exp cenv Initial.tint) n_list in
let typed_se, ty = typing_static_exp cenv se in
let tarray = List.fold_left (fun ty typed_n -> Tarray(ty, typed_n)) ty typed_n_list in
Sarray_power (typed_se, typed_n_list), tarray
| Sarray [] ->
message se.se_loc Eempty_array
| Sarray (se::se_list) ->
let typed_se, ty = typing_static_exp const_env se in
let typed_se_list = List.map (expect_static_exp const_env ty) se_list in
Sarray (typed_se::typed_se_list),
let typed_se, ty = typing_static_exp cenv se in
let typed_se_list = List.map (expect_static_exp cenv ty) se_list in
Sarray (typed_se::typed_se_list),
Tarray(ty, mk_static_int ((List.length se_list) + 1))
| Stuple se_list ->
let typed_se_list, ty_list = List.split
(List.map (typing_static_exp const_env) se_list) in
(List.map (typing_static_exp cenv) se_list) in
Stuple typed_se_list, prod ty_list
| Srecord f_se_list ->
(* find the record type using the first field *)
@ -441,7 +472,7 @@ and typing_static_exp const_env se =
if List.length f_se_list <> List.length fields then
message se.se_loc Esome_fields_are_missing;
let f_se_list =
List.map (typing_static_field const_env fields
List.map (typing_static_field cenv fields
(Tid q)) f_se_list in
Srecord f_se_list, Tid q
in
@ -450,41 +481,43 @@ and typing_static_exp const_env se =
with
TypingError kind -> message se.se_loc kind
and typing_static_field const_env fields t1 (f,se) =
and typing_static_field cenv fields t1 (f,se) =
try
let ty = check_type const_env (field_assoc f fields) in
let typed_se = expect_static_exp const_env ty se in
let ty = check_type cenv (field_assoc f fields) in
let typed_se = expect_static_exp cenv ty se in
f, typed_se
with
Not_found -> message se.se_loc (Eno_such_field (t1, f))
and typing_static_args const_env expected_ty_list e_list =
and typing_static_args cenv expected_ty_list e_list =
try
List.map2 (expect_static_exp const_env) expected_ty_list e_list
List.map2 (expect_static_exp cenv) expected_ty_list e_list
with Invalid_argument _ ->
error (Earity_clash(List.length e_list, List.length expected_ty_list))
and expect_static_exp const_env exp_ty se =
let se, ty = typing_static_exp const_env se in
and expect_static_exp cenv exp_ty se =
let se, ty = typing_static_exp cenv se in
try
unify ty exp_ty; se
unify cenv ty exp_ty; se
with
_ -> message se.se_loc (Etype_clash(ty, exp_ty))
(** @return the type of the field with name [f] in the list
[fields]. [t1] is the corresponding record type and [loc] is
the location, both used for error reporting. *)
let field_type const_env f fields t1 loc =
let field_type cenv f fields t1 loc =
try
check_type const_env (field_assoc f fields)
check_type cenv (field_assoc f fields)
with
Not_found -> message loc (Eno_such_field (t1, f))
let rec typing const_env h e =
let rec typing cenv h e =
try
let typed_desc,ty = match e.e_desc with
| Econst c ->
let typed_c, ty = typing_static_exp const_env c in
let typed_c, ty = typing_static_exp cenv c in
Econst typed_c, ty
| Evar x ->
Evar x, typ_of_name h x
@ -493,7 +526,7 @@ let rec typing const_env h e =
| Eapp(op, e_list, r) ->
let ty, op, typed_e_list =
typing_app const_env h op e_list in
typing_app cenv h op e_list in
Eapp(op, typed_e_list, r), ty
| Estruct(l) ->
@ -504,26 +537,24 @@ let rec typing const_env h e =
| (f,_)::_ -> struct_info_from_field f
) in
if List.length l <> List.length fields then
message e.e_loc Esome_fields_are_missing;
if List.length l <> List.length fields
then message e.e_loc Esome_fields_are_missing;
check_field_unicity l;
let l =
List.map (typing_field
const_env h fields (Tid q)) l in
let l = List.map (typing_field cenv h fields (Tid q)) l in
Estruct l, Tid q
| Epre (None, e) ->
let typed_e,ty = typing const_env h e in
let typed_e,ty = typing cenv h e in
Epre (None, typed_e), ty
| Epre (Some c, e) ->
let typed_c, t1 = typing_static_exp const_env c in
let typed_e = expect const_env h t1 e in
let typed_c, t1 = typing_static_exp cenv c in
let typed_e = expect cenv h t1 e in
Epre(Some typed_c, typed_e), t1
| Efby (e1, e2) ->
let typed_e1, t1 = typing const_env h e1 in
let typed_e2 = expect const_env h t1 e2 in
let typed_e1, t1 = typing cenv h e1 in
let typed_e2 = expect cenv h t1 e2 in
Efby (typed_e1, typed_e2), t1
| Eiterator (it, ({ a_op = (Enode f | Efun f);
@ -537,31 +568,30 @@ let rec typing const_env h e =
let expected_ty_list =
List.map (subst_type_vars m) expected_ty_list in
let result_ty_list = List.map (subst_type_vars m) result_ty_list in
let typed_n = expect_static_exp const_env (Tid Initial.pint) n in
let typed_n = expect_static_exp cenv (Tid Initial.pint) n in
(*typing of partial application*)
let p_ty_list, expected_ty_list =
Misc.split_at (List.length pe_list) expected_ty_list in
let typed_pe_list = typing_args const_env h p_ty_list pe_list in
let typed_pe_list = typing_args cenv h p_ty_list pe_list in
(*typing of other arguments*)
let ty, typed_e_list = typing_iterator const_env h it n
let ty, typed_e_list = typing_iterator cenv h it n
expected_ty_list result_ty_list e_list in
let typed_params = typing_node_params const_env
let typed_params = typing_node_params cenv
ty_desc.node_params params in
(* add size constraints *)
let size_constrs =
instanciate_constr m ty_desc.node_params_constraints in
add_size_constraint (Clequal (mk_static_int 1, typed_n));
List.iter add_size_constraint size_constrs;
(* return the type *)
Eiterator(it, { app with a_op = op; a_params = typed_params }
, typed_n, typed_pe_list, typed_e_list, reset), ty
(* add size constraints *)
let constrs = List.map (simplify m) ty_desc.node_param_constraints in
add_constraint_leq cenv (mk_static_int 1) typed_n;
List.iter (add_constraint cenv) constrs;
(* return the type *)
Eiterator(it, { app with a_op = op; a_params = typed_params }
, typed_n, typed_pe_list, typed_e_list, reset), ty
| Eiterator _ -> assert false
| Ewhen (e, c, x) ->
let typed_e, t = typing const_env h e in
let typed_e, t = typing cenv h e in
let tn_expected = find_constrs c in
let tn_actual = typ_of_name h x in
unify tn_actual tn_expected;
unify cenv tn_actual tn_expected;
Ewhen (typed_e, c, x), t
| Emerge (x, (c1,e1)::c_e_list) ->
@ -573,7 +603,7 @@ let rec typing const_env h e =
List.fold_left
(fun c_set (c, _) ->
if QualSet.mem c c_set then message e.e_loc (Emerge_uniq c);
(try unify c_type (find_constrs c)
(try unify cenv c_type (find_constrs c)
with
TypingError(Etype_clash _) -> message e.e_loc (Emerge_mix c));
QualSet.add c c_set) c_set c_e_list in
@ -589,11 +619,11 @@ let rec typing const_env h e =
if not (QualSet.is_empty c_set_diff)
then message e.e_loc (Emerge_missing_constrs c_set_diff);
(* verify [x] is of the right type *)
unify (typ_of_name h x) c_type;
unify cenv (typ_of_name h x) c_type;
(* type *)
let typed_e1, t = typing const_env h e1 in
let typed_e1, t = typing cenv h e1 in
let typed_c_e_list =
List.map (fun (c, e) -> (c, expect const_env h t e)) c_e_list in
List.map (fun (c, e) -> (c, expect cenv h t e)) c_e_list in
Emerge (x, (c1,typed_e1)::typed_c_e_list), t
| Emerge (_, []) -> assert false
in
@ -601,68 +631,68 @@ let rec typing const_env h e =
with
TypingError(kind) -> message e.e_loc kind
and typing_field const_env h fields t1 (f, e) =
and typing_field cenv h fields t1 (f, e) =
try
let ty = check_type const_env (field_assoc f fields) in
let typed_e = expect const_env h ty e in
let ty = check_type cenv (field_assoc f fields) in
let typed_e = expect cenv h ty e in
f, typed_e
with
Not_found -> message e.e_loc (Eno_such_field (t1, f))
and expect const_env h expected_ty e =
let typed_e, actual_ty = typing const_env h e in
and expect cenv h expected_ty e =
let typed_e, actual_ty = typing cenv h e in
try
unify actual_ty expected_ty;
unify cenv actual_ty expected_ty;
typed_e
with TypingError(kind) -> message e.e_loc kind
and typing_app const_env h app e_list =
and typing_app cenv h app e_list =
match app.a_op with
| Eequal ->
let e1, e2 = assert_2 e_list in
let typed_e1, t1 = typing const_env h e1 in
let typed_e2 = expect const_env h t1 e2 in
Tid Initial.pbool, app, [typed_e1; typed_e2]
| Earrow ->
let e1, e2 = assert_2 e_list in
let typed_e1, t1 = typing const_env h e1 in
let typed_e2 = expect const_env h t1 e2 in
let typed_e1, t1 = typing cenv h e1 in
let typed_e2 = expect cenv h t1 e2 in
t1, app, [typed_e1;typed_e2]
| Eifthenelse ->
let e1, e2, e3 = assert_3 e_list in
let typed_e1 = expect const_env h
let typed_e1 = expect cenv h
(Tid Initial.pbool) e1 in
let typed_e2, t1 = typing const_env h e2 in
let typed_e3 = expect const_env h t1 e3 in
let typed_e2, t1 = typing cenv h e2 in
let typed_e3 = expect cenv h t1 e3 in
t1, app, [typed_e1; typed_e2; typed_e3]
| Efun {name = "="} ->
let e1, e2 = assert_2 e_list in
let typed_e1, t1 = typing cenv h e1 in
let typed_e2 = expect cenv h t1 e2 in
Tid Initial.pbool, app, [typed_e1; typed_e2]
| (Efun f | Enode f) ->
let ty_desc = find_value f in
let op, expected_ty_list, result_ty_list = kind f ty_desc in
let node_params = List.map (fun { p_name = n } -> local_qn n) ty_desc.node_params in
let m = build_subst node_params app.a_params in
let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in
let typed_e_list = typing_args const_env h expected_ty_list e_list in
let typed_e_list = typing_args cenv h expected_ty_list e_list in
let result_ty_list = List.map (subst_type_vars m) result_ty_list in
(* Type static parameters and generate constraints *)
let typed_params = typing_node_params const_env ty_desc.node_params app.a_params in
let size_constrs = instanciate_constr m ty_desc.node_params_constraints in
List.iter add_size_constraint size_constrs;
let typed_params = typing_node_params cenv ty_desc.node_params app.a_params in
let constrs = List.map (simplify m) ty_desc.node_param_constraints in
List.iter (add_constraint cenv) constrs;
prod result_ty_list,
{ app with a_op = op; a_params = typed_params },
typed_e_list
| Etuple ->
let typed_e_list,ty_list =
List.split (List.map (typing const_env h) e_list) in
List.split (List.map (typing cenv h) e_list) in
prod ty_list, app, typed_e_list
| Earray ->
let exp, e_list = assert_1min e_list in
let typed_exp, t1 = typing const_env h exp in
let typed_e_list = List.map (expect const_env h t1) e_list in
let typed_exp, t1 = typing cenv h exp in
let typed_e_list = List.map (expect cenv h t1) e_list in
let n = mk_static_int (List.length e_list + 1) in
Tarray(t1, n), app, typed_exp::typed_e_list
@ -673,83 +703,82 @@ and typing_app const_env h app e_list =
(match f.se_desc with
| Sfield fn -> fn
| _ -> assert false) in
let typed_e, t1 = typing const_env h e in
let typed_e, t1 = typing cenv h e in
let fields = struct_info t1 in
let t2 = field_type const_env fn fields t1 e.e_loc in
let t2 = field_type cenv fn fields t1 e.e_loc in
t2, app, [typed_e]
| Efield_update ->
let e1, e2 = assert_2 e_list in
let f = assert_1 app.a_params in
let typed_e1, t1 = typing const_env h e1 in
let typed_e1, t1 = typing cenv h e1 in
let fields = struct_info t1 in
let fn =
(match f.se_desc with
| Sfield fn -> fn
| _ -> assert false) in
let t2 = field_type const_env fn fields t1 e1.e_loc in
let typed_e2 = expect const_env h t2 e2 in
let t2 = field_type cenv fn fields t1 e1.e_loc in
let typed_e2 = expect cenv h t2 e2 in
t1, app, [typed_e1; typed_e2]
| Earray_fill ->
let _, _ = assert_1min app.a_params in
let e1 = assert_1 e_list in
let typed_n_list = List.map (expect_static_exp const_env Initial.tint) app.a_params in
let typed_e1, t1 = typing const_env h e1 in
List.map (fun typed_n -> add_size_constraint (Clequal (mk_static_int 1, typed_n))) typed_n_list;
(List.fold_left (fun t1 typed_n -> Tarray (t1, typed_n)) t1 typed_n_list), { app with a_params = typed_n_list }, [typed_e1]
let typed_n_list = List.map (expect_static_exp cenv Initial.tint) app.a_params in
let typed_e1, t1 = typing cenv h e1 in
List.iter (fun typed_n -> add_constraint_leq cenv (mk_static_int 1) typed_n) typed_n_list;
(List.fold_left (fun t1 typed_n -> Tarray (t1, typed_n)) t1 typed_n_list),
{ app with a_params = typed_n_list }, [typed_e1]
| Eselect ->
let e1 = assert_1 e_list in
let typed_e1, t1 = typing const_env h e1 in
let typed_e1, t1 = typing cenv h e1 in
let typed_idx_list, ty =
typing_array_subscript const_env h app.a_params t1 in
typing_array_subscript cenv h app.a_params t1 in
ty, { app with a_params = typed_idx_list }, [typed_e1]
| Eselect_dyn ->
let e1, defe, idx_list = assert_2min e_list in
let typed_e1, t1 = typing const_env h e1 in
let typed_defe = expect const_env h (element_type t1) defe in
let typed_e1, t1 = typing cenv h e1 in
let typed_defe = expect cenv h (element_type t1) defe in
let ty, typed_idx_list =
typing_array_subscript_dyn const_env h idx_list t1 in
typing_array_subscript_dyn cenv h idx_list t1 in
ty, app, typed_e1::typed_defe::typed_idx_list
| Eselect_trunc ->
let e1, idx_list = assert_1min e_list in
let typed_e1, t1 = typing const_env h e1 in
let typed_e1, t1 = typing cenv h e1 in
let ty, typed_idx_list =
typing_array_subscript_dyn const_env h idx_list t1 in
typing_array_subscript_dyn cenv h idx_list t1 in
ty, app, typed_e1::typed_idx_list
| Eupdate ->
let e1, e2, idx_list = assert_2min e_list in
let typed_e1, t1 = typing const_env h e1 in
let typed_e1, t1 = typing cenv h e1 in
let ty, typed_idx_list =
typing_array_subscript_dyn const_env h idx_list t1 in
let typed_e2 = expect const_env h ty e2 in
typing_array_subscript_dyn cenv h idx_list t1 in
let typed_e2 = expect cenv h ty e2 in
t1, app, typed_e1::typed_e2::typed_idx_list
| Eselect_slice ->
let e = assert_1 e_list in
let idx1, idx2 = assert_2 app.a_params in
let typed_idx1 = expect_static_exp const_env (Tid Initial.pint) idx1 in
let typed_idx2 = expect_static_exp const_env (Tid Initial.pint) idx2 in
let typed_e, t1 = typing const_env h e in
let typed_idx1 = expect_static_exp cenv (Tid Initial.pint) idx1 in
let typed_idx2 = expect_static_exp cenv (Tid Initial.pint) idx2 in
let typed_e, t1 = typing cenv h e in
(*Create the expression to compute the size of the array *)
let e1 =
mk_static_int_op (mk_pervasives "-") [typed_idx2; typed_idx1] in
let e2 =
mk_static_int_op (mk_pervasives "+") [e1;mk_static_int 1 ] in
add_size_constraint (Clequal (mk_static_int 1, e2));
let e1 = mk_static_int_op (mk_pervasives "-") [typed_idx2; typed_idx1] in
let e2 = mk_static_int_op (mk_pervasives "+") [e1;mk_static_int 1 ] in
add_constraint_leq cenv (mk_static_int 1) e2;
Tarray (element_type t1, e2),
{ app with a_params = [typed_idx1; typed_idx2] }, [typed_e]
| Econcat ->
let e1, e2 = assert_2 e_list in
let typed_e1, t1 = typing const_env h e1 in
let typed_e2, t2 = typing const_env h e2 in
let typed_e1, t1 = typing cenv h e1 in
let typed_e2, t2 = typing cenv h e2 in
begin try
unify (element_type t1) (element_type t2)
unify cenv (element_type t1) (element_type t2)
with
TypingError(kind) -> message e1.e_loc kind
end;
@ -759,13 +788,13 @@ and typing_app const_env h app e_list =
and typing_iterator const_env h
and typing_iterator cenv h
it n args_ty_list result_ty_list e_list = match it with
| Imap ->
let args_ty_list = List.map (fun ty -> Tarray(ty, n)) args_ty_list in
let result_ty_list =
List.map (fun ty -> Tarray(ty, n)) result_ty_list in
let typed_e_list = typing_args const_env h
let typed_e_list = typing_args cenv h
args_ty_list e_list in
prod result_ty_list, typed_e_list
@ -775,9 +804,9 @@ and typing_iterator const_env h
let result_ty_list =
List.map (fun ty -> Tarray(ty, n)) result_ty_list in
(* Last but one arg of the function should be integer *)
( try unify idx_ty (Tid Initial.pint)
( try unify cenv idx_ty (Tid Initial.pint)
with TypingError _ -> raise (TypingError (Emapi_bad_args idx_ty)));
let typed_e_list = typing_args const_env h
let typed_e_list = typing_args cenv h
args_ty_list e_list in
prod result_ty_list, typed_e_list
@ -785,10 +814,10 @@ and typing_iterator const_env h
let args_ty_list =
map_butlast (fun ty -> Tarray (ty, n)) args_ty_list in
let typed_e_list =
typing_args const_env h args_ty_list e_list in
typing_args cenv h args_ty_list e_list in
(*check accumulator type matches in input and output*)
if List.length result_ty_list > 1 then error Etoo_many_outputs;
( try unify (last_element args_ty_list) (List.hd result_ty_list)
( try unify cenv (last_element args_ty_list) (List.hd result_ty_list)
with TypingError(kind) -> message (List.hd e_list).e_loc kind );
(List.hd result_ty_list), typed_e_list
@ -796,15 +825,15 @@ and typing_iterator const_env h
let args_ty_list, acc_ty = split_last args_ty_list in
let args_ty_list, idx_ty = split_last args_ty_list in
(* Last but one arg of the function should be integer *)
( try unify idx_ty (Tid Initial.pint)
( try unify cenv idx_ty (Tid Initial.pint)
with TypingError _ -> raise (TypingError (Efoldi_bad_args idx_ty)));
let args_ty_list =
map_butlast (fun ty -> Tarray (ty, n)) (args_ty_list@[acc_ty]) in
let typed_e_list =
typing_args const_env h args_ty_list e_list in
typing_args cenv h args_ty_list e_list in
(*check accumulator type matches in input and output*)
if List.length result_ty_list > 1 then error Etoo_many_outputs;
( try unify (last_element args_ty_list) (List.hd result_ty_list)
( try unify cenv (last_element args_ty_list) (List.hd result_ty_list)
with TypingError(kind) -> message (List.hd e_list).e_loc kind );
(List.hd result_ty_list), typed_e_list
@ -813,52 +842,51 @@ and typing_iterator const_env h
map_butlast (fun ty -> Tarray (ty, n)) args_ty_list in
let result_ty_list =
map_butlast (fun ty -> Tarray (ty, n)) result_ty_list in
let typed_e_list = typing_args const_env h
let typed_e_list = typing_args cenv h
args_ty_list e_list in
(*check accumulator type matches in input and output*)
( try unify (last_element args_ty_list) (last_element result_ty_list)
( try unify cenv (last_element args_ty_list) (last_element result_ty_list)
with TypingError(kind) -> message (List.hd e_list).e_loc kind );
prod result_ty_list, typed_e_list
and typing_array_subscript const_env h idx_list ty =
and typing_array_subscript cenv h idx_list ty =
match unalias_type ty, idx_list with
| ty, [] -> [], ty
| Tarray(ty, exp), idx::idx_list ->
ignore (expect_static_exp const_env (Tid Initial.pint) exp);
let typed_idx = expect_static_exp const_env (Tid Initial.pint) idx in
add_size_constraint (Clequal (mk_static_int 0, idx));
let bound =
mk_static_int_op (mk_pervasives "-") [exp; mk_static_int 1] in
add_size_constraint (Clequal (idx,bound));
let typed_idx_list, ty =
typing_array_subscript const_env h idx_list ty in
ignore (expect_static_exp cenv (Tid Initial.pint) exp);
let typed_idx = expect_static_exp cenv (Tid Initial.pint) idx in
add_constraint_leq cenv (mk_static_int 0) idx;
let bound = mk_static_int_op (mk_pervasives "-") [exp; mk_static_int 1] in
add_constraint_leq cenv idx bound;
let typed_idx_list, ty = typing_array_subscript cenv h idx_list ty in
typed_idx::typed_idx_list, ty
| _, _ -> error (Esubscripted_value_not_an_array ty)
(* This function checks that the array dimensions matches
the subscript. It returns the base type wrt the nb of indices. *)
and typing_array_subscript_dyn const_env h idx_list ty =
and typing_array_subscript_dyn cenv h idx_list ty =
match unalias_type ty, idx_list with
| ty, [] -> ty, []
| Tarray(ty, _), idx::idx_list ->
let typed_idx = expect const_env h (Tid Initial.pint) idx in
let typed_idx = expect cenv h (Tid Initial.pint) idx in
let ty, typed_idx_list =
typing_array_subscript_dyn const_env h idx_list ty in
typing_array_subscript_dyn cenv h idx_list ty in
ty, typed_idx::typed_idx_list
| _, _ -> error (Esubscripted_value_not_an_array ty)
and typing_args const_env h expected_ty_list e_list =
and typing_args cenv h expected_ty_list e_list =
let typed_e_list, args_ty_list =
List.split (List.map (typing const_env h) e_list) in
List.split (List.map (typing cenv h) e_list)
in
let args_ty_list = flatten_ty_list args_ty_list in
(match args_ty_list, expected_ty_list with
| [], [] -> ()
| _, _ ->
unify (prod args_ty_list) (prod expected_ty_list));
(match args_ty_list, expected_ty_list with
| [], [] -> ()
| _, _ -> unify cenv (prod args_ty_list) (prod expected_ty_list)
);
typed_e_list
and typing_node_params const_env params_sig params =
List.map2 (fun p_sig p -> expect_static_exp const_env
and typing_node_params cenv params_sig params =
List.map2 (fun p_sig p -> expect_static_exp cenv
p_sig.p_type p) params_sig params
@ -875,59 +903,59 @@ let rec typing_pat h acc = function
pat_list (acc, []) in
acc, Tprod(ty_list)
let rec typing_eq const_env h acc eq =
let rec typing_eq cenv h acc eq =
let typed_desc,acc = match eq.eq_desc with
| Eautomaton(state_handlers) ->
let typed_sh,acc =
typing_automaton_handlers const_env h acc state_handlers in
typing_automaton_handlers cenv h acc state_handlers in
Eautomaton(typed_sh),
acc
| Eswitch(e, switch_handlers) ->
let typed_e,ty = typing const_env h e in
let typed_e,ty = typing cenv h e in
let typed_sh,acc =
typing_switch_handlers const_env h acc ty switch_handlers in
typing_switch_handlers cenv h acc ty switch_handlers in
Eswitch(typed_e,typed_sh),
acc
| Epresent(present_handlers, b) ->
let typed_b, def_names, _ = typing_block const_env h b in
let typed_b, def_names, _ = typing_block cenv h b in
let typed_ph, acc =
typing_present_handlers const_env h
typing_present_handlers cenv h
acc def_names present_handlers in
Epresent(typed_ph,typed_b),
acc
| Ereset(b, e) ->
let typed_e = expect const_env h (Tid Initial.pbool) e in
let typed_b, def_names, _ = typing_block const_env h b in
let typed_e = expect cenv h (Tid Initial.pbool) e in
let typed_b, def_names, _ = typing_block cenv h b in
Ereset(typed_b, typed_e),
Env.union def_names acc
| Eblock b ->
let typed_b, def_names, _ = typing_block const_env h b in
let typed_b, def_names, _ = typing_block cenv h b in
Eblock typed_b,
Env.union def_names acc
| Eeq(pat, e) ->
let acc, ty_pat = typing_pat h acc pat in
let typed_e = expect const_env h ty_pat e in
let typed_e = expect cenv h ty_pat e in
Eeq(pat, typed_e),
acc in
{ eq with eq_desc = typed_desc }, acc
and typing_eq_list const_env h acc eq_list =
mapfold (typing_eq const_env h) acc eq_list
and typing_eq_list cenv h acc eq_list =
mapfold (typing_eq cenv h) acc eq_list
and typing_automaton_handlers const_env h acc state_handlers =
and typing_automaton_handlers cenv h acc state_handlers =
(* checks unicity of states *)
let addname acc { s_state = n } =
add_distinct_S n acc in
let states = List.fold_left addname S.empty state_handlers in
let states = List.fold_left addname NamesSet.empty state_handlers in
let escape h ({ e_cond = e; e_next_state = n } as esc) =
if not (S.mem n states) then error (Eundefined(n));
let typed_e = expect const_env h (Tid Initial.pbool) e in
if not (NamesSet.mem n states) then error (Eundefined(n));
let typed_e = expect cenv h (Tid Initial.pbool) e in
{ esc with e_cond = typed_e } in
let handler ({ s_block = b; s_until = e_list1;
s_unless = e_list2 } as s) =
let typed_b, defined_names, h0 = typing_block const_env h b in
let typed_b, defined_names, h0 = typing_block cenv h b in
let typed_e_list1 = List.map (escape h0) e_list1 in
let typed_e_list2 = List.map (escape h) e_list2 in
{ s with
@ -943,7 +971,7 @@ and typing_automaton_handlers const_env h acc state_handlers =
typed_handlers,
(add total (add partial acc))
and typing_switch_handlers const_env h acc ty switch_handlers =
and typing_switch_handlers cenv h acc ty switch_handlers =
(* checks unicity of states *)
let addname acc { w_name = n } = add_distinct_qualset n acc in
let cases = List.fold_left addname QualSet.empty switch_handlers in
@ -952,7 +980,7 @@ and typing_switch_handlers const_env h acc ty switch_handlers =
error (Epartial_switch (fullname (QualSet.choose d)));
let handler ({ w_block = b } as sh) =
let typed_b, defined_names, _ = typing_block const_env h b in
let typed_b, defined_names, _ = typing_block cenv h b in
{ sh with w_block = typed_b }, defined_names in
let typed_switch_handlers, defined_names_list =
@ -962,11 +990,11 @@ and typing_switch_handlers const_env h acc ty switch_handlers =
(typed_switch_handlers,
add total (add partial acc))
and typing_present_handlers const_env h acc def_names
and typing_present_handlers cenv h acc def_names
present_handlers =
let handler ({ p_cond = e; p_block = b }) =
let typed_e = expect const_env h (Tid Initial.pbool) e in
let typed_b, defined_names, _ = typing_block const_env h b in
let typed_e = expect cenv h (Tid Initial.pbool) e in
let typed_b, defined_names, _ = typing_block cenv h b in
{ p_cond = typed_e; p_block = typed_b },
defined_names
in
@ -978,12 +1006,12 @@ and typing_present_handlers const_env h acc def_names
(typed_present_handlers,
(add total (add partial acc)))
and typing_block const_env h
and typing_block cenv h
({ b_local = l; b_equs = eq_list; b_loc = loc } as b) =
try
let typed_l, (local_names, h0) = build const_env h l in
let typed_l, (local_names, h0) = build cenv h l in
let typed_eq_list, defined_names =
typing_eq_list const_env h0 Env.empty eq_list in
typing_eq_list cenv h0 Env.empty eq_list in
let defnames = diff_env defined_names local_names in
{ b with
b_defnames = defnames;
@ -998,13 +1026,13 @@ and typing_block const_env h
@return the typed list of var_dec, an environment mapping
names to their types (aka defined names) and the environment
mapping names to types and last that will be used for typing (aka h).*)
and build const_env h dec =
and build cenv h dec =
let var_dec (acc_defined, h) vd =
try
let ty = check_type const_env vd.v_type in
let ty = check_type cenv vd.v_type in
let last_dec = match vd.v_last with
| Last (Some se) -> Last (Some (expect_static_exp const_env ty se))
| Last (Some se) -> Last (Some (expect_static_exp cenv ty se))
| Var | Last None -> vd.v_last in
if Env.mem vd.v_ident h then
@ -1018,70 +1046,63 @@ and build const_env h dec =
in
mapfold var_dec (Env.empty, h) dec
let typing_contract const_env h contract =
let typing_contract cenv h contract =
match contract with
| None -> None,h
| Some ({ c_block = b;
c_assume = e_a;
c_enforce = e_g;
c_controllables = c }) ->
let typed_b, defined_names, _ = typing_block const_env h b in
let typed_b, defined_names, _ = typing_block cenv h b in
(* check that the equations do not define other unexpected names *)
included_env defined_names Env.empty;
(* assumption *)
let typed_e_a = expect const_env h (Tid Initial.pbool) e_a in
let typed_e_a = expect cenv h (Tid Initial.pbool) e_a in
(* property *)
let typed_e_g = expect const_env h (Tid Initial.pbool) e_g in
let typed_e_g = expect cenv h (Tid Initial.pbool) e_g in
let typed_c, (c_names, h) = build const_env h c in
let typed_c, (c_names, h) = build cenv h c in
Some { c_block = typed_b;
c_assume = typed_e_a;
c_enforce = typed_e_g;
c_controllables = typed_c }, h
let solve loc cl =
try
solve QualEnv.empty cl
with
Solve_failed c -> message loc (Econstraint_solve_failed c)
let build_node_params const_env l =
let build_node_params cenv l =
let check_param env p =
let ty = check_type const_env p.p_type in
let ty = check_type cenv p.p_type in
let p = { p with p_type = ty } in
let n = Names.local_qn p.p_name in
p, QualEnv.add n ty env
in
mapfold check_param const_env l
mapfold check_param cenv l
let node ({ n_name = f; n_input = i_list; n_output = o_list;
n_contract = contract;
n_block = b; n_loc = loc;
n_params = node_params; } as n) =
try
let typed_params, const_env =
let typed_params, cenv =
build_node_params QualEnv.empty node_params in
let typed_i_list, (input_names, h) =
build const_env Env.empty i_list in
let typed_o_list, (output_names, h) = build const_env h o_list in
let typed_i_list, (input_names, h) = build cenv Env.empty i_list in
let typed_o_list, (output_names, h) = build cenv h o_list in
(* typing contract *)
let typed_contract, h =
typing_contract const_env h contract in
let typed_contract, h = typing_contract cenv h contract in
let typed_b, defined_names, _ = typing_block const_env h b in
(* check that the defined names match exactly the outputs and locals *)
included_env defined_names output_names;
included_env output_names defined_names;
let typed_b, defined_names, _ = typing_block cenv h b in
(* check that the defined names match exactly the outputs and locals *)
included_env defined_names output_names;
included_env output_names defined_names;
(* update the node signature to add static params constraints *)
let cl = get_size_constraint () in
let cl = solve loc cl in
let s = find_value f in
replace_value f { s with node_params_constraints = cl };
let cl = List.map (expect_static_exp cenv Initial.tbool) s.node_param_constraints in
let cl = cl @ get_constraints () in
let cl = solve cl in
replace_value f { s with node_param_constraints = cl };
{ n with
n_input = typed_i_list;

2
compiler/heptagon/hept_mapfold.ml
View file

@ -285,7 +285,7 @@ and program_desc_it funs acc pd =
with Fallback -> program_desc funs acc pd
and program_desc funs acc pd = match pd with
| Pconst cd -> let cd, acc = const_dec_it funs acc cd in Pconst cd, acc
| Ptype td -> pd, acc
| Ptype td -> pd, acc (* TODO types *)
| Pnode n -> let n, acc = node_dec_it funs acc n in Pnode n, acc
let defaults = {

14
compiler/heptagon/hept_printer.ml
View file

@ -63,6 +63,9 @@ let print_const_dec ff c =
fprintf ff "const %a = %a@."
print_qualname c.c_name print_static_exp c.c_value
let print_ct_annot ff = function
| None -> ()
| Some ct -> fprintf ff " :: %a" print_ct ct
let rec print_params ff l =
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "<<"","">>") l
@ -90,9 +93,9 @@ and print_exps ff e_list =
and print_exp ff e =
if !Compiler_options.full_type_info then
fprintf ff "(%a : %a)"
print_exp_desc e.e_desc print_type e.e_ty
else fprintf ff "%a" print_exp_desc e.e_desc
fprintf ff "(%a : %a%a)"
print_exp_desc e.e_desc print_type e.e_ty print_ct_annot e.e_ct_annot
else fprintf ff "%a%a" print_exp_desc e.e_desc print_ct_annot e.e_ct_annot
and print_exp_desc ff = function
| Evar x -> print_ident ff x
@ -134,9 +137,6 @@ and print_every ff reset =
and print_app ff (app, args) =
match app.a_op with
| Eequal ->
let e1, e2 = assert_2 args in
fprintf ff "@[<2>%a@ = %a@]" print_exp e1 print_exp e2
| Etuple -> print_exp_tuple ff args
| Efun f | Enode f ->
fprintf ff "@[%a@,%a@,%a@]"
@ -157,7 +157,7 @@ and print_app ff (app, args) =
| Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args
| Earray_fill ->
let e = assert_1 args in
fprintf ff "%a@[<2>%a@]" print_exp e (print_list print_static_exp "^""^""") app.a_params
fprintf ff "%a@[<2>%a@]" print_exp e (print_list print_static_exp "^""^""") app.a_params
| Eselect ->
let e = assert_1 args in
fprintf ff "%a%a" print_exp e print_index app.a_params

26
compiler/heptagon/hept_utils.ml
View file

@ -19,9 +19,10 @@ open Initial
open Heptagon
(* Helper functions to create AST. *)
let mk_exp desc ?(ct_annot = Clocks.invalid_clock) ?(loc = no_location) ty =
(* TODO : After switch, all mk_exp should take care of level_ck *)
let mk_exp desc ?(level_ck = Cbase) ?(ct_annot = None) ?(loc = no_location) ty =
{ e_desc = desc; e_ty = ty; e_ct_annot = ct_annot;
e_base_ck = Cbase; e_loc = loc; }
e_level_ck = level_ck; e_loc = loc; }
let mk_app ?(params=[]) ?(unsafe=false) op =
{ a_op = op; a_params = params; a_unsafe = unsafe }
@ -60,16 +61,17 @@ let mk_simple_equation pat e =
let mk_switch_equation e l =
mk_equation (Eswitch (e, l))
let mk_signature name ins outs stateful params loc =
let mk_signature name ins outs stateful params constraints loc =
{ sig_name = name;
sig_inputs = ins;
sig_stateful = stateful;
sig_outputs = outs;
sig_params = params;
sig_param_constraints = constraints;
sig_loc = loc }
let mk_node
?(input = []) ?(output = []) ?(contract = None) ?(local = [])
?(input = []) ?(output = []) ?(contract = None)
?(stateful = true) ?(loc = no_location) ?(param = []) ?(constraints = [])
name block =
{ n_name = name;
@ -80,7 +82,7 @@ let mk_node
n_block = block;
n_loc = loc;
n_params = param;
n_params_constraints = constraints }
n_param_constraints = constraints }
(** @return the set of variables defined in [pat]. *)
let vars_pat pat =
@ -97,3 +99,17 @@ let vars_pat pat =
let rec vd_mem n = function
| [] -> false
| vd::l -> vd.v_ident = n or (vd_mem n l)
let args_of_var_decs =
(* before the clocking the clock is wrong in the signature *)
List.map (fun vd -> Signature.mk_arg (Some (Idents.source_name vd.v_ident))
vd.v_type Signature.Cbase)
let signature_of_node n =
{ node_inputs = args_of_var_decs n.n_input;
node_outputs = args_of_var_decs n.n_output;
node_stateful = n.n_stateful;
node_params = n.n_params;
node_param_constraints = n.n_param_constraints;
node_loc = n.n_loc }

114
compiler/heptagon/heptagon.ml
View file

@ -29,8 +29,8 @@ type iterator_type =
type exp = {
e_desc : desc;
e_ty : ty;
e_ct_annot : ct;
e_base_ck : ck;
e_ct_annot : ct option; (* exists when a source annotation exists *)
e_level_ck : ck; (* set by the switch pass, represents the activation base of the expression *)
e_loc : location }
and desc =
@ -55,7 +55,6 @@ and app = {
a_unsafe : bool }
and op =
| Eequal
| Etuple
| Efun of fun_name
| Enode of fun_name
@ -142,15 +141,15 @@ type contract = {
c_block : block }
type node_dec = {
n_name : qualname;
n_stateful : 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 }
n_name : qualname;
n_stateful : 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_param_constraints : constrnt list }
type const_dec = {
c_name : qualname;
@ -170,12 +169,13 @@ and program_desc =
type signature = {
sig_name : qualname;
sig_inputs : arg list;
sig_stateful : bool;
sig_outputs : arg list;
sig_params : param list;
sig_loc : location }
sig_name : qualname;
sig_inputs : arg list;
sig_stateful : bool;
sig_outputs : arg list;
sig_params : param list;
sig_param_constraints : constrnt list;
sig_loc : location }
type interface = interface_decl list
@ -188,82 +188,4 @@ and interface_desc =
| Itypedef of type_dec
| Iconstdef of const_dec
| Isignature of signature
(*
(* Helper functions to create AST. *)
let mk_exp desc ?(ct_annot = Clocks.invalid_clock) ?(loc = no_location) ty =
{ e_desc = desc; e_ty = ty; e_ct_annot = ct_annot;
e_base_ck = Cbase; e_loc = loc; }
let mk_app ?(params=[]) ?(unsafe=false) op =
{ a_op = op; a_params = params; a_unsafe = unsafe }
let mk_op_app ?(params=[]) ?(unsafe=false) ?(reset=None) op args =
Eapp(mk_app ~params:params ~unsafe:unsafe op, args, reset)
let mk_type_dec name desc =
{ t_name = name; t_desc = desc; t_loc = no_location; }
let mk_equation stateful desc =
{ eq_desc = desc; eq_stateful = stateful; eq_loc = no_location; }
let mk_var_dec ?(last = Var) ?(clock = fresh_clock()) name ty =
{ v_ident = name; v_type = ty; v_clock = clock;
v_last = last; v_loc = no_location }
let mk_block stateful ?(defnames = Env.empty) ?(locals = []) eqs =
{ b_local = locals; b_equs = eqs; b_defnames = defnames;
b_stateful = stateful; b_loc = no_location; }
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 = mk_op_app Eifthenelse [e1; e2; e3] }
let mk_simple_equation stateful pat e =
mk_equation stateful (Eeq(pat, e))
let mk_switch_equation stateful e l =
mk_equation stateful (Eswitch (e, l))
let mk_signature name ins outs stateful params loc =
{ sig_name = name;
sig_inputs = ins;
sig_stateful = stateful;
sig_outputs = outs;
sig_params = params;
sig_loc = loc }
let mk_node
?(input = []) ?(output = []) ?(contract = None) ?(local = [])
?(stateful = true) ?(loc = no_location) ?(param = []) ?(constraints = [])
name block =
{ n_name = name;
n_stateful = stateful;
n_input = input;
n_output = output;
n_contract = contract;
n_block = block;
n_loc = loc;
n_params = param;
n_params_constraints = constraints }
(** @return the set of variables defined in [pat]. *)
let vars_pat pat =
let rec _vars_pat locals acc = function
| Evarpat x ->
if (IdentSet.mem x locals) or (IdentSet.mem x acc)
then acc
else IdentSet.add x acc
| Etuplepat pat_list -> List.fold_left (_vars_pat locals) acc pat_list
in _vars_pat IdentSet.empty IdentSet.empty pat
(** @return 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)
*)

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

@ -19,8 +19,6 @@ let compile_program p =
let p = silent_pass "Statefulness check" true Stateful.program p in
let p = pass "Typing" true Typing.program p pp in
if !print_types then print_interface Format.std_formatter;
(* Causality check *)
let p = silent_pass "Causality check" !causality Causality.program p in

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

@ -54,7 +54,10 @@ List.iter (fun (str,tok) -> Hashtbl.add keyword_table str tok) [
"enforce", ENFORCE;
"with", WITH;
"when", WHEN;
"whenot", WHENOT;
"merge", MERGE;
"on", ON;
"onot", ONOT;
"map", MAP;
"mapi", MAPI;
"fold", FOLD;
@ -122,13 +125,14 @@ rule token = parse
| [' ' '\t'] + { token lexbuf }
| "." {DOT}
| "(" {LPAREN}
| "(<" {LPAREN_LESS}
| "<(" {LESS_LPAREN}
| ")" {RPAREN}
| ">)" {GREATER_RPAREN}
| ")>" {RPAREN_GREATER}
| "*" { STAR }
| "{" {LBRACE}
| "}" {RBRACE}
| ":" {COLON}
| "::" {COLONCOLON}
| ";" {SEMICOL}
| "=" {EQUAL}
| "==" {EQUALEQUAL}

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

@ -9,7 +9,7 @@ open Hept_parsetree
%}
%token DOT LPAREN LPAREN_LESS RPAREN GREATER_RPAREN LBRACE RBRACE COLON SEMICOL
%token DOT LPAREN LESS_LPAREN RPAREN RPAREN_GREATER LBRACE RBRACE COLON COLONCOLON SEMICOL
%token EQUAL EQUALEQUAL LESS_GREATER BARBAR COMMA BAR ARROW LET TEL
%token <string> Constructor
%token <string> IDENT
@ -39,7 +39,7 @@ open Hept_parsetree
%token ASSUME
%token ENFORCE
%token WITH
%token WHEN MERGE
%token WHEN WHENOT MERGE ON ONOT
%token POWER
%token LBRACKET LBRACKETGREATER
%token RBRACKET LESSRBRACKET
@ -65,7 +65,7 @@ open Hept_parsetree
%left AMPERSAND
%left INFIX0 EQUAL LESS_GREATER
%right INFIX1
%right WHEN
%right WHEN WHENOT
%left INFIX2 SUBTRACTIVE
%left STAR INFIX3
%left INFIX4
@ -160,16 +160,17 @@ label_ty:
;
node_dec:
| node_or_fun ident node_params LPAREN in_params RPAREN
RETURNS LPAREN out_params RPAREN
contract b=block(LET) TEL
{{ n_name = $2;
n_stateful = $1;
n_input = $5;
n_output = $9;
n_contract = $11;
| n=node_or_fun f=ident pc=node_params LPAREN i=in_params RPAREN
RETURNS LPAREN o=out_params RPAREN
c=contract b=block(LET) TEL
{{ n_name = f;
n_stateful = n;
n_input = i;
n_output = o;
n_contract = c;
n_block = b;
n_params = $3;
n_params = fst pc;
n_constraints = snd pc;
n_loc = (Loc($startpos,$endpos)) }}
;
@ -193,8 +194,8 @@ nonmt_params:
;
param:
| ident_list COLON ty_ident
{ List.map (fun id -> mk_var_dec id $3 Var (Loc($startpos,$endpos))) $1 }
| idl=ident_list COLON ty=ty_ident ck=ck_annot
{ List.map (fun id -> mk_var_dec id ty ck Var (Loc($startpos,$endpos))) idl }
;
out_params:
@ -207,9 +208,13 @@ nonmt_out_params:
| var_last SEMICOL nonmt_out_params { $1 @ $3 }
;
constraints:
| /*empty*/ {[]}
| BAR l=slist(SEMICOL, exp) { l }
node_params:
| /* empty */ { [] }
| DOUBLE_LESS nonmt_params DOUBLE_GREATER { $2 }
| /* empty */ { [],[] }
| DOUBLE_LESS p=nonmt_params c=constraints DOUBLE_GREATER { p,c }
;
contract:
@ -248,12 +253,12 @@ loc_params:
var_last:
| ident_list COLON ty_ident
{ 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)) (Loc($startpos,$endpos)) ] }
| idl=ident_list COLON ty=ty_ident ck=ck_annot
{ List.map (fun id -> mk_var_dec id ty ck Var (Loc($startpos,$endpos))) idl }
| LAST id=IDENT COLON ty=ty_ident ck=ck_annot EQUAL e=exp
{ [ mk_var_dec id ty ck (Last(Some(e))) (Loc($startpos,$endpos)) ] }
| LAST id=IDENT COLON ty=ty_ident ck=ck_annot
{ [ mk_var_dec id ty ck (Last(None)) (Loc($startpos,$endpos)) ] }
;
ident_list:
@ -268,6 +273,30 @@ ty_ident:
{ Tarray ($1, $3) }
;
ct_annot:
| /*empty */ { None }
| COLONCOLON ck=ck
| ON ck=on_ck { Some(Ck ck) }
ck_annot:
| /*empty */ { None }
| COLONCOLON ck=ck
| ON ck=on_ck { Some ck }
ck:
| DOT { Cbase }
| ck=on_ck { ck }
on_ck:
| x=IDENT { Con(Cbase,Q Initial.ptrue,x) }
| c=constructor_or_bool LPAREN x=IDENT RPAREN { Con(Cbase,c,x) }
| b=ck ON x=IDENT { Con(b,Q Initial.ptrue,x) }
| b=ck ONOT x=IDENT { Con(b,Q Initial.pfalse,x) }
| b=ck ON c=constructor_or_bool LPAREN x=IDENT RPAREN { Con(b,c,x) }
equs:
| /* empty */ { [] }
| eqs=optsnlist(SEMICOL,equ) { eqs }
@ -400,7 +429,7 @@ exps:
simple_exp:
| e=_simple_exp { mk_exp e (Loc($startpos,$endpos)) }
| LPAREN exp RPAREN { $2 }
| LPAREN e=exp ct=ct_annot RPAREN { { e with e_ct_annot = ct} }
_simple_exp:
| IDENT { Evar $1 }
| const { Econst $1 }
@ -439,6 +468,10 @@ _exp:
{ mk_op_call $2 [$1; $3] }
| e=exp WHEN c=constructor_or_bool LPAREN ce=IDENT RPAREN
{ Ewhen (e, c, ce) }
| e=exp WHEN ce=IDENT
{ Ewhen (e, Q Initial.ptrue, ce) }
| e=exp WHENOT ce=IDENT
{ Ewhen (e, Q Initial.pfalse, ce) }
| MERGE n=IDENT hs=merge_handlers
{ Emerge (n, hs) }
| exp INFIX1 exp
@ -446,9 +479,9 @@ _exp:
| exp INFIX0 exp
{ mk_op_call $2 [$1; $3] }
| exp EQUAL exp
{ mk_call Eequal [$1; $3] }
{ mk_op_call "=" [$1; $3] }
| exp LESS_GREATER exp
{ let e = mk_exp (mk_call Eequal [$1; $3]) (Loc($startpos,$endpos)) in
{ let e = mk_exp (mk_op_call "=" [$1; $3]) (Loc($startpos,$endpos)) in
mk_op_call "not" [e] }
| exp OR exp
{ mk_op_call "or" [$1; $3] }
@ -485,12 +518,12 @@ _exp:
{ mk_call Econcat [$1; $3] }
/*Iterators*/
| it=iterator DOUBLE_LESS n=simple_exp DOUBLE_GREATER q=qualname
pargs=delim_slist(COMMA, LPAREN_LESS, GREATER_RPAREN, exp)
pargs=delim_slist(COMMA, LESS_LPAREN, RPAREN_GREATER, exp)
LPAREN args=exps RPAREN
{ mk_iterator_call it q [] n pargs args }
| it=iterator DOUBLE_LESS n=simple_exp DOUBLE_GREATER
LPAREN q=qualname DOUBLE_LESS sa=array_exp_list DOUBLE_GREATER RPAREN
pargs=delim_slist(COMMA, LPAREN_LESS, GREATER_RPAREN, exp)
pargs=delim_slist(COMMA, LESS_LPAREN, RPAREN_GREATER, exp)
LPAREN args=exps RPAREN
{ mk_iterator_call it q sa n pargs args }
/*Records operators */
@ -605,13 +638,14 @@ _interface_decl:
| type_dec { Itypedef $1 }
| const_dec { Iconstdef $1 }
| OPEN modul { Iopen $2 }
| VAL node_or_fun ident node_params LPAREN params_signature RPAREN
RETURNS LPAREN params_signature RPAREN
{ Isignature({ sig_name = $3;
sig_inputs = $6;
sig_stateful = $2;
sig_outputs = $10;
sig_params = $4;
| VAL n=node_or_fun f=ident pc=node_params LPAREN i=params_signature RPAREN
RETURNS LPAREN o=params_signature RPAREN
{ Isignature({ sig_name = f;
sig_inputs = i;
sig_stateful = n;
sig_outputs = o;
sig_params = fst pc;
sig_param_constraints = snd pc;
sig_loc = (Loc($startpos,$endpos)) }) }
;
@ -626,8 +660,8 @@ nonmt_params_signature:
;
param_signature:
| IDENT COLON ty_ident { mk_arg (Some $1) $3 }
| ty_ident { mk_arg None $1 }
| IDENT COLON ty_ident ck=ck_annot { mk_arg (Some $1) $3 ck }
| ty_ident ck=ck_annot { mk_arg None $1 ck }
;
%%

69
compiler/heptagon/parsing/hept_parsetree.ml
View file

@ -61,10 +61,18 @@ type ty =
| Tid of qualname
| Tarray of ty * exp
and ck =
| Cbase
| Con of ck * constructor_name * var_name
and ct =
| Ck of ck
| Cprod of ct list
and exp =
{ e_desc : edesc;
e_ct_annot : Clocks.ct;
e_loc : location }
{ e_desc : edesc;
e_ct_annot : ct option ;
e_loc : location }
and edesc =
| Econst of static_exp
@ -81,7 +89,6 @@ and edesc =
and app = { a_op: op; a_params: exp list; }
and op =
| Eequal
| Etuple
| Enode of qualname
| Efun of qualname
@ -139,10 +146,11 @@ and present_handler =
p_block : block; }
and var_dec =
{ v_name : var_name;
v_type : ty;
v_last : last;
v_loc : location; }
{ v_name : var_name;
v_type : ty;
v_clock : ck option;
v_last : last;
v_loc : location; }
and last = Var | Last of exp option
@ -164,14 +172,15 @@ type contract =
c_block : block }
type node_dec =
{ n_name : dec_name;
n_stateful : 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; }
{ n_name : dec_name;
n_stateful : 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;
n_constraints : exp list; }
type const_dec =
{ c_name : dec_name;
@ -192,16 +201,18 @@ and program_desc =
type arg =
{ a_type : ty;
a_name : var_name option }
{ a_type : ty;
a_clock : ck option;
a_name : var_name option }
type signature =
{ sig_name : dec_name;
sig_inputs : arg list;
sig_stateful : bool;
sig_outputs : arg list;
sig_params : var_dec list;
sig_loc : location }
{ sig_name : dec_name;
sig_inputs : arg list;
sig_stateful : bool;
sig_outputs : arg list;
sig_params : var_dec list;
sig_param_constraints : exp list;
sig_loc : location }
type interface = interface_decl list
@ -217,7 +228,7 @@ and interface_desc =
(* {3 Helper functions to create AST} *)
let mk_exp desc ?(ct_annot = Clocks.invalid_clock) loc =
let mk_exp desc ?(ct_annot = None) loc =
{ e_desc = desc; e_ct_annot = ct_annot; e_loc = loc }
let mk_app op params =
@ -250,8 +261,8 @@ let mk_equation desc 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;
let mk_var_dec name ty ck last loc =
{ v_name = name; v_type = ty; v_clock = ck;
v_last = last; v_loc = loc }
let mk_block locals eqs loc =
@ -261,8 +272,8 @@ let mk_block locals eqs 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 mk_arg name ty ck =
{ a_type = ty; a_name = name; a_clock = ck}
let ptrue = Q Initial.ptrue
let pfalse = Q Initial.pfalse

161
compiler/heptagon/parsing/hept_parsetree_mapfold.ml
View file

@ -10,39 +10,38 @@
open Misc
open Errors
open Global_mapfold
(*open Global_mapfold*)
open Hept_parsetree
type 'a hept_it_funs = {
ty : 'a hept_it_funs -> 'a -> Hept_parsetree.ty -> Hept_parsetree.ty * 'a;
static_exp : 'a hept_it_funs -> 'a -> Hept_parsetree.static_exp -> static_exp * 'a;
static_exp_desc : 'a hept_it_funs -> 'a -> Hept_parsetree.static_exp_desc
-> Hept_parsetree.static_exp_desc * '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.edesc -> Hept_parsetree.edesc * '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;
type_dec: 'a hept_it_funs -> 'a -> Hept_parsetree.type_dec -> Hept_parsetree.type_dec * 'a;
type_desc: 'a hept_it_funs -> 'a -> Hept_parsetree.type_desc -> Hept_parsetree.type_desc * 'a;
program: 'a hept_it_funs -> 'a -> Hept_parsetree.program -> Hept_parsetree.program * 'a;
program_desc: 'a hept_it_funs -> 'a -> Hept_parsetree.program_desc
-> Hept_parsetree.program_desc * 'a; }
ty : 'a hept_it_funs -> 'a -> ty -> ty * 'a;
static_exp : 'a hept_it_funs -> 'a -> static_exp -> static_exp * 'a;
static_exp_desc : 'a hept_it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a;
app : 'a hept_it_funs -> 'a -> app -> app * 'a;
block : 'a hept_it_funs -> 'a -> block -> block * 'a;
edesc : 'a hept_it_funs -> 'a -> edesc -> edesc * 'a;
eq : 'a hept_it_funs -> 'a -> eq -> eq * 'a;
eqdesc : 'a hept_it_funs -> 'a -> eqdesc -> eqdesc * 'a;
escape_unless : 'a hept_it_funs -> 'a -> escape -> escape * 'a;
escape_until : 'a hept_it_funs -> 'a -> escape -> escape * 'a;
exp : 'a hept_it_funs -> 'a -> exp -> exp * 'a;
pat : 'a hept_it_funs -> 'a -> pat -> pat * 'a;
present_handler : 'a hept_it_funs -> 'a -> present_handler -> present_handler * 'a;
state_handler : 'a hept_it_funs -> 'a -> state_handler -> state_handler * 'a;
switch_handler : 'a hept_it_funs -> 'a -> switch_handler -> switch_handler * 'a;
var_dec : 'a hept_it_funs -> 'a -> var_dec -> var_dec * 'a;
arg : 'a hept_it_funs -> 'a -> arg -> arg * 'a;
last : 'a hept_it_funs -> 'a -> last -> last * 'a;
contract : 'a hept_it_funs -> 'a -> contract -> contract * 'a;
node_dec : 'a hept_it_funs -> 'a -> node_dec -> node_dec * 'a;
const_dec : 'a hept_it_funs -> 'a -> const_dec -> const_dec * 'a;
type_dec : 'a hept_it_funs -> 'a -> type_dec -> type_dec * 'a;
type_desc : 'a hept_it_funs -> 'a -> type_desc -> type_desc * 'a;
program : 'a hept_it_funs -> 'a -> program -> program * 'a;
program_desc : 'a hept_it_funs -> 'a -> program_desc -> program_desc * 'a;
interface : 'a hept_it_funs -> 'a -> interface -> interface * 'a;
interface_desc : 'a hept_it_funs -> 'a -> interface_desc -> interface_desc * 'a;
signature : 'a hept_it_funs -> 'a -> signature -> signature * 'a; }
let rec static_exp_it funs acc se = funs.static_exp funs acc se
and static_exp funs acc se =
@ -217,6 +216,10 @@ and var_dec funs acc vd =
let v_last, acc = last_it funs acc vd.v_last in
{ vd with v_last = v_last; v_type = v_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 last_it funs acc l =
try funs.last funs acc l
@ -237,12 +240,6 @@ and contract funs acc c =
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 =
@ -250,12 +247,14 @@ and node_dec funs acc nd =
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_constraints, acc = mapfold (exp_it funs) acc nd.n_constraints 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_constraints = n_constraints;
n_contract = n_contract }
, acc
@ -298,7 +297,7 @@ and type_desc funs acc td = match td with
and program_it funs acc p = funs.program funs acc p
and program funs acc p =
let p_desc, acc = mapfold (program_desc funs) acc p.p_desc in
let p_desc, acc = mapfold (program_desc_it funs) acc p.p_desc in
{ p with p_desc = p_desc }, acc
and program_desc_it funs acc pd =
@ -310,6 +309,36 @@ and program_desc funs acc pd = match pd with
| Pnode n -> let n, acc = node_dec_it funs acc n in Pnode n, acc
| Ppragma _ -> pd, acc
and interface_desc_it funs acc id =
try funs.interface_desc funs acc id
with Fallback -> interface_desc funs acc id
and interface_desc funs acc id = match id with
| Iopen _ -> id, acc
| Itypedef t -> let t, acc = type_dec_it funs acc t in Itypedef t, acc
| Iconstdef c -> let c, acc = const_dec_it funs acc c in Iconstdef c, acc
| Isignature s -> let s, acc = signature_it funs acc s in Isignature s, acc
and interface_it funs acc i = funs.interface funs acc i
and interface funs acc i =
let decl acc id =
let idc, acc = interface_desc_it funs acc id.interf_desc in
{ id with interf_desc = idc }, acc
in
mapfold decl acc i
and signature_it funs acc s = funs.signature funs acc s
and signature funs acc s =
let sig_inputs, acc = mapfold (arg_it funs) acc s.sig_inputs in
let sig_outputs, acc = mapfold (arg_it funs) acc s.sig_outputs in
let sig_params, acc = mapfold (var_dec_it funs) acc s.sig_params in
let sig_param_constraints, acc = mapfold (exp_it funs) acc s.sig_param_constraints in
{ s with sig_inputs = sig_inputs;
sig_outputs = sig_outputs;
sig_params = sig_params;
sig_param_constraints = sig_param_constraints; }
, acc
let defaults = {
ty = ty;
static_exp = static_exp;
@ -334,33 +363,41 @@ let defaults = {
type_dec = type_dec;
type_desc = type_desc;
program = program;
program_desc = program_desc }
program_desc = program_desc;
interface = interface;
interface_desc = interface_desc;
signature = signature;
arg = arg; }
let defaults_stop = {
ty = stop;
static_exp = stop;
static_exp_desc = 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;
type_dec = stop;
type_desc = stop;
program = stop;
program_desc = stop }
ty = Global_mapfold.stop;
static_exp = Global_mapfold.stop;
static_exp_desc = Global_mapfold.stop;
app = Global_mapfold.stop;
block = Global_mapfold.stop;
edesc = Global_mapfold.stop;
eq = Global_mapfold.stop;
eqdesc = Global_mapfold.stop;
escape_unless = Global_mapfold.stop;
escape_until = Global_mapfold.stop;
exp = Global_mapfold.stop;
pat = Global_mapfold.stop;
present_handler = Global_mapfold.stop;
state_handler = Global_mapfold.stop;
switch_handler = Global_mapfold.stop;
var_dec = Global_mapfold.stop;
last = Global_mapfold.stop;
contract = Global_mapfold.stop;
node_dec = Global_mapfold.stop;
const_dec = Global_mapfold.stop;
type_dec = Global_mapfold.stop;
type_desc = Global_mapfold.stop;
program = Global_mapfold.stop;
program_desc = Global_mapfold.stop;
interface = Global_mapfold.stop;
interface_desc = Global_mapfold.stop;
signature = Global_mapfold.stop;
arg = Global_mapfold.stop; }

103
compiler/heptagon/parsing/hept_scoping.ml
View file

@ -111,7 +111,7 @@ 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
if NamesSet.mem c local_const
then local_qn c
else qualify_const c
@ -161,24 +161,25 @@ end
let mk_app ?(params=[]) ?(unsafe=false) op =
{ Heptagon.a_op = op; Heptagon.a_params = params; Heptagon.a_unsafe = unsafe }
let mk_signature name ins outs stateful params loc =
let mk_signature name ins outs stateful params constraints loc =
{ Heptagon.sig_name = name;
Heptagon.sig_inputs = ins;
Heptagon.sig_stateful = stateful;
Heptagon.sig_outputs = outs;
Heptagon.sig_params = params;
Heptagon.sig_param_constraints = constraints;
Heptagon.sig_loc = loc }
(** 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
if NamesSet.mem c local_const
then Error.message loc (Error.Econst_variable_already_defined c)
else S.add c local_const in
else NamesSet.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
List.fold_left build NamesSet.empty vd_list
(** { 3 Translate the AST into Heptagon. } *)
@ -241,12 +242,25 @@ let rec translate_type loc ty =
with
| ScopingError err -> message loc err
let rec translate_some_clock loc env ck = match ck with
| None -> Clocks.fresh_clock()
| Some(ck) -> translate_clock loc env ck
and translate_clock loc env ck = match ck with
| Cbase -> Clocks.Cbase
| Con(ck,c,x) -> Clocks.Con(translate_clock loc env ck, qualify_constrs c, Rename.var loc env x)
let rec translate_ct loc env ct = match ct with
| Ck ck -> Clocks.Ck (translate_clock loc env ck)
| Cprod c_l -> Clocks.Cprod (List.map (translate_ct loc env) c_l)
let rec translate_exp env e =
try
{ Heptagon.e_desc = translate_desc e.e_loc env e.e_desc;
Heptagon.e_ty = Types.invalid_type;
Heptagon.e_base_ck = Clocks.Cbase;
Heptagon.e_ct_annot = e.e_ct_annot;
Heptagon.e_level_ck = Clocks.Cbase;
Heptagon.e_ct_annot = Misc.optional (translate_ct e.e_loc env) e.e_ct_annot;
Heptagon.e_loc = e.e_loc }
with ScopingError(error) -> message e.e_loc error
@ -296,7 +310,6 @@ and translate_desc loc env = function
and translate_op = function
| Eequal -> Heptagon.Eequal
| Earrow -> Heptagon.Earrow
| Eifthenelse -> Heptagon.Eifthenelse
| Efield -> Heptagon.Efield
@ -381,9 +394,10 @@ and translate_var_dec env vd =
{ Heptagon.v_ident = Rename.var vd.v_loc env vd.v_name;
Heptagon.v_type = translate_type vd.v_loc vd.v_type;
Heptagon.v_last = translate_last vd.v_last;
Heptagon.v_clock = Clocks.fresh_clock(); (* TODO add clock annotations *)
Heptagon.v_clock = translate_some_clock vd.v_loc env vd.v_clock;
Heptagon.v_loc = vd.v_loc }
(** [env] should contain the declared variables prior to this translation *)
and translate_vd_list env =
List.map (translate_var_dec env)
@ -399,42 +413,40 @@ let translate_contract env ct =
Heptagon.c_controllables = translate_vd_list env ct.c_controllables;
Heptagon.c_block = b }
let params_of_var_decs =
List.map (fun vd -> Signature.mk_param
vd.v_name
(translate_type vd.v_loc vd.v_type))
let params_of_var_decs p_l =
let pofvd vd = Signature.mk_param vd.v_name (translate_type vd.v_loc vd.v_type) in
List.map pofvd p_l
let args_of_var_decs =
List.map (fun vd -> Signature.mk_arg
(Some vd.v_name)
(translate_type vd.v_loc vd.v_type))
let translate_constrnt e = expect_static_exp e
let translate_node node =
let n = current_qual node.n_name in
Idents.enter_node n;
(* 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 node.n_params in
let inputs = translate_vd_list env0 node.n_input in
let constraints = List.map translate_constrnt node.n_constraints in
let input_env = Rename.append Rename.empty (node.n_input) in
(* inputs should refer only to inputs *)
let inputs = translate_vd_list input_env node.n_input in
(* Inputs and outputs define the initial local env *)
let env0 = Rename.append input_env node.n_output in
let outputs = translate_vd_list env0 node.n_output in
let b, env = translate_block env0 node.n_block in
let contract =
Misc.optional (translate_contract env) node.n_contract in
(* the env of the block is used in the contract translation *)
let contract = Misc.optional (translate_contract env) node.n_contract in
(* add the node signature to the environment *)
let i = args_of_var_decs node.n_input in
let o = args_of_var_decs node.n_output in
let p = params_of_var_decs node.n_params in
safe_add node.n_loc add_value n (Signature.mk_node i o node.n_stateful p);
{ Heptagon.n_name = n;
Heptagon.n_stateful = node.n_stateful;
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 nnode = { Heptagon.n_name = n;
Heptagon.n_stateful = node.n_stateful;
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_param_constraints = constraints; }
in
safe_add node.n_loc add_value n (Hept_utils.signature_of_node nnode);
nnode
let translate_typedec ty =
let n = current_qual ty.t_name in
@ -477,7 +489,7 @@ let translate_const_dec cd =
let translate_program p =
let translate_program_desc pd = match pd with
| Ppragma _ -> Misc.unsupported "pragma in scoping" 1
| Ppragma _ -> Misc.unsupported "pragma in scoping"
| Pconst c -> Heptagon.Pconst (translate_const_dec c)
| Ptype t -> Heptagon.Ptype (translate_typedec t)
| Pnode n -> Heptagon.Pnode (translate_node n)
@ -488,15 +500,26 @@ let translate_program p =
Heptagon.p_opened = p.p_opened;
Heptagon.p_desc = desc; }
let translate_signature s =
let translate_arg a =
Signature.mk_arg a.a_name (translate_type s.sig_loc a.a_type) in
let rec translate_some_clock ck = match ck with
| None -> Signature.Cbase
| Some ck -> translate_clock ck
and translate_clock ck = match ck with
| Cbase -> Signature.Cbase
| Con(ck,c,x) -> Signature.Con(translate_clock ck, qualify_constrs c, x)
and translate_arg a = Signature.mk_arg a.a_name (translate_type s.sig_loc a.a_type)
(translate_some_clock a.a_clock)
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 s.sig_params in
safe_add s.sig_loc add_value n (Signature.mk_node i o s.sig_stateful p);
mk_signature n i o s.sig_stateful p s.sig_loc
let c = List.map translate_constrnt s.sig_param_constraints in
let sig_node = Signature.mk_node s.sig_loc i o s.sig_stateful p in
Signature.check_signature sig_node;
safe_add s.sig_loc add_value n sig_node;
mk_signature n i o s.sig_stateful p c s.sig_loc
let translate_interface_desc = function

24
compiler/heptagon/parsing/hept_static_scoping.ml
View file

@ -36,30 +36,28 @@ let exp funs local_const e =
let sed =
match e.e_desc with
| Evar n ->
(try
Svar (Q (qualify_const local_const (ToQ n)))
with
| Error.ScopingError _ -> raise Not_static)
(try Svar (Q (qualify_const local_const (ToQ n)))
with Error.ScopingError _ -> raise Not_static)
| Eapp({ a_op = Earray_fill; a_params = n_list }, [e]) ->
Sarray_power (assert_se e, List.map assert_se n_list)
Sarray_power (assert_se e, List.map assert_se n_list)
| Eapp({ a_op = Earray }, e_list) ->
Sarray (List.map assert_se e_list)
Sarray (List.map assert_se e_list)
| Eapp({ a_op = Etuple }, e_list) ->
Stuple (List.map assert_se e_list)
Stuple (List.map assert_se e_list)
| Eapp(app, e_list) ->
let op, e_list = static_app_from_app app e_list in
let op, e_list = static_app_from_app app e_list in
Sop (op, List.map assert_se e_list)
| Estruct e_list ->
Srecord (List.map (fun (f,e) -> f, assert_se e) e_list)
Srecord (List.map (fun (f,e) -> f, assert_se e) e_list)
| _ -> raise Not_static
in
{ e with e_desc = Econst (mk_static_exp sed e.e_loc) }, local_const
{ e with e_desc = Econst (mk_static_exp sed e.e_loc) }, local_const
with
Not_static -> e, local_const
let node funs _ n =
let local_const = Hept_scoping.build_const n.n_loc n.n_params in
Hept_parsetree_mapfold.node_dec funs local_const n
Hept_parsetree_mapfold.node_dec funs local_const n
let const_dec funs local_const cd =
let cd, _ = Hept_parsetree_mapfold.const_dec funs local_const cd in
@ -72,13 +70,13 @@ let const_dec funs local_const cd =
let program p =
let funs = { Hept_parsetree_mapfold.defaults
with node_dec = node; exp = exp; static_exp = static_exp; const_dec = const_dec } in
let p, _ = Hept_parsetree_mapfold.program_it funs Names.S.empty p in
let p, _ = Hept_parsetree_mapfold.program_it funs Names.NamesSet.empty p in
p
(* (* TODO mapfold on interface *)
let interface i =
let funs = { Hept_parsetree_mapfold.defaults
with node_dec = node; exp = exp; const_dec = const_dec } in
let i, _ = Hept_parsetree_mapfold.interface_it funs Names.S.empty i in
let i, _ = Hept_parsetree_mapfold.interface_it funs Names.NamesSet.empty i in
i
*)

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

@ -53,7 +53,8 @@ let state_type_dec_list = ref []
(* 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 "automata" state in
let n = String.capitalize (Names.shortname type_name) ^ "_" ^ state in
let c = Modules.fresh_constr "automata" n 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
@ -75,7 +76,7 @@ let no_strong_transition state_handlers =
let translate_automaton v eq_list handlers =
let type_name = Modules.fresh_type "automata" "states" in
let type_name = Modules.fresh_type "automata" "state" in
(* the state env associate a name to a qualified constructor *)
let state_env =
List.fold_left
@ -94,8 +95,7 @@ let translate_automaton v eq_list handlers =
let pre_next_resetname = fresh PNR in
let name n = NamesEnv.find n state_env in
let state n =
mk_exp (Econst (mk_constructor (name n) tstatetype)) tstatetype 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

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

@ -16,10 +16,10 @@ 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 re, vre, eqre = Reset.bool_var_from_exp re in
let re, vre, eqre = Reset.reset_var_from_exp re in
Eapp(op, e_list, Some re), (vre::v, eqre::acc_eq_list)
| Eiterator(it, op, n, pe_list, e_list, Some re) when not (is_var re) ->
let re, vre, eqre = Reset.bool_var_from_exp re in
let re, vre, eqre = Reset.reset_var_from_exp re in
Eiterator(it, op, n, pe_list, e_list, Some re),
(vre::v, eqre::acc_eq_list)
| _ -> ed, (v, acc_eq_list)

16
compiler/heptagon/transformations/inline.ml
View file

@ -27,9 +27,9 @@ let mk_unique_node nd =
let subst = List.map mk_bind (nd.n_block.b_local
@ nd.n_input @ nd.n_output) in
let subst_var_dec funs () vd =
let subst_var_dec _ () vd =
({ vd with v_ident = (List.assoc vd.v_ident subst).v_ident; }, ()) in
let subst_edesc funs () ed = match ed with
let subst_edesc _ () ed = match ed with
| Evar vn -> (Evar (List.assoc vn subst).v_ident, ())
| _ -> raise Errors.Fallback in
let subst_eqdesc funs () eqd =
@ -100,7 +100,7 @@ let exp funs (env, newvars, newequs) exp = match exp.e_desc with
| _ -> Hept_mapfold.exp funs (env, newvars, newequs) exp
let block funs (env, newvars, newequs) blk =
let (block, (env, newvars, newequs)) =
let (_, (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, [], []))
@ -117,11 +117,11 @@ let node_dec funs (env, newvars, newequs) nd =
let program p =
let env n =
let d =
List.find
(function
| Pnode nd -> nd.n_name = n
| _ -> false)
p.p_desc in
List.find
(function
| Pnode nd -> nd.n_name = n
| _ -> false)
p.p_desc in
match d with
| Pnode nd -> nd
| _ -> assert false in

2
compiler/heptagon/transformations/itfusion.ml
View file

@ -28,7 +28,7 @@ let anon_nodes = ref QualEnv.empty
let add_anon_node inputs outputs locals eqs =
let n = mk_fresh_node_name () in
let b = mk_block ~locals:locals eqs in
let nd = mk_node ~input:inputs ~output:outputs ~local:locals n b in
let nd = mk_node ~input:inputs ~output:outputs n b in
anon_nodes := QualEnv.add n nd !anon_nodes;
n

7
compiler/heptagon/transformations/normalize.ml
View file

@ -34,11 +34,6 @@ struct
raise Errors.Error
end
let is_stateful e = match e.e_desc with
| Efby _ | Epre _ -> true
| Eapp({ a_op = Enode _ }, _, _) -> true
| _ -> false
let exp_list_of_static_exp_list se_list =
let mk_one_const se =
mk_exp (Econst se) se.se_ty
@ -269,7 +264,7 @@ and translate_eq ((d_list, eq_list) as context) eq = match eq.eq_desc with
mk_equation ~loc:eq.eq_loc (Eblock { b with b_local = v @ b.b_local; b_equs = eqs})
in
d_list, eq :: eq_list
| _ -> Misc.internal_error "normalize" 0
| _ -> Misc.internal_error "normalize"
and translate_eq_list d_list eq_list =
List.fold_left

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

@ -15,7 +15,7 @@ open Hept_mapfold
let translate_present_handlers handlers cont =
let translate_present_handler { p_cond = e; p_block = b } cont =
let stateful = b.b_stateful or cont.b_stateful in
mk_block ~defnames:b.b_defnames
mk_block ~stateful:stateful ~defnames:b.b_defnames
[mk_switch_equation e
[{ w_name = Initial.ptrue; w_block = b };
{ w_name = Initial.pfalse; w_block = cont }]] in

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

@ -22,10 +22,10 @@ open Initial
let fresh = Idents.gen_fresh "reset" (fun () -> "r")
let fresh = Idents.gen_fresh "reset" ~reset:true (fun () -> "r")
(* get e and return r, var_dec_r, r = e *)
let bool_var_from_exp e =
let reset_var_from_exp e =
let r = fresh() in
{ e with e_desc = Evar r }, mk_var_dec r (Tid Initial.pbool), mk_equation (Eeq(Evarpat r, e))
@ -45,36 +45,43 @@ let ifres res e2 e3 =
| None -> mk_op_app Eifthenelse [init e3.e_loc; e2; e3]
| Some re -> mk_op_app Eifthenelse [re; e2; e3]
(** Keep when ever possible the initialization value *)
(** Keep whenever possible the initialization value *)
let default e =
match e.e_desc with
| Econst c -> Some c
| _ -> None
let edesc funs (res,stateful) ed =
let ed, _ = Hept_mapfold.edesc funs (res,stateful) ed in
let ed = match ed with
let edesc funs ((res,_) as acc) ed = match ed with
| Efby (e1, e2) ->
let e1,_ = Hept_mapfold.exp_it funs acc e1 in
let e2,_ = Hept_mapfold.exp_it funs acc e2 in
(match res, e1 with
| None, { e_desc = Econst c } ->
(* no reset : [if res] useless, the initialization is sufficient *)
Epre(Some c, e2)
| _ -> ifres res e1 { e2 with e_desc = Epre(default e1, e2) })
| _ -> ifres res e1 { e2 with e_desc = Epre(default e1, e2) }), acc
| Eapp({ a_op = Earrow }, [e1;e2], _) ->
ifres res e1 e2
let e1,_ = Hept_mapfold.exp_it funs acc e1 in
let e2,_ = Hept_mapfold.exp_it funs acc e2 in
ifres res e1 e2, acc
| Eapp({ a_op = Enode _ } as op, e_list, re) ->
Eapp(op, e_list, merge_resets res re)
let args,_ = mapfold (Hept_mapfold.exp_it funs) acc e_list in
let re,_ = optional_wacc (Hept_mapfold.exp_it funs) acc re in
Eapp(op, args, merge_resets res re), acc
| Eiterator(it, ({ a_op = Enode _ } as op), n, pe_list, e_list, re) ->
Eiterator(it, op, n, pe_list, e_list, merge_resets res re)
| Eapp({ a_op = Efun _ } as op, e_list, re) ->
Eapp(op, e_list, None) (* funs don't need resets *)
| Eiterator(it, ({ a_op = Efun _ } as op), n, pe_list, e_list, re) ->
Eiterator(it, op, n, pe_list, e_list, None) (* funs don't need resets *)
| _ -> ed
in
ed, (res,stateful)
let pargs,_ = mapfold (Hept_mapfold.exp_it funs) acc pe_list in
let args,_ = mapfold (Hept_mapfold.exp_it funs) acc e_list in
let re,_ = optional_wacc (Hept_mapfold.exp_it funs) acc re in
Eiterator(it, op, n, pargs, args, merge_resets res re), acc
| Eapp({ a_op = Efun _ } as op, e_list, _) ->
let args,_ = mapfold (Hept_mapfold.exp_it funs) acc e_list in
Eapp(op, args, None), acc (* funs don't need resets *)
| Eiterator(it, ({ a_op = Efun _ } as op), n, pe_list, e_list, _) ->
let pargs,_ = mapfold (Hept_mapfold.exp_it funs) acc pe_list in
let args,_ = mapfold (Hept_mapfold.exp_it funs) acc e_list in
Eiterator(it, op, n, pargs, args, None), acc (* funs don't need resets *)
| _ -> raise Errors.Fallback
let eq funs (res,_) eq =
Hept_mapfold.eq funs (res,eq.eq_stateful) eq
@ -88,7 +95,7 @@ let eqdesc funs (res,stateful) = function
| Ereset(b, e) ->
if stateful then (
let e, _ = Hept_mapfold.exp_it funs (res,stateful) e in
let e, vd, eq = bool_var_from_exp e in
let e, vd, eq = reset_var_from_exp e in
let r = merge_resets res (Some e) in
let b, _ = Hept_mapfold.block_it funs (r,stateful) b in
let b = { b with b_equs = eq::b.b_equs; b_local = vd::b.b_local; b_stateful = true } in

12
compiler/heptagon/transformations/switch.ml
View file

@ -7,7 +7,7 @@
(* *)
(**************************************************************************)
(* ASSUMES no automaton, no present, no last *)
(* ASSUMES no automaton, no present, no last, no reset *)
(* Removing switch statements *)
@ -33,7 +33,7 @@ with one defined var y ( defnames = {y} ) and used var x
*)
(* base_ck is used to have correct behavior for side effects :
it keep track of the fact that a call
it keep track of the fact that a cal
without interaction with the dataflow was in a case of the switch *)
@ -105,7 +105,7 @@ let current_level env = match env with
(** Set the base clock of an expression to the current level of the [env] *)
let annot_exp e env =
{ e with e_base_ck = current_level env }
{ e with e_level_ck = current_level env }
end
@ -133,7 +133,7 @@ let add_to_locals vd_env locals h =
let add_one n nn (locals,vd_env) =
let orig_vd = Idents.Env.find n vd_env in
let vd_nn = mk_var_dec nn orig_vd.v_type in
vd_nn::locals, Idents.Env.add vd_nn.v_ident vd_nn vd_env
vd_nn::locals, Idents.Env.add vd_nn.v_ident vd_nn vd_env
in
fold add_one h (locals, vd_env)
end
@ -197,7 +197,7 @@ let eqdesc funs (vd_env,env,h) eqd = match eqd with
let equs = (mk_equation (Eblock b_eq))::equs in
((constr,h)::c_h_l, locals, equs, vd_env)
in
let (c_h_l, locals, equs, vd_env) =
List.fold_left switch_handler ([], locals, equs, vd_env) sw_h_l
in
@ -212,7 +212,7 @@ let eqdesc funs (vd_env,env,h) eqd = match eqd with
let equs =
Idents.Env.fold (fun n ty equs -> new_merge n ty equs) defnames equs
in
(* return the transformation in a block *)
let b = mk_block ~defnames:defnames ~locals:locals equs in
Eblock b, (vd_env,env,h)

58
compiler/main/hept2mls.ml
View file

@ -44,16 +44,10 @@ struct
raise Errors.Error
end
(* add an equation *)
let equation locals eqs e =
let n = Idents.gen_var "hept2mls" "ck" in
n,
(mk_var_dec n e.e_ty) :: locals,
(mk_equation (Evarpat n) e):: eqs
let translate_var { Heptagon.v_ident = n; Heptagon.v_type = ty;
Heptagon.v_loc = loc } =
mk_var_dec ~loc:loc n ty
Heptagon.v_loc = loc; Heptagon.v_clock = ck } =
mk_var_dec ~loc:loc n ty ck
let translate_reset = function
| Some { Heptagon.e_desc = Heptagon.Evar n } -> Some n
@ -68,7 +62,6 @@ let translate_iterator_type = function
| Heptagon.Imapfold -> Imapfold
let rec translate_op = function
| Heptagon.Eequal -> Eequal
| Heptagon.Eifthenelse -> Eifthenelse
| Heptagon.Efun f -> Efun f
| Heptagon.Enode f -> Enode f
@ -82,7 +75,7 @@ let rec translate_op = function
| Heptagon.Eselect_trunc -> Eselect_trunc
| Heptagon.Econcat -> Econcat
| Heptagon.Earray -> Earray
| Heptagon.Etuple -> Misc.internal_error "hept2mls Etuple" 1
| Heptagon.Etuple -> Misc.internal_error "hept2mls Etuple"
| Heptagon.Earrow -> assert false
let translate_app app =
@ -97,52 +90,53 @@ let rec translate_extvalue e =
| Heptagon.Ewhen (e, c, x) ->
mk_extvalue (Wwhen (translate_extvalue e, c, x))
| Heptagon.Eapp({ Heptagon.a_op = Heptagon.Efield;
Heptagon.a_params = params }, e_list, reset) ->
Heptagon.a_params = params }, e_list, _) ->
let e = assert_1 e_list in
let f = assert_1 params in
let fn = match f.se_desc with Sfield fn -> fn | _ -> assert false in
mk_extvalue (Wfield (translate_extvalue e, fn))
| _ -> Error.message e.Heptagon.e_loc Error.Enormalization
let translate
({ Heptagon.e_desc = desc; Heptagon.e_ty = ty;
Heptagon.e_loc = loc } as e) =
let mk_exp = mk_exp ~loc:loc in
match desc with
let rec translate ({ Heptagon.e_desc = desc; Heptagon.e_ty = ty; Heptagon.e_level_ck = b_ck;
Heptagon.e_ct_annot = a_ct; Heptagon.e_loc = loc } as e) =
let desc = match desc with
| Heptagon.Econst _
| Heptagon.Evar _
| Heptagon.Ewhen _
| Heptagon.Eapp({ Heptagon.a_op = Heptagon.Efield }, _, _) ->
let w = translate_extvalue e in
mk_exp ty (Eextvalue w)
Eextvalue w
| Heptagon.Ewhen (e,c,x) -> Ewhen (translate e, c, x)
| Heptagon.Epre(None, e) ->
mk_exp ty (Efby(None, translate_extvalue e))
Efby(None, translate_extvalue e)
| Heptagon.Epre(Some c, e) ->
mk_exp ty (Efby(Some c, translate_extvalue e))
Efby(Some c, translate_extvalue e)
| Heptagon.Efby ({ Heptagon.e_desc = Heptagon.Econst c }, e) ->
mk_exp ty (Efby(Some c, translate_extvalue e))
Efby(Some c, translate_extvalue e)
| Heptagon.Estruct f_e_list ->
let f_e_list = List.map
(fun (f, e) -> (f, translate_extvalue e)) f_e_list in
mk_exp ty (Estruct f_e_list)
Estruct f_e_list
| Heptagon.Eapp({ Heptagon.a_op = Heptagon.Earrow }, _, _) ->
Error.message loc Error.Eunsupported_language_construct
| Heptagon.Eapp(app, e_list, reset) ->
mk_exp ty (Eapp (translate_app app,
List.map translate_extvalue e_list,
translate_reset reset))
Eapp (translate_app app, List.map translate_extvalue e_list, translate_reset reset)
| Heptagon.Eiterator(it, app, n, pe_list, e_list, reset) ->
mk_exp ty
(Eiterator (translate_iterator_type it,
Eiterator (translate_iterator_type it,
translate_app app, n,
List.map translate_extvalue pe_list,
List.map translate_extvalue e_list,
translate_reset reset))
translate_reset reset)
| Heptagon.Efby _
| Heptagon.Elast _ ->
Error.message loc Error.Eunsupported_language_construct
| Heptagon.Emerge (x, c_e_list) ->
mk_exp ty (Emerge (x, List.map (fun (c,e)-> c, translate_extvalue e) c_e_list))
Emerge (x, List.map (fun (c,e)-> c, translate_extvalue e) c_e_list)
in
match a_ct with
| None -> mk_exp b_ck ty ~loc:loc desc
| Some ct -> mk_exp b_ck ty ~ct:ct ~loc:loc desc
let rec translate_pat = function
| Heptagon.Evarpat(n) -> Evarpat n
@ -167,8 +161,8 @@ let translate_contract contract =
Heptagon.c_controllables = l_c } ->
Some { c_local = List.map translate_var v;
c_eq = List.map translate_eq eq_list;
c_assume = translate e_a;
c_enforce = translate e_g;
c_assume = translate_extvalue e_a;
c_enforce = translate_extvalue e_g;
c_controllables = List.map translate_var l_c }
let node n =
@ -181,7 +175,7 @@ let node n =
n_equs = List.map translate_eq n.Heptagon.n_block.Heptagon.b_equs;
n_loc = n.Heptagon.n_loc ;
n_params = n.Heptagon.n_params;
n_params_constraints = n.Heptagon.n_params_constraints }
n_param_constraints = n.Heptagon.n_param_constraints }
let typedec
{Heptagon.t_name = n; Heptagon.t_desc = tdesc; Heptagon.t_loc = loc} =

316
compiler/main/hepts.ml
View file

@ -53,25 +53,25 @@ class boolean_input (table:GPack.table) n : input =
let click button_clicked () =
if not !click_processed then
begin
click_processed := true;
value := not !value;
begin match button_clicked with
| false ->
but_true#set_active !value
| true ->
but_false#set_active (not !value)
end;
begin match !autostep with
| None -> ()
| Some f -> f ()
end;
click_processed := false
click_processed := true;
value := not !value;
begin match button_clicked with
| false ->
but_true#set_active !value
| true ->
but_false#set_active (not !value)
end;
begin match !autostep with
| None -> ()
| Some f -> f ()
end;
click_processed := false
end
in
let _ = (but_true#connect#clicked ~callback:(click true)) in
let _ = (but_false#connect#clicked ~callback:(click false)) in
object
method get_input =
method get_input =
if !value then "1" else "0"
method get_random_input =
let v = Random.bool () in
@ -90,20 +90,20 @@ class enum_input mod_name value_list (table:GPack.table) n : input =
let mod_name = modul_to_string mod_name in
let value = ref ((List.hd value_list).name) in
let click_processed = ref false in
let nb_values = List.length value_list in
let buttons_frame = GPack.table ~columns:nb_values ~rows:1 () in
let _ = table#attach
let _ = table#attach
~expand:`BOTH ~left:1 ~right:3 ~top:n buttons_frame#coerce in
let rec create_buttons n first = function
[] -> []
| { name = value } :: value_list ->
let but = GButton.toggle_button ~label:value ~active:first () in
let _ = buttons_frame#attach
~expand:`BOTH ~left:n ~right:(n+1) ~top:0 but#coerce in
(value,but) :: (create_buttons (n+1) false value_list) in
let but = GButton.toggle_button ~label:value ~active:first () in
let _ = buttons_frame#attach
~expand:`BOTH ~left:n ~right:(n+1) ~top:0 but#coerce in
(value,but) :: (create_buttons (n+1) false value_list) in
let buttons = create_buttons 0 true value_list in
let array_buttons = Array.of_list buttons in
@ -113,25 +113,25 @@ class enum_input mod_name value_list (table:GPack.table) n : input =
(fun (v,b) ->
let prefixed_value = mod_name ^ "_" ^ v in
let click () =
if not !click_processed then
begin
click_processed := true;
value := prefixed_value;
!active_button#set_active false;
b#set_active true;
active_button := b;
begin match !autostep with
| None -> ()
| Some f -> f ()
end;
click_processed := false
end in
if not !click_processed then
begin
click_processed := true;
value := prefixed_value;
!active_button#set_active false;
b#set_active true;
active_button := b;
begin match !autostep with
| None -> ()
| Some f -> f ()
end;
click_processed := false
end in
ignore(b#connect#clicked ~callback:click)
)
buttons in
object
method get_input =
method get_input =
!value
method get_random_input =
let i = Random.int (Array.length array_buttons) in
@ -167,7 +167,7 @@ object
method reset = ()
end
class scale_input default_value lower upper to_float from_float digits
class scale_input default_value lower upper to_float from_float digits
(table:GPack.table) n : input =
let adj =
GData.adjustment
@ -175,8 +175,8 @@ class scale_input default_value lower upper to_float from_float digits
~lower:lower
~upper:upper
() in
let scale =
GRange.scale
let scale =
GRange.scale
`HORIZONTAL
~adjustment:adj
~digits:digits
@ -197,7 +197,7 @@ object
adj#set_value (to_float v)
method reset = ()
end
class type output =
object
@ -208,7 +208,7 @@ class label_output (table:GPack.table) n : output =
let label = GMisc.label ~text:"" () in
let _ = table#attach ~expand:`BOTH ~left:1 ~right:2 ~top:n label#coerce in
object
method set_output s =
method set_output s =
label#set_text s
end
@ -225,25 +225,25 @@ let create_input v_name v_ty n (table:GPack.table) =
table#attach ~expand:`BOTH ~left:0 ~right:1 ~top:n label#coerce;
match v_ty with
| Tid{ qual = Pervasives; name = "int" } ->
new scale_input
0.0 0. 120.float_of_string
(fun v ->
string_of_int (int_of_float v))
0
table n
new scale_input
0.0 0. 120.float_of_string
(fun v ->
string_of_int (int_of_float v))
0
table n
| Tid{ qual = Pervasives; name = "float" } ->
new scale_input 0. 0. 100. float_of_string string_of_float 1 table n
| Tid{ qual = Pervasives; name = "bool" } ->
new boolean_input table n
| Tid(name) ->
begin try
let ty = find_type name in
begin match ty with
| Tenum(clist) -> new enum_input name.qual clist table n
| _ -> new entry_input "" table n
end
let ty = find_type name in
begin match ty with
| Tenum(clist) -> new enum_input name.qual clist table n
| _ -> new entry_input "" table n
end
with Not_found ->
new entry_input "" table n
new entry_input "" table n
end
| _ -> failwith("Arrays and tuples not yet implemented")
@ -277,7 +277,7 @@ let find_in_path filename =
Only a minimal chronogram tool will be provided.\n" filename;
raise Not_found
let usage_msg = "Usage: " ^
let usage_msg = "Usage: " ^
Sys.executable_name ^ " -mod <Module> -node <node> -exec <exec>\n" ^
" " ^ Sys.executable_name ^ " -sig <file>.epci -node <node> -exec <exec>"
and doc_sig = "<file>.epci\tCompiled interface containing node <node> (for backward compatibility)"
@ -297,8 +297,8 @@ let main () =
let mod_name_of_epci epci_name =
if Filename.check_suffix epci_name ".epci" then
begin
let filename = Filename.chop_suffix epci_name ".epci" in
mod_name := String.capitalize(Filename.basename filename)
let filename = Filename.chop_suffix epci_name ".epci" in
mod_name := String.capitalize(Filename.basename filename)
end
else
raise (Arg.Bad("Invalid compiled interface: " ^ epci_name)) in
@ -314,20 +314,20 @@ let main () =
arg_list
(fun s -> raise (Arg.Bad ("Invalid argument: " ^ s)))
usage_msg;
if (!mod_name = "")
or (!node_name = "")
or (!exec_name = "") then
begin
Arg.usage arg_list usage_msg;
raise Error
Arg.usage arg_list usage_msg;
raise Error
end;
open_module (Module !mod_name);
let signature = find_value { qual = (Module !mod_name);
name = !node_name } in
name = !node_name } in
let nb_inputs = List.length signature.node_inputs in
let nb_outputs = List.length signature.node_outputs in
@ -351,7 +351,7 @@ let main () =
let out_frame = GBin.frame ~label:"Outputs" ~packing:up_part#add () in
(* let output_frame = GPack.table ~row_spacings:0 ~border_width:1 ~columns:2 ~rows:nb_outputs *)
(* ~packing:out_frame#add () in *)
let output_frame = GPack.table ~columns:2 ~rows:nb_outputs
let output_frame = GPack.table ~columns:2 ~rows:nb_outputs
~packing:out_frame#add () in
(* Step label *)
@ -359,7 +359,7 @@ let main () =
(* Period scale *)
let period_label = GMisc.label ~text:"Period" ~packing:period_part#add () in
let running_period_adj =
GData.adjustment
GData.adjustment
~value:!running_period
~lower:0.001
~upper:1.0
@ -367,8 +367,8 @@ let main () =
~page_incr:0.1
~page_size:0.1 () in
ignore(running_period_adj#connect#value_changed
(fun () -> running_period := running_period_adj#value));
let period_scale =
(fun () -> running_period := running_period_adj#value));
let period_scale =
GRange.scale
`HORIZONTAL
~adjustment:running_period_adj
@ -379,27 +379,27 @@ let main () =
() in
(* Step, autostep, random, run, quit buttons *)
let bstep = GButton.button ~label:"Step" ~packing:low_part#add () in
let bastep =
let bastep =
GButton.toggle_button ~label:"Autostep" ~packing:low_part#add () in
let brun =
let brun =
GButton.toggle_button ~label:"Run" ~packing:low_part#add () in
let brandom =
let brandom =
GButton.toggle_button ~label:"Random" ~packing:low_part#add () in
let bquit = GButton.button ~label:"Quit" ~packing:low_part#add () in
(* chronogram windows *)
let chrono = GWindow.window ~title:(!node_name ^ " - chronogram") () in
let chrono_box = GPack.vbox ~packing:chrono#add () in
let chrono_chronos =
let chrono_chronos =
GPack.table ~homogeneous:false ~col_spacings:10
~columns:11 ~rows:(nb_inputs+nb_outputs)
~packing:chrono_box#add () in
let packing_chrono = chrono_chronos#attach ~expand:`BOTH in
let chrono_buttons =
let chrono_buttons =
GPack.button_box `HORIZONTAL ~packing:chrono_box#add () in
let blatex = GButton.button ~label:"Export in LaTeX"
~packing:chrono_buttons#add () in
let bgnuplot = GButton.button ~label:"Export for Gnuplot"
let bgnuplot = GButton.button ~label:"Export for Gnuplot"
~packing:chrono_buttons#add () in
let make_label () = GMisc.label ~text:" " () in
@ -417,27 +417,27 @@ let main () =
output_string oc_sim2chro "#@inputs\n";
(* Adding inputs *)
let inputs,_ =
List.fold_left
List.fold_left
(fun (acc,n) { a_name = name; a_type = ty } ->
let name =
match name with
| None -> "Input " ^ (string_of_int n)
| Some name -> name in
let input = create_input name ty n input_frame in
let _chrono_label =
GMisc.label ~text:name ~packing:(packing_chrono ~left:0 ~top:n) () in
let chrono_data = Array.make 10 (make_label()) in
for i = 0 to 9 do
let lab = make_label () in
chrono_data.(i) <- lab;
packing_chrono ~left:(i+1) ~top:n lab#coerce
done;
let save = ref [] in
saves := (name, save)::!saves;
Printf.fprintf oc_sim2chro "\"%s\":%s\n" name (sim2chro_type ty);
((input,chrono_data,save)::acc),(n+1))
let name =
match name with
| None -> "Input " ^ (string_of_int n)
| Some name -> name in
let input = create_input name ty n input_frame in
let _chrono_label =
GMisc.label ~text:name ~packing:(packing_chrono ~left:0 ~top:n) () in
let chrono_data = Array.make 10 (make_label()) in
for i = 0 to 9 do
let lab = make_label () in
chrono_data.(i) <- lab;
packing_chrono ~left:(i+1) ~top:n lab#coerce
done;
let save = ref [] in
saves := (name, save)::!saves;
Printf.fprintf oc_sim2chro "\"%s\":%s\n" name (sim2chro_type ty);
((input,chrono_data,save)::acc),(n+1))
([],0)
signature.node_inputs in
@ -451,24 +451,24 @@ let main () =
let outputs,_ =
List.fold_left
(fun (acc,n) { a_name = name; a_type = ty } ->
let name =
match name with
| None -> "Output " ^ (string_of_int n)
| Some name -> name in
let output = create_output name ty n output_frame in
let n = n + nb_inputs in
let _chrono_label =
GMisc.label ~text:name ~packing:(packing_chrono ~left:0 ~top:n) () in
let chrono_data = Array.make 10 (make_label()) in
for i = 0 to 9 do
let lab = make_label () in
chrono_data.(i) <- lab;
packing_chrono ~left:(i+1) ~top:n lab#coerce
done;
let save = ref [] in
Printf.fprintf oc_sim2chro "\"%s\":%s\n" name (sim2chro_type ty);
saves := (name, save)::!saves;
((output,chrono_data,save)::acc),(n+1))
let name =
match name with
| None -> "Output " ^ (string_of_int n)
| Some name -> name in
let output = create_output name ty n output_frame in
let n = n + nb_inputs in
let _chrono_label =
GMisc.label ~text:name ~packing:(packing_chrono ~left:0 ~top:n) () in
let chrono_data = Array.make 10 (make_label()) in
for i = 0 to 9 do
let lab = make_label () in
chrono_data.(i) <- lab;
packing_chrono ~left:(i+1) ~top:n lab#coerce
done;
let save = ref [] in
Printf.fprintf oc_sim2chro "\"%s\":%s\n" name (sim2chro_type ty);
saves := (name, save)::!saves;
((output,chrono_data,save)::acc),(n+1))
([],0)
signature.node_outputs in
@ -476,7 +476,7 @@ let main () =
(* create simulating process *)
let (ic_sim,oc_sim) = Unix.open_process !exec_name in
let output_latex () =
let oc = open_out (!node_name ^ ".tex") in
output_string oc "\\[\n";
@ -524,62 +524,62 @@ let main () =
output_string oc_sim2chro "\n";
flush oc_sim2chro
in
let step () =
incr nb_step;
(* write inputs to simulating process *)
let input_strings =
List.fold_left
(fun acc (input,chrono,save) ->
let s =
if brandom#active
then input#get_random_input
else input#get_input in
input#reset;
Printf.fprintf oc_sim "%s\n" s;
save := s::!save;
if !nb_step <= 10 then
ignore
(fun acc (input,chrono,save) ->
let s =
if brandom#active
then input#get_random_input
else input#get_input in
input#reset;
Printf.fprintf oc_sim "%s\n" s;
save := s::!save;
if !nb_step <= 10 then
ignore
(List.fold_right
(fun x i ->
(chrono.(i))#set_text x ; i+1)
!save 0)
else
begin
(chrono.(0))#set_text "...";
for i = 1 to 9 do
(chrono.(i))#set_text (List.nth !save (9-i))
done
end;
s::acc)
[]
inputs in
(fun x i ->
(chrono.(i))#set_text x ; i+1)
!save 0)
else
begin
(chrono.(0))#set_text "...";
for i = 1 to 9 do
(chrono.(i))#set_text (List.nth !save (9-i))
done
end;
s::acc)
[]
inputs in
flush oc_sim;
(* read outputs *)
let output_strings =
List.fold_left
(fun acc (output,chrono,save) ->
let s = input_line ic_sim in
output#set_output s;
save := s::!save;
if !nb_step <= 10 then
ignore
List.fold_left
(fun acc (output,chrono,save) ->
let s = input_line ic_sim in
output#set_output s;
save := s::!save;
if !nb_step <= 10 then
ignore
(List.fold_right
(fun x i ->
(chrono.(i))#set_text x ; i+1)
!save 0)
else
begin
(chrono.(0))#set_text "...";
for i = 1 to 9 do
(chrono.(i))#set_text (List.nth !save (9-i))
done
end;
s::acc)
[]
outputs in
(fun x i ->
(chrono.(i))#set_text x ; i+1)
!save 0)
else
begin
(chrono.(0))#set_text "...";
for i = 1 to 9 do
(chrono.(i))#set_text (List.nth !save (9-i))
done
end;
s::acc)
[]
outputs in
step_sim2chro (input_strings,output_strings);
@ -602,9 +602,9 @@ let main () =
let toggle_run () =
match !running_thread with
| None ->
let t = Thread.create run () in
running_thread := Some t
| None ->
let t = Thread.create run () in
running_thread := Some t
| Some t -> running_thread := None
in

36
compiler/main/mls2obc.ml
View file

@ -11,12 +11,12 @@
open Misc
open Names
open Idents
open Clocks
open Signature
open Obc
open Obc_utils
open Obc_mapfold
open Types
open Clocks
open Static
open Initial
@ -63,7 +63,7 @@ let rec pattern_of_idx_list p l =
let rec aux p l = match p.pat_ty, l with
| _, [] -> p
| Tarray (ty',_), idx :: l -> aux (mk_pattern ty' (Larray (p, idx))) l
| _ -> internal_error "mls2obc" 1
| _ -> internal_error "mls2obc"
in
aux p l
@ -71,7 +71,7 @@ let rec extvalue_of_idx_list w l = match w.w_ty, l with
| _, [] -> w
| Tarray (ty',_), idx :: l ->
extvalue_of_idx_list (mk_ext_value ty' (Warray (w, idx))) l
| _ -> internal_error "mls2obc" 1
| _ -> internal_error "mls2obc"
let rec ext_value_of_trunc_idx_list p l =
let mk_between idx se =
@ -80,16 +80,16 @@ let rec ext_value_of_trunc_idx_list p l =
let rec aux p l = match p.w_ty, l with
| _, [] -> p
| Tarray (ty', se), idx :: l -> aux (mk_ext_value ty' (Warray (p, mk_between idx se))) l
| _ -> internal_error "mls2obc" 1
| _ -> internal_error "mls2obc"
in
aux p l
let array_elt_of_exp idx e =
match e.e_desc, Modules.unalias_type e.e_ty with
| Eextvalue { w_desc = Wconst { se_desc = Sarray_power (c, _); _ }; }, Tarray (ty,_) -> mk_ext_value_exp ty (Wconst c)
| Eextvalue { w_desc = Wconst { se_desc = Sarray_power (c, _) }; }, Tarray (ty,_) -> mk_ext_value_exp ty (Wconst c)
| _, Tarray (ty,_) ->
mk_ext_value_exp ty (Warray(ext_value_of_exp e, idx))
| _ -> internal_error "mls2obc" 2
| _ -> internal_error "mls2obc"
(** Creates the expression that checks that the indices
in idx_list are in the bounds. If idx_list=[e1;..;ep]
@ -109,10 +109,10 @@ let rec bound_check_expr idx_list bounds =
let e = mk_comp idx n in
mk_exp_bool (Eop (op_from_string "&",
[e; bound_check_expr idx_list bounds]))
| (_, _) -> internal_error "mls2obc" 3
| (_, _) -> internal_error "mls2obc"
let mk_plus_one e = match e.e_desc with
| Eextvalue ({ w_desc = Wconst idx; _ } as w) ->
| Eextvalue ({ w_desc = Wconst idx } as w) ->
let idx_plus_one = mk_static_int_op (mk_pervasives "+") [idx; mk_static_int 1] in
{ e with e_desc = Eextvalue { w with w_desc = Wconst idx_plus_one; }; }
| _ ->
@ -155,7 +155,7 @@ let update_record dest src f v =
in
let fields = match dest.pat_ty with
| Tid n -> Modules.find_struct n
| _ -> Misc.internal_error "mls2obc field of nonstruct" 1
| _ -> Misc.internal_error "mls2obc field of nonstruct"
in
List.map assgn_act fields
@ -174,7 +174,7 @@ let rec translate_pat map ty pat = match pat, ty with
| Minils.Etuplepat pat_list, Tprod ty_l ->
List.fold_right2 (fun ty pat acc -> (translate_pat map ty pat) @ acc)
ty_l pat_list []
| Minils.Etuplepat _, _ -> Misc.internal_error "Ill-typed pattern" 0
| Minils.Etuplepat _, _ -> Misc.internal_error "Ill-typed pattern"
let translate_var_dec l =
let one_var { Minils.v_ident = x; Minils.v_type = t; v_loc = loc } =
@ -221,6 +221,9 @@ let rec translate map e =
let e = translate_extvalue map (assert_1 e_list) in
let idx_list = List.map mk_exp_static_int idx_list in
Eextvalue (extvalue_of_idx_list e idx_list)
| Minils.Ewhen(e,_,_) ->
let e = translate map e in
e.e_desc
(* Already treated cases when translating the [eq] *)
| Minils.Eiterator _ | Minils.Emerge _ | Minils.Efby _
| Minils.Eapp ({Minils.a_op=(Minils.Enode _|Minils.Efun _|Minils.Econcat
@ -228,7 +231,7 @@ let rec translate map e =
|Minils.Eselect_trunc|Minils.Eselect_slice
|Minils.Earray_fill|Minils.Efield_update
|Minils.Eifthenelse)}, _, _) ->
internal_error "mls2obc" 5
internal_error "mls2obc"
in
mk_exp e.Minils.e_ty desc
@ -243,6 +246,7 @@ and translate_act map pat
({ Minils.e_desc = desc } as act) =
match pat, desc with
(* When Merge *)
| pat, Minils.Ewhen (e,_,_) -> translate_act map pat e
| Minils.Evarpat x, Minils.Emerge (y, c_act_list) ->
let x = var_from_name map x in
let translate_c_extvalue (c, w) =
@ -281,7 +285,7 @@ and translate_act map pat
let x = var_from_name map x in
let t = match x.pat_ty with
| Tarray (t,_) -> t
| _ -> Misc.internal_error "mls2obc select slice type" 5
| _ -> Misc.internal_error "mls2obc select slice type"
in
let rec make_loop power_list replace = match power_list with
@ -306,7 +310,7 @@ and translate_act map pat
let x = var_from_name map x in
let t = match x.pat_ty with
| Tarray (t,_) -> t
| _ -> Misc.internal_error "mls2obc select slice type" 5
| _ -> Misc.internal_error "mls2obc select slice type"
in
let idx = mk_exp_int (Eop (op_from_string "+",
[mk_evar_int cpt; mk_exp_static_int idx1 ])) in
@ -384,7 +388,7 @@ let empty_call_context = None
[v] var decs *)
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_ck = ck; Minils.e_loc = loc } = e in
let { Minils.e_desc = desc; Minils.e_base_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
@ -460,7 +464,7 @@ and mk_node_call map call_context app loc (name_list : Obc.pattern list) args ty
let e = mk_exp ty (Eop(f, args)) in
Aassgn (name, e)
| _ ->
Misc.unsupported "mls2obc: external function with multiple return values" 1 in
Misc.unsupported "mls2obc: external function with multiple return values" in
[], [], [], [act]
| Minils.Enode f when Itfusion.is_anon_node f ->
@ -510,7 +514,7 @@ and translate_iterator map call_context it name_list
| Tarray (t,_) -> t
| _ ->
Format.eprintf "%a" Global_printer.print_type ty;
internal_error "mls2obc" 6
internal_error "mls2obc"
in
let array_of_output name_list ty_list =
List.map2 (fun l ty -> mk_pattern ty (Larray (l, mk_evar_int x))) name_list ty_list

4
compiler/main/mls2seq.ml
View file

@ -47,10 +47,10 @@ let targets = [ "c",(Obc_no_params Cmain.program, no_conf);
"epo", (Minils write_object_file, no_conf) ]
let generate_target p s =
let print_unfolded p_list =
(* let print_unfolded p_list =
comment "Unfolding";
if !Compiler_options.verbose
then List.iter (Mls_printer.print stderr) p_list in
then List.iter (Mls_printer.print stderr) p_list in*)
let target =
(try fst (List.assoc s targets)
with Not_found -> language_error s; raise Errors.Error) in

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

@ -8,9 +8,19 @@
(**************************************************************************)
(* clock checking *)
(* v_clock is expected to contain correct clocks before entering here :
either explicit with Cbase representing the node activation clock
or fresh_clock() for unannoted variables.
Idem for e_ct : if explicit, it represents a clock annotation.
Unification is done on this mutable fields.
e_base_ck is set according to node signatures.
*)
open Misc
open Idents
open Minils
open Global_printer
open Mls_printer
open Signature
open Types
@ -19,139 +29,181 @@ open Location
open Format
(** Error Kind *)
type error_kind = | Etypeclash of ct * ct
type error_kind = | Etypeclash of ct * ct | Eclockclash of ck * ck | Edefclock
let error_message loc = function
| Etypeclash (actual_ct, expected_ct) ->
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;
print_ct actual_ct
print_ct expected_ct;
raise Errors.Error
| Eclockclash (actual_ck, expected_ck) ->
Format.eprintf "%aClock Clash: this value has clock %a,@\n\
but is exprected to have clock %a.@."
print_location loc
print_ck actual_ck
print_ck expected_ck;
raise Errors.Error
| Edefclock ->
Format.eprintf "%aArguments defining clocks should be given as names@."
print_location loc;
raise Errors.Error
let typ_of_name h x = Env.find x h
let ck_of_name h x =
if is_reset x
then fresh_clock()
else Env.find x h
let rec typing_extvalue h w =
let ct = match w.w_desc with
| Wconst se -> skeleton (fresh_clock ()) se.se_ty
| Wvar x -> Ck (typ_of_name h x)
let ck = match w.w_desc with
| Wconst _ -> fresh_clock()
| Wvar x -> ck_of_name h x
| Wwhen (w1, c, n) ->
let ck_n = typ_of_name h n in
(expect h (skeleton ck_n w1.w_ty) w1; skeleton (Con (ck_n, c, n)) w1.w_ty)
| Wfield (w1, f) ->
let ck = fresh_clock () in
let ct = skeleton ck w1.w_ty in (expect h (Ck ck) w1; ct)
in (w.w_ck <- ckofct ct; ct)
let ck_n = ck_of_name h n in
expect_extvalue h ck_n w1;
Con (ck_n, c, n)
| Wfield (w1, _) ->
typing_extvalue h w1
in
w.w_ck <- ck;
ck
and expect h expected_ty e =
let actual_ty = typing_extvalue h e in
try unify actual_ty expected_ty
and expect_extvalue h expected_ck e =
let actual_ck = typing_extvalue h e in
try unify_ck actual_ck expected_ck
with
| Unify -> eprintf "%a : " print_extvalue e;
error_message e.w_loc (Etypeclash (actual_ty, expected_ty))
error_message e.w_loc (Eclockclash (actual_ck, expected_ck))
let rec typing h e =
let ct = match e.e_desc with
| Eextvalue w -> typing_extvalue h w
| Efby (_, e) -> typing_extvalue h e
| Eapp({a_op = op}, args, r) ->
let ck = match r with
| None -> fresh_clock ()
| Some(reset) -> typ_of_name h reset in
typing_op op args h e ck
(* Typed exactly as a fun or a node... *)
| Eiterator (_, _, _, pargs, args, r) ->
let ck = match r with
| None -> fresh_clock()
| Some(reset) -> typ_of_name h reset
in
List.iter (expect h (Ck ck)) pargs;
List.iter (expect h (Ck ck)) args;
skeleton ck 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 = fresh_clock () in
(List.iter
(fun (_, e) -> let ct = skeleton ck e.w_ty in expect h ct e) l;
Ck ck)
in (e.e_ck <- ckofct ct; ct)
let rec typing_pat h = function
| Evarpat x -> Ck (ck_of_name h x)
| Etuplepat pat_list -> Cprod (List.map (typing_pat h) pat_list)
and typing_op op e_list h e ck = match op with
| (Eequal | Efun _ | Enode _) -> (*LA*)
List.iter (fun e -> expect h (skeleton ck e.w_ty) e) e_list;
skeleton ck e.e_ty
| Eifthenelse ->
let e1, e2, e3 = assert_3 e_list in
let ct = skeleton ck e.e_ty
in (expect h (Ck ck) e1; expect h ct e2; expect h ct e3; ct)
| Efield_update ->
let e1, e2 = assert_2 e_list in
let ct = skeleton ck e.e_ty
in (expect h (Ck ck) e1; expect h ct e2; ct)
| Earray ->
(List.iter (expect h (Ck ck)) e_list; skeleton ck e.e_ty)
| Earray_fill -> let e = assert_1 e_list in typing_extvalue h e
| Eselect -> let e = assert_1 e_list in typing_extvalue h e
| Eselect_dyn -> (* TODO defe not treated ? *)
let e1, defe, idx = assert_2min e_list in
let ct = skeleton ck e1.w_ty
in (List.iter (expect h ct) (e1::defe::idx); ct)
| Eselect_trunc ->
let e1, idx = assert_1min e_list in
let ct = skeleton ck e1.w_ty
in (List.iter (expect h ct) (e1::idx); ct)
| Eupdate ->
let e1, e2, idx = assert_2min e_list in
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 -> let e = assert_1 e_list in typing_extvalue h e
| Econcat ->
let e1, e2 = assert_2 e_list in
let ct = skeleton ck e.e_ty
in (expect h (Ck ck) e1; expect h ct e2; ct)
and typing_c_e_list h ck_c n c_e_list =
let rec typrec =
function
| [] -> ()
| (c, e) :: c_e_list ->
(expect h (skeleton (Con (ck_c, c, n)) e.w_ty) e; typrec c_e_list)
in typrec c_e_list
let typing_app h base pat op w_list = match op with
| Earray_fill | Eselect | Eselect_dyn | Eselect_trunc | Eupdate | Eequal
| Eselect_slice | Econcat | Earray | Efield_update | Eifthenelse ->
List.iter (expect_extvalue h base) w_list;
Ck base
| ( Efun f | Enode f) ->
let node = Modules.find_value f in
let pat_id_list = Mls_utils.ident_list_of_pat pat in
let rec build_env a_l v_l env = match a_l, v_l with
| [],[] -> env
| a::a_l, v::v_l -> (match a.a_name with
| None -> build_env a_l v_l env
| Some n -> build_env a_l v_l ((n,v)::env))
| _ -> Misc.internal_error "Clocking, non matching signature"
in
let env_pat = build_env node.node_outputs pat_id_list [] in
let env_args = build_env node.node_inputs w_list [] in
(* implement with Cbase as base, replace name dep by ident dep *)
let rec sigck_to_ck sck = match sck with
| Signature.Cbase -> base
| Signature.Con (sck,c,x) ->
(* find x in the envs : *)
let id = try List.assoc x env_pat
with Not_found ->
try
let w = List.assoc x env_args in
(match w.w_desc with
| Wvar id -> id
| _ -> error_message w.w_loc Edefclock)
with Not_found ->
Misc.internal_error "Clocking, non matching signature 2"
in
Clocks.Con (sigck_to_ck sck, c, id)
in
List.iter2 (fun a w -> expect_extvalue h (sigck_to_ck a.a_clock) w) node.node_inputs w_list;
Clocks.prod (List.map (fun a -> sigck_to_ck a.a_clock) node.node_outputs)
let expect_exp h expected_ty e =
let actual_ty = typing h e in
try unify actual_ty expected_ty
with
| Unify -> eprintf "%a : " print_exp e;
error_message e.e_loc (Etypeclash (actual_ty, expected_ty))
let rec typing_pat h =
function
| Evarpat x -> Ck (typ_of_name h x)
| Etuplepat pat_list -> Cprod (List.map (typing_pat h) pat_list)
let typing_eqs h eq_list = (*TODO FIXME*)
let typing_eq { eq_lhs = pat; eq_rhs = e } =
let ty_pat = typing_pat h pat in
(try expect_exp h ty_pat e with
| Errors.Error -> (* DEBUG *)
Format.eprintf "Complete expression: %a@\nClock pattern: %a@."
Mls_printer.print_exp e
Mls_printer.print_clock ty_pat;
raise Errors.Error)
in List.iter typing_eq eq_list
let build h dec =
List.fold_left (fun h { v_ident = n } -> Env.add n (fresh_clock ()) h) h dec
let typing_eq h { eq_lhs = pat; eq_rhs = e; eq_loc = loc } =
(* typing the expression, returns ct, ck_base *)
let rec typing e =
let ct,base = match e.e_desc with
| Eextvalue w
| Efby (_, w) ->
let ck = typing_extvalue h w in
Ck ck, ck
| Ewhen (e,c,n) ->
let ck_n = ck_of_name h n in
let base = expect (skeleton ck_n e.e_ty) e in
skeleton (Con (ck_n, c, n)) e.e_ty, base
| Emerge (x, c_e_list) ->
let ck = ck_of_name h x in
List.iter (fun (c,e) -> expect_extvalue h (Con (ck,c,x)) e) c_e_list;
Ck ck, ck
| Estruct l ->
let ck = fresh_clock () in
List.iter (fun (_, e) -> expect_extvalue h ck e) l;
Ck ck, ck
| Eapp({a_op = op}, args, _) -> (* hyperchronous reset *)
let base_ck = fresh_clock () in
let ct = typing_app h base_ck pat op args in
ct, base_ck
| Eiterator (it, {a_op = op}, _, pargs, args, _) -> (* hyperchronous reset *)
let base_ck = fresh_clock() in
let ct = match it with
| Imap -> (* exactly as if clocking the node *)
typing_app h base_ck pat op (pargs@args)
| Imapi -> (* clocking the node with the extra [i] input on [ck_r] *)
let i (* stubs [i] as 0 *) =
mk_extvalue ~ty:Initial.tint ~clock:base_ck (Wconst (Initial.mk_static_int 0))
in
typing_app h base_ck pat op (pargs@args@[i])
| Ifold | Imapfold ->
(* clocking node with equality constaint on last input and last output *)
let ct = typing_app h base_ck pat op (pargs@args) in
unify_ck (Clocks.last_clock ct) (Misc.last_element args).w_ck;
ct
| Ifoldi -> (* clocking the node with the extra [i] and last in/out constraints *)
let i (* stubs [i] as 0 *) =
mk_extvalue ~ty:Initial.tint ~clock:base_ck (Wconst (Initial.mk_static_int 0))
in
let rec insert_i args = match args with
| [] -> [i]
| [l] -> i::[l]
| h::l -> h::(insert_i l)
in
let ct = typing_app h base_ck pat op (pargs@(insert_i args)) in
unify_ck (Clocks.last_clock ct) (Misc.last_element args).w_ck;
ct
in
ct, base_ck
in
e.e_base_ck <- base;
(try unify ct e.e_ct
with Unify ->
eprintf "Incoherent clock annotation.@\n";
error_message e.e_loc (Etypeclash (ct,e.e_ct)));
e.e_ct <- ct;
ct, base
and expect expected_ct e =
let actual_ct,base = typing e in
(try unify actual_ct expected_ct
with Unify -> error_message e.e_loc (Etypeclash (actual_ct, expected_ct)));
base
in
let ct,_ = typing e in
let pat_ct = typing_pat h pat in
(try unify ct pat_ct
with Unify ->
eprintf "Incoherent clock between right and left side of the equation.@\n";
error_message loc (Etypeclash (ct, pat_ct)))
let sbuild h dec base =
List.fold_left (fun h { v_ident = n } -> Env.add n base h) h dec
let typing_eqs h eq_list = List.iter (typing_eq h) eq_list
let typing_contract h contract base =
let append_env h vds =
List.fold_left (fun h { v_ident = n; v_clock = ck } -> Env.add n ck h) h vds
let typing_contract h contract =
match contract with
| None -> h
| Some { c_local = l_list;
@ -159,32 +211,33 @@ let typing_contract h contract base =
c_assume = e_a;
c_enforce = e_g;
c_controllables = c_list } ->
let h' = build h l_list in
let h' = append_env h l_list in
(* assumption *)
(* property *)
typing_eqs h' eq_list;
expect_exp h' (Ck base) e_a;
expect_exp h' (Ck base) e_g;
sbuild h c_list base
expect_extvalue h' Cbase e_a;
expect_extvalue h' Cbase e_g;
append_env h c_list
let typing_node ({ n_input = i_list;
n_output = o_list;
n_contract = contract;
n_local = l_list;
n_equs = eq_list
} as node) =
let base = Cbase in
let h = sbuild Env.empty i_list base in
let h = sbuild h o_list base in
let h = typing_contract h contract base in
let h = build h l_list in
(typing_eqs h eq_list;
(*update clock info in variables descriptions *)
let set_clock vd = { vd with v_clock = ck_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;
n_local = List.map set_clock l_list })
let typing_node node =
let h0 = append_env Env.empty node.n_input in
let h0 = append_env h0 node.n_output in
let h = typing_contract h0 node.n_contract in
let h = append_env h node.n_local in
typing_eqs h node.n_equs;
(* synchronize input and output on base : find the free vars and set them to base *)
Env.iter (fun _ ck -> unify_ck Cbase (root_ck_of ck)) h0;
(*update clock info in variables descriptions *)
let set_clock vd = { vd with v_clock = ck_repr (Env.find vd.v_ident h) } in
let node = { node with n_input = List.map set_clock node.n_input;
n_output = List.map set_clock node.n_output;
n_local = List.map set_clock node.n_local }
in
(* check signature causality and update it in the global env *)
let sign = Mls_utils.signature_of_node node in
Signature.check_signature sign;
Modules.replace_value node.n_name sign;
node
let program p =
let program_desc pd = match pd with

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

@ -1,320 +0,0 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* simple initialization analysis. This is almost trivial since *)
(* input/outputs of a node are forced to be initialized *)
(* add a special treatment of clock state variables whose initial *)
(* values are known. This allows to accept code generated *)
(* for automata *)
(* if [clock c = C fby ec] then [merge c (C -> e) ...] is initialized *)
(* if [e] is initialized only *)
open Misc
open Names
open Idents
open Minils
open Location
open Format
open Types
type typ = | Iproduct of typ list | Ileaf of init
and init = { mutable i_desc : init_desc; mutable i_index : int}
and init_desc = | Izero | Ione | Ivar | Imax of init * init | Ilink of init
type typ_env =
{ t_init : init; (* its initialisation type *) t_value : longname option }
(* its initial value *)
(* typing errors *)
exception Unify
let index = ref 0
let gen_index () = (incr index; !index)
let new_var () = { i_desc = Ivar; i_index = gen_index (); }
let izero = { i_desc = Izero; i_index = gen_index (); }
let ione = { i_desc = Ione; i_index = gen_index (); }
let imax i1 i2 = { i_desc = Imax (i1, i2); i_index = gen_index (); }
let product l = Iproduct l
let leaf i = Ileaf i
(* basic operation on initialization values *)
let rec irepr i =
match i.i_desc with
| Ilink i_son ->
let i_son = irepr i_son in (i.i_desc <- Ilink i_son; i_son)
| _ -> i
(** Simplification rules for max. Nothing fancy here *)
let max i1 i2 =
let i1 = irepr i1 in
let i2 = irepr i2
in
match ((i1.i_desc), (i2.i_desc)) with
| (Izero, Izero) -> izero
| (Izero, _) -> i2
| (_, Izero) -> i1
| (_, Ione) | (Ione, _) -> ione
| _ -> imax i1 i2
let rec itype =
function | Iproduct ty_list -> itype_list ty_list | Ileaf i -> i
and itype_list ty_list =
List.fold_left (fun acc ty -> max acc (itype ty)) izero ty_list
(* saturate an initialization type. Every element must be initialized *)
let rec initialized i =
let i = irepr i
in
match i.i_desc with
| Izero -> ()
| Ivar -> i.i_desc <- Ilink izero
| Imax (i1, i2) -> (initialized i1; initialized i2)
| Ilink i -> initialized i
| Ione -> raise Unify
(* build an initialization type from a type *)
let rec skeleton i =
function
| Tprod ty_list -> product (List.map (skeleton i) ty_list)
| Tarray _ | Tid _ -> leaf i
(* sub-typing *)
let rec less left_ty right_ty =
if left_ty == right_ty
then ()
else
(match (left_ty, right_ty) with
| (Iproduct l1, Iproduct l2) -> List.iter2 less l1 l2
| (Ileaf i1, Ileaf i2) -> iless i1 i2
| _ -> raise Unify)
and iless left_i right_i =
if left_i == right_i
then ()
else
(let left_i = irepr left_i in
let right_i = irepr right_i
in
if left_i == right_i
then ()
else
(match ((left_i.i_desc), (right_i.i_desc)) with
| (Izero, _) | (_, Ione) -> ()
| (_, Izero) -> initialized left_i
| (Imax (i1, i2), _) -> (iless i1 right_i; iless i2 right_i)
| (_, Ivar) ->
let left_i = occur_check right_i.i_index left_i
in right_i.i_desc <- Ilink left_i
| (_, Imax (i1, i2)) ->
let i1 = occur_check left_i.i_index i1 in
let i2 = occur_check left_i.i_index i2
in right_i.i_desc <- Ilink (imax left_i (imax i1 i2))
| _ -> raise Unify))
and (* an inequation [a < t[a]] becomes [a = t[0]] *) occur_check index i =
match i.i_desc with
| Izero | Ione -> i
| Ivar -> if i.i_index = index then izero else i
| Imax (i1, i2) -> max (occur_check index i1) (occur_check index i2)
| Ilink i -> occur_check index i
(* computes the initialization type of a merge *)
let merge opt_c c_i_list =
let rec search c c_i_list =
match c_i_list with
| [] -> izero
| (c0, i) :: c_i_list -> if c = c0 then i else search c c_i_list
in
match opt_c with
| None -> List.fold_left (fun acc (_, i) -> max acc i) izero c_i_list
| Some c -> search c c_i_list
module Printer =
struct
open Format
let rec print_list_r print po sep pf ff =
function
| [] -> ()
| x :: l ->
(fprintf ff "@[%s%a" po print x;
List.iter (fprintf ff "%s@]@ @[%a" sep print) l;
fprintf ff "%s@]" pf)
let rec 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@]" print_init i1 print_init i2
| Ilink i -> print_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_type "(" " *" ")") ty_list
end
module Error =
struct
open Location
type error = | Eclash of typ * typ
exception Error of location * error
let error loc kind = raise (Error (loc, kind))
let message loc kind =
((match kind with
| Eclash (left_ty, right_ty) ->
Format.eprintf
"%aInitialization error: this expression has type \
%a,@\n\
but is expected to have type %a@."
print_location loc Printer.output_typ left_ty Printer.
output_typ right_ty);
raise Errors.Error)
end
let less_exp e actual_ty expected_ty =
try less actual_ty expected_ty
with
| Unify -> Error.message e.e_loc (Error.Eclash (actual_ty, expected_ty))
let rec typing h e =
match e.e_desc with
| Econst c -> leaf izero
| Evar x -> let { t_init = i } = Env.find x h in leaf i
| Efby (None, e) -> (expect h e (skeleton izero e.e_ty); leaf ione)
| Efby ((Some _), e) -> (expect h e (skeleton izero e.e_ty); leaf izero)
| Etuple e_list -> product (List.map (typing h) e_list)
(*TODO traitement singulier et empêche reset d'un 'op'*)
| Ecall (op, e_list, None) when op.op_kind = Efun ->
let i = List.fold_left (fun acc e -> itype (typing h e)) izero e_list
in skeleton i e.e_ty
| Ecall (op, e_list, reset) when op.op_kind = Enode ->
List.iter (fun e -> expect h e (skeleton izero e.e_ty)) e_list;
let i = match reset with
| None -> izero
| Some(n) -> let { t_init = i } = Env.find n h in i
in skeleton i e.e_ty
| Ewhen (e, c, n) ->
let { t_init = i1 } = Env.find n h in
let i2 = itype (typing h e) in skeleton (max i1 i2) e.e_ty
(* result of the encoding of e1 -> e2 ==
if true fby false then e1 else e2 *)
| Eifthenelse(
{ e_desc = Efby(Some (Cconstr tn), { e_desc = Econst (Cconstr fn) }) },
e2, e3) when tn = Initial.ptrue & fn = Initial.pfalse ->
expect h e3 (skeleton ione e3.e_ty);
let i = itype (typing h e2) in skeleton i e.e_ty
| Eifthenelse (e1, e2, e3) ->
let i1 = itype (typing h e1) in
let i2 = itype (typing h e2) in
let i3 = itype (typing h e3) in
let i = max i1 (max i2 i3) in skeleton i e.e_ty
| Emerge (n, c_e_list) ->
let { t_init = i; t_value = opt_c } = Env.find n h in
let i =
merge opt_c
(List.map (fun (c, e) -> (c, (itype (typing h e)))) c_e_list)
in skeleton i e.e_ty
| Efield (e1, n) -> let i = itype (typing h e1) in skeleton i e.e_ty
| Estruct l ->
let i =
List.fold_left (fun acc (_, e) -> max acc (itype (typing h e))) izero
l
in skeleton i e.e_ty
| Efield_update _ | Econstvar _ | Earray _ | Earray_op _ ->
leaf izero (* TODO FIXME array_op dans init *)
and expect h e expected_ty =
let actual_ty = typing h e in less_exp e actual_ty expected_ty
let rec typing_pat h =
function
| Evarpat x -> let { t_init = i } = Env.find x h in leaf i
| Etuplepat pat_list -> product (List.map (typing_pat h) pat_list)
let typing_eqs h eq_list =
List.iter
(fun { eq_lhs = pat; eq_rhs = e } ->
let ty_pat = typing_pat h pat in expect h e ty_pat)
eq_list
let build h eq_list =
let rec build_pat h =
function
| Evarpat x -> Env.add x { t_init = new_var (); t_value = None; } h
| Etuplepat pat_list -> List.fold_left build_pat h pat_list in
let build_equation h { eq_lhs = pat; eq_rhs = e } =
match (pat, (e.e_desc)) with
| (Evarpat x, Efby ((Some (Cconstr c)), _)) ->
(* we keep the initial value of state variables *)
Env.add x { t_init = new_var (); t_value = Some c; } h
| _ -> build_pat h pat
in List.fold_left build_equation h eq_list
let sbuild h dec =
List.fold_left
(fun h { v_ident = n } -> Env.add n { t_init = izero; t_value = None; } h)
h dec
let typing_contract h contract =
match contract with
| None -> h
| Some
{
c_local = l_list;
c_eq = eq_list;
c_assume = e_a;
c_enforce = e_g;
c_controllables = c_list
} ->
let h = sbuild h c_list in
let h' = build h eq_list
in
(* assumption *)
(* property *)
(typing_eqs h' eq_list;
expect h' e_a (skeleton izero e_a.e_ty);
expect h' e_g (skeleton izero e_g.e_ty);
h)
let typing_node {
n_name = f;
n_input = i_list;
n_output = o_list;
n_contract = contract;
n_local = l_list;
n_equs = eq_list
} =
let h = sbuild Env.empty i_list in
let h = sbuild h o_list in
let h = typing_contract h contract in
let h = build h eq_list in typing_eqs h eq_list
let program (({ p_nodes = p_node_list } as p)) =
(List.iter typing_node p_node_list; p)

33
compiler/minils/analysis/level_clock.ml Normal file
View file

@ -0,0 +1,33 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
open Clocks
open Minils
(* Any clock variable left after clocking is free and should be set to level_ck.
Since inputs and outputs are grounded to Cbase, this append when
no data dependence exists between an expression and the inputs/outputs.*)
(* We are confident that it is sufficient to unify level_ck with base_ck
for expressions having a base_ck == Cvar.
The other ones are coming from one like this one,
indeed if it was Con (Cvar,c,x) x would have to be defined with an expression of clock Cvar.*)
let eq _ acc eq =
let e = eq.eq_rhs in
let _ = match ck_repr e.e_base_ck with
| Cvar {contents = Cindex _} -> unify_ck e.e_base_ck e.e_level_ck
| _ -> ()
in
eq,acc (* no recursion since in minils exps are not recursive *)
let program p =
let funs = { Mls_mapfold.defaults with Mls_mapfold.eq = eq } in
let p, _ = Mls_mapfold.program_it funs [] p in
p

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

@ -15,10 +15,20 @@ let pp p = if !verbose then Mls_printer.print stdout p
let compile_program p =
(* Clocking *)
let p = pass "Clocking" true Clocking.program p pp in
let p =
try pass "Clocking" true Clocking.program p pp
with Errors.Error ->
comment ~sep:"" "\nInfered clocks :\n";
pp p;
comment ~sep:"*** " ("Clocking failed.");
if !print_types then Global_printer.print_interface Format.std_formatter;
raise Errors.Error
in
(* Check that the dataflow code is well initialized *)
(*let p = silent_pass "Initialization check" !init Init.program p in *)
if !print_types then Global_printer.print_interface Format.std_formatter;
(* Level clocks *)
let p = pass "Level clock" true Level_clock.program p pp in
(* Automata minimization *)
(*

34
compiler/minils/minils.ml
View file

@ -46,16 +46,18 @@ and extvalue = {
w_loc : location }
and extvalue_desc =
| Wconst of static_exp
| Wconst of static_exp (*no tuple*)
| Wvar of var_ident
| Wfield of extvalue * field_name
| Wwhen of extvalue * constructor_name * var_ident (** extvalue when Constructor(ident) *)
and exp = {
e_desc : edesc;
mutable e_ck: ck;
e_ty : ty;
e_loc : location }
e_desc : edesc;
e_level_ck : ck; (*when no data dep, execute the exp on this clock (set by [switch] *)
mutable e_base_ck : ck;
mutable e_ct : ct;
e_ty : ty;
e_loc : location }
and edesc =
| Eextvalue of extvalue
@ -63,13 +65,14 @@ and edesc =
(** static_exp fby extvalue *)
| Eapp of app * extvalue list * var_ident option
(** app ~args=(extvalue,extvalue...) reset ~r=ident *)
| Ewhen of exp * constructor_name * var_ident (** e when C(c) *)
| Emerge of var_ident * (constructor_name * extvalue) list
(** merge ident (Constructor -> extvalue)+ *)
| Estruct of (field_name * extvalue) list
(** { field=extvalue; ... } *)
| Eiterator of iterator_type * app * static_exp
* extvalue list * extvalue list * var_ident option
(** map f <<n>> (extvalue, extvalue...) reset ident *)
(** map f <<n>> <(extvalue)> (extvalue) reset ident *)
and app = { a_op: op; a_params: static_exp list; a_unsafe: bool }
(** Unsafe applications could have side effects
@ -107,8 +110,8 @@ type var_dec = {
v_loc : location }
type contract = {
c_assume : exp;
c_enforce : exp;
c_assume : extvalue;
c_enforce : extvalue;
c_controllables : var_dec list;
c_local : var_dec list;
c_eq : eq list }
@ -119,13 +122,11 @@ type node_dec = {
n_input : var_dec list;
n_output : var_dec list;
n_contract : contract option;
(* GD: inglorious hack for controller call
mutable n_controller_call : var_ident list * var_ident list; *)
n_local : var_dec list;
n_equs : eq list;
n_loc : location;
n_params : param list;
n_params_constraints : size_constraint list }
n_param_constraints : constrnt list }
type const_dec = {
c_name : qualname;
@ -150,12 +151,11 @@ let mk_extvalue ~ty ?(clock = fresh_clock()) ?(loc = no_location) desc =
{ w_desc = desc; w_ty = ty;
w_ck = clock; w_loc = loc }
let mk_exp ty ?(clock = fresh_clock()) ?(loc = no_location) desc =
{ e_desc = desc; e_ty = ty;
e_ck = clock; e_loc = loc }
let mk_exp level_ck ty ?(ck = Cbase) ?(ct = fresh_ct ty) ?(loc = no_location) desc =
{ e_desc = desc; e_ty = ty; e_level_ck = level_ck; e_base_ck = ck; e_ct = ct; e_loc = loc }
let mk_var_dec ?(loc = no_location) ?(clock = fresh_clock()) ident ty =
{ v_ident = ident; v_type = ty; v_clock = clock; v_loc = loc }
let mk_var_dec ?(loc = no_location) ident ty ck =
{ v_ident = ident; v_type = ty; v_clock = ck; v_loc = loc }
let mk_equation ?(loc = no_location) pat exp =
{ eq_lhs = pat; eq_rhs = exp; eq_loc = loc }
@ -173,7 +173,7 @@ let mk_node
n_equs = eq;
n_loc = loc;
n_params = param;
n_params_constraints = constraints }
n_param_constraints = constraints }
let mk_type_dec type_desc name loc =
{ t_name = name; t_desc = type_desc; t_loc = loc }

7
compiler/minils/mls_mapfold.ml
View file

@ -85,6 +85,9 @@ and edesc funs acc ed = match ed with
(c,w), acc in
let c_w_list, acc = mapfold aux acc c_w_list in
Emerge(x, c_w_list), acc
| Ewhen(e,c,x) ->
let e, acc = exp_it funs acc e in
Ewhen(e,c,x), acc
| Estruct n_w_list ->
let aux acc (n,w) =
let w, acc = extvalue_it funs acc w in
@ -136,8 +139,8 @@ 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_assume, acc = extvalue_it funs acc c.c_assume in
let c_enforce, acc = extvalue_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

28
compiler/minils/mls_printer.ml
View file

@ -1,11 +1,11 @@
open Misc
open Names
open Signature
open Idents
open Types
open Clocks
open Static
open Format
open Signature
open Global_printer
open Pp_tools
open Minils
@ -28,22 +28,10 @@ let rec print_pat ff = function
| Etuplepat 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_qualname c print_ident n
| Cvar { contents = Cindex _ } -> 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
let print_vd ff { v_ident = n; v_type = ty; v_clock = ck } =
if !Compiler_options.full_type_info then
(* if !Compiler_options.full_type_info then*)
fprintf ff "%a : %a :: %a" print_ident n print_type ty print_ck ck
else fprintf ff "%a : %a" print_ident n print_type ty
(*else fprintf ff "%a : %a" print_ident n print_type ty*)
let print_local_vars ff = function
| [] -> ()
@ -86,7 +74,7 @@ and print_trunc_index ff idx =
and print_exp ff e =
if !Compiler_options.full_type_info then
fprintf ff "(%a : %a :: %a)"
print_exp_desc e.e_desc print_type e.e_ty print_ck e.e_ck
print_exp_desc e.e_desc print_type e.e_ty print_ct e.e_ct
else fprintf ff "%a" print_exp_desc e.e_desc
and print_every ff reset =
@ -114,6 +102,8 @@ and print_exp_desc ff = function
fprintf ff "@[<2>%a@,%a@]" print_app (app, args) print_every reset
| Emerge (x, tag_w_list) ->
fprintf ff "@[<2>merge %a@ %a@]" print_ident x print_tag_w_list tag_w_list
| Ewhen (e,c,x) ->
fprintf ff "@[<2>(%a@ when %a(%a))@]" print_exp e print_qualname c print_ident x
| Estruct f_w_list ->
print_record (print_couple print_qualname print_extvalue """ = """) ff f_w_list
| Eiterator (it, f, param, pargs, args, reset) ->
@ -180,7 +170,7 @@ and print_tag_w_list ff tag_w_list =
and print_eq ff { eq_lhs = p; eq_rhs = e } =
if !Compiler_options.full_type_info
then fprintf ff "@[<2>%a :: %a =@ %a@]"
print_pat p print_ck e.e_ck print_exp e
print_pat p print_ck e.e_base_ck print_exp e
else fprintf ff "@[<2>%a =@ %a@]" print_pat p print_exp e
@ -207,8 +197,8 @@ let print_contract ff { c_local = l; c_eq = eqs;
fprintf ff "@[<v2>contract@\n%a%a@ assume %a@ enforce %a@ with (%a)@]"
print_local_vars l
print_eqs eqs
print_exp e_a
print_exp e_g
print_extvalue e_a
print_extvalue e_g
print_vd_tuple c

37
compiler/minils/mls_utils.ml
View file

@ -46,10 +46,6 @@ let rec vd_mem n = function
| [] -> false
| vd::l -> vd.v_ident = n or (vd_mem n l)
(** @return a signature arguments from the vardecs *)
let args_of_var_decs vds =
List.map (fun vd -> Signature.mk_arg (Some (name vd.v_ident)) vd.v_type) vds
(** @return whether [ty] corresponds to a record type. *)
let is_record_type ty = match ty with
@ -77,6 +73,10 @@ struct
| Cbase | Cvar { contents = Cindex _ } -> acc
| Cvar { contents = Clink ck } -> vars_ck acc ck
let rec vars_ct acc = function
| Ck ck -> vars_ck acc ck
| Cprod c_l -> List.fold_left vars_ct acc c_l
let read_extvalue read_funs (is_left, acc_init) w =
(* recursive call *)
let _,(_, acc) = Mls_mapfold.extvalue read_funs (is_left, acc_init) w in
@ -104,7 +104,7 @@ struct
else acc
| _ -> acc
in
e, (is_left, vars_ck acc e.e_ck)
e, (is_left, vars_ct acc e.e_ct)
let read_exp is_left acc e =
let _, (_, acc) =
@ -136,14 +136,13 @@ struct
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.w_ck
| _ -> e.e_ck
let clock { eq_rhs = e } = e.e_base_ck
let head ck =
let rec headrec ck l =
match ck with
| Cbase | Cvar { contents = Cindex _ } -> l
| Cbase
| Cvar { contents = Cindex _ } -> l
| Con(ck, _, n) -> headrec ck (n :: l)
| Cvar { contents = Clink ck } -> headrec ck l
in
@ -191,3 +190,23 @@ module AllDep = Dep.Make
let eq_find id = List.find (fun eq -> List.mem id (Vars.def [] eq))
let ident_list_of_pat pat =
let rec f acc pat = match pat with
| Evarpat id -> id::acc
| Etuplepat pat_l -> List.fold_left f acc pat_l
in
List.rev (f [] pat)
let args_of_var_decs =
List.map (fun vd -> Signature.mk_arg (Some (Idents.source_name vd.v_ident))
vd.v_type (Signature.ck_to_sck vd.v_clock))
let signature_of_node n =
{ node_inputs = args_of_var_decs n.n_input;
node_outputs = args_of_var_decs n.n_output;
node_stateful = n.n_stateful;
node_params = n.n_params;
node_param_constraints = n.n_param_constraints;
node_loc = n.n_loc }

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

@ -140,7 +140,7 @@ struct
(match q.qual with
| LocalModule -> (* This var is a static parameter, it has to be instanciated *)
(try QualEnv.find q m
with Not_found -> Misc.internal_error "callgraph" 0)
with Not_found -> Misc.internal_error "callgraph")
| _ -> se)
| _ -> se in
se, m
@ -182,12 +182,12 @@ struct
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
node_param_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 = []; }
{ n with n_name = ln; n_params = []; n_param_constraints = []; }
let node_dec n =
List.map (node_dec_instance n) (get_node_instances n.n_name)
@ -222,8 +222,8 @@ let load_object_file modul =
let modname = match modul with
| Names.Pervasives -> "Pervasives"
| Names.Module n -> n
| Names.LocalModule -> Misc.internal_error "modules" 0
| Names.QualModule _ -> Misc.unsupported "modules" 0
| Names.LocalModule -> Misc.internal_error "modules"
| Names.QualModule _ -> Misc.unsupported "modules"
in
let name = String.uncapitalize modname in
try
@ -261,7 +261,7 @@ let node_by_longname node =
let n = List.find (function Pnode n -> n.n_name = node | _ -> false) p.p_desc in
(match n with
| Pnode n -> n
| _ -> Misc.internal_error "callgraph" 0)
| _ -> Misc.internal_error "callgraph")
with
Not_found -> Error.message no_location (Error.Enode_unbound node)
@ -318,7 +318,7 @@ let program p =
(* Find the nodes without static parameters *)
let main_nodes = List.filter (function Pnode n -> is_empty n.n_params | _ -> false) p.p_desc in
let main_nodes = List.map (function Pnode n -> n.n_name, []
| _ -> Misc.internal_error "callgraph" 0) main_nodes in
| _ -> Misc.internal_error "callgraph") main_nodes in
info.opened <- ModulEnv.add p.p_modname p ModulEnv.empty;
(* Creates the list of instances starting from these nodes *)
List.iter call_node main_nodes;

2
compiler/minils/transformations/checkpass.ml
View file

@ -48,7 +48,7 @@ let add_check prefix pass nd nd_list =
node_outputs = [{ a_name = None; a_type = Tid Initial.pbool; }];
node_stateful = true;
node_params = [];
node_params_constraints = [] };
node_param_constraints = [] };
Compiler_options.add_assert nd_check.n_name.name;
nd :: nd' :: nd_check :: nd_list

3
compiler/minils/transformations/normalize_mem.ml
View file

@ -22,8 +22,9 @@ let eq _ (outputs, eqs, env) eq = match eq.eq_lhs, eq.eq_rhs.e_desc with
| Evarpat x, Efby _ ->
if Mls_utils.vd_mem x outputs then
let ty = eq.eq_rhs.e_ty in
let ck = eq.eq_rhs.e_base_ck in
let x_copy = Idents.gen_var "normalize_mem" ("out_"^(Idents.name x)) in
let exp_x = mk_exp ty (Eextvalue (mk_extvalue ~ty:ty (Wvar x))) in
let exp_x = mk_exp ck ty (Eextvalue (mk_extvalue ~ty:ty (Wvar x))) in
let eq_copy = { eq with eq_lhs = Evarpat x_copy; eq_rhs = exp_x } in
let env = Env.add x x_copy env in
eq, (outputs, eq::eq_copy::eqs, env)

10
compiler/obc/c/cgen.ml
View file

@ -244,7 +244,7 @@ let rec cexpr_of_static_exp se =
Cstructlit (ty_name,
List.map (fun (_, se) -> cexpr_of_static_exp se) fl)
| Sarray_power(c,n_list) ->
(List.fold_left (fun cc n -> Carraylit (repeat_list cc (int_of_static_exp n)))
(List.fold_left (fun cc n -> Carraylit (repeat_list cc (int_of_static_exp n)))
(cexpr_of_static_exp c) n_list)
| Svar ln ->
(try
@ -291,7 +291,7 @@ and cop_of_op_aux op_name cexps = match op_name with
Cbop (copname op, el, er)
| _ -> Cfun_call(op, cexps)
end
| { name = op; _ } -> Cfun_call(op,cexps)
| { name = op } -> Cfun_call(op,cexps)
and cop_of_op out_env var_env op_name exps =
let cexps = cexprs_of_exps out_env var_env exps in
@ -462,8 +462,8 @@ let rec create_affect_const var_env (dest : clhs) c =
| [] -> dest, replace
| p :: power_list ->
let x = gen_symbol () in
let e, replace =
make_loop power_list
let e, replace =
make_loop power_list
(fun y -> [Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp p, replace y)]) in
let e = (CLarray (e, Cvar x)) in
e, replace
@ -531,7 +531,7 @@ let rec cstm_of_act out_env var_env obj_env act =
cstm_of_act_list out_env var_env obj_env act)]
(** Translate constant assignment *)
| Aassgn (vn, { e_desc = Eextvalue { w_desc = Wconst c; _}; }) ->
| Aassgn (vn, { e_desc = Eextvalue { w_desc = Wconst c }; }) ->
let vn = clhs_of_pattern out_env var_env vn in
create_affect_const var_env vn c

56
compiler/obc/c/cmain.ml
View file

@ -82,7 +82,7 @@ let assert_node_res cd =
Cif (Cuop ("!", Cfield (Cvar (fst out), local_qn outn)),
[Csexpr (Cfun_call ("fprintf",
[Cvar "stderr";
Cconst (Cstrlit ("Node \\\"" ^ name
Cconst (Cstrlit ("Node \\\"" ^ name
^ "\\\" failed at step" ^
" %d.\\n"));
Cvar step_counter]));
@ -133,24 +133,24 @@ let main_def_of_class_def cd =
let scan_exp =
let printf_s = Format.sprintf "%s ? " prompt in
let format_s = format_for_type ty in
let exp_scanf = Cfun_call ("scanf",
let exp_scanf = Cfun_call ("scanf",
[Cconst (Cstrlit format_s);
Caddrof lhs]) in
let body =
if !Compiler_options.hepts_simulation
then (* hepts: systematically test and quit when EOF *)
[Cif(Cbop("==",exp_scanf,Cvar("EOF")),
[Creturn(mk_int 0)],[])]
else
[Csexpr (exp_scanf);] in
let body =
if !Compiler_options.hepts_simulation then
body
else
Csexpr (Cfun_call ("printf",
let body =
if !Compiler_options.hepts_simulation
then (* hepts: systematically test and quit when EOF *)
[Cif(Cbop("==",exp_scanf,Cvar("EOF")),
[Creturn(mk_int 0)],[])]
else
[Csexpr (exp_scanf);] in
let body =
if !Compiler_options.hepts_simulation then
body
else
Csexpr (Cfun_call ("printf",
Cconst (Cstrlit printf_s)
:: args_format_s))
:: body in
:: body in
Csblock { var_decls = [];
block_body = body; } in
match need_buf_for_ty ty with
@ -169,21 +169,21 @@ let main_def_of_class_def cd =
let iter_var = fresh "i" in
let lhs = Carray (lhs, Cvar iter_var) in
let (writes, bufs) = write_lhs_of_ty lhs ty in
let writes_loop =
Cfor (iter_var, mk_int 0, cexpr_of_static_exp n, writes) in
if !Compiler_options.hepts_simulation then
([writes_loop], bufs)
else
let writes_loop =
Cfor (iter_var, mk_int 0, cexpr_of_static_exp n, writes) in
if !Compiler_options.hepts_simulation then
([writes_loop], bufs)
else
([cprint_string "[ ";
writes_loop;
writes_loop;
cprint_string "]"], bufs)
| _ ->
let varn = fresh "buf" in
let format_s = format_for_type ty in
let format_s =
if !Compiler_options.hepts_simulation
then format_s ^ "\\n"
else format_s ^ " " in
let format_s =
if !Compiler_options.hepts_simulation
then format_s ^ "\\n"
else format_s ^ " " in
let nbuf_opt = need_buf_for_ty ty in
let ep = match nbuf_opt with
| None -> [lhs]
@ -209,9 +209,9 @@ let main_def_of_class_def cd =
write_lhs_of_ty (Cfield (Cvar "res",
local_qn (name vd.v_ident))) vd.v_type in
if !Compiler_options.hepts_simulation then
(stm, vars)
(stm, vars)
else
(cprint_string "=> " :: stm, vars)
(cprint_string "=> " :: stm, vars)
in
split (map write_lhs_of_ty_for_vd stepm.m_outputs) in
let printf_calls = List.concat printf_calls in
@ -240,7 +240,7 @@ let main_def_of_class_def cd =
concat scanf_calls
@ [Csexpr funcall]
@ printf_calls
@
@
(if !Compiler_options.hepts_simulation
then []
else [Csexpr (Cfun_call ("puts", [Cconst (Cstrlit "")]))])

2
compiler/obc/control.ml
View file

@ -61,7 +61,7 @@ and joinhandlers h1 h2 =
with Not_found -> s1, h2 in
(c1, join_block s1') :: joinhandlers h1' h2'
let block funs acc b =
let block _ acc b =
{ b with b_body = joinlist b.b_body }, acc
let program p =

42
compiler/obc/java/obc2java.ml
View file

@ -103,21 +103,21 @@ let rec static_exp param_env se = match se.Types.se_desc with
| Types.Sbool b -> Sbool b
| Types.Sstring s -> Sstring s
| Types.Sconstructor c -> let c = translate_constructor_name c in Sconstructor c
| Types.Sfield f -> eprintf "ojSfield @."; assert false;
| Types.Sfield _ -> eprintf "ojSfield @."; assert false;
| Types.Stuple se_l -> tuple param_env se_l
| Types.Sarray_power (see,pow_list) ->
let pow_list = List.rev pow_list in
let rec make_array tyl pow_list = match tyl, pow_list with
| Tarray(t, _), pow::pow_list ->
| Tarray(t, _), pow::pow_list ->
let pow = (try Static.int_of_static_exp Names.QualEnv.empty pow
with Errors.Error ->
eprintf "%aStatic power of array should have integer power. \
Please use callgraph or non-static exp in %a.@."
Location.print_location se.Types.se_loc
Global_printer.print_static_exp se;
raise Errors.Error)
eprintf "%aStatic power of array should have integer power. \
Please use callgraph or non-static exp in %a.@."
Location.print_location se.Types.se_loc
Global_printer.print_static_exp se;
raise Errors.Error)
in
Enew_array (tyl, Misc.repeat_list (make_array t pow_list) pow)
Enew_array (tyl, Misc.repeat_list (make_array t pow_list) pow)
| _ -> static_exp param_env see
in
make_array (ty param_env se.Types.se_ty) pow_list
@ -126,20 +126,20 @@ let rec static_exp param_env se = match se.Types.se_desc with
| _ -> Misc.internal_error "mls2obc select slice type" 5
in
let eval_int pow = (try Static.int_of_static_exp Names.QualEnv.empty pow
with Errors.Error ->
eprintf "%aStatic power of array should have integer power. \
Please use callgraph or non-static exp in %a.@."
Location.print_location se.Types.se_loc
Global_printer.print_static_exp se;
raise Errors.Error)
with Errors.Error ->
eprintf "%aStatic power of array should have integer power. \
Please use callgraph or non-static exp in %a.@."
Location.print_location se.Types.se_loc
Global_printer.print_static_exp se;
raise Errors.Error)
in
let rec make_matrix acc = match pow_list with
| [] -> acc
| pow :: pow_list ->
let pow = eval_int pow in
| pow :: pow_list ->
let pow = eval_int pow in
make_matrix (Misc.repeat_list acc pow) pow_list
in
let se_l = match pow_list with
let se_l = match pow_list with
| [] -> Misc.internal_error "Empty power list" 0
| pow :: pow_list -> make_matrix (Misc.repeat_list (static_exp param_env see)) pow_list
in
@ -157,7 +157,7 @@ and boxed_ty param_env t = match t with
| Types.Tid t when t = Initial.pfloat -> Tclass (Names.local_qn "Float")
| Types.Tid t -> Tclass (qualname_to_class_name t)
| Types.Tarray (t,size) -> Tarray (ty param_env t, static_exp param_env size)
| Types.Tinvalid -> Misc.internal_error "obc2java invalid type" 1
| Types.Tinvalid -> Misc.internal_error "obc2java invalid type"
and tuple_ty param_env ty_l =
let ln = ty_l |> List.length |> Pervasives.string_of_int in
@ -171,7 +171,7 @@ and ty param_env t :Java.ty = match t with
| Types.Tid t when t = Initial.pfloat -> Tfloat
| Types.Tid t -> Tclass (qualname_to_class_name t)
| Types.Tarray (t,size) -> Tarray (ty param_env t, static_exp param_env size)
| Types.Tinvalid -> Misc.internal_error "obc2java invalid type" 1
| Types.Tinvalid -> Misc.internal_error "obc2java invalid type"
and var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident }
@ -420,8 +420,8 @@ let type_dec_list classes td_l =
let classe_name = qualname_to_package_classe td.t_name in
Idents.enter_node classe_name;
match td.t_desc with
| Type_abs -> Misc.unsupported "obc2java, abstract type." 1
| Type_alias _ -> Misc.unsupported "obc2java, type alias." 2
| Type_abs -> Misc.unsupported "obc2java, abstract type."
| Type_alias _ -> Misc.unsupported "obc2java, type alias."
| Type_enum c_l ->
let mk_constr_enum c = translate_constructor_name_2 c td.t_name in
(mk_enum (List.map mk_constr_enum c_l) classe_name) :: classes

98
compiler/obc/ml/caml.ml
View file

@ -1,98 +0,0 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(** Sequential caml code. *)
open Misc
open Names
open Idents
open Location
type caml_code =
{ c_types: (string, type_definition) Hashtbl.t;
c_defs: (string * cexp) list;
}
and immediate =
Cbool of bool
| Cint of int
| Cfloat of float
| Cchar of char
| Cstring of string
| Cvoid
and cexp =
Cconstant of immediate
| Cglobal of qualified_ident
| Cvar of string
| Cconstruct of qualified_ident * cexp list
| Capply of cexp * cexp list
| Cfun of pattern list * cexp
| Cletin of is_rec * (pattern * cexp) list * cexp
| Cifthenelse of cexp * cexp * cexp
| Cifthen of cexp * cexp
| Cmatch of cexp * (pattern * cexp) list
| Ctuple of cexp list
| Crecord of (qualified_ident * cexp) list
| Crecord_access of cexp * qualified_ident
| Cseq of cexp list
| Cderef of cexp
| Cref of cexp
| Cset of string * cexp
| Clabelset of string * string * cexp
| Cmagic of cexp
and is_rec = bool
and pattern =
Cconstantpat of immediate
| Cvarpat of string
| Cconstructpat of qualified_ident * pattern list
| Ctuplepat of pattern list
| Crecordpat of (qualified_ident * pattern) list
| Corpat of pattern * pattern
| Caliaspat of pattern * string
| Cwildpat
let cvoidpat = Cconstantpat(Cvoid)
let cvoid = Cconstant(Cvoid)
let crefvoid = Cref(cvoid)
let cfalse = Cconstant(Cbool(false))
let ctrue = Cconstant(Cbool(true))
let creftrue = Cref(ctrue)
let cdummy = Cmagic (Cconstant (Cvoid))
let cand_op = {qual = pervasives_module;id = "&&"}
let cor_op = {qual = pervasives_module;id = "or"}
let cnot_op = {qual = pervasives_module;id = "not"}
let cand c1 c2 = Capply (Cglobal (cand_op), [c1;c2])
let cor c1 c2 = Capply (Cglobal (cor_op), [c1;c2])
let cnot c = Capply(Cglobal (cnot_op),[c])
let cvoidfun e = Cfun([cvoidpat], e)
let cvoidapply e = Capply(e, [cvoid])
let cfun params e =
match params, e with
| params, Cfun(others, e) -> Cfun(params @ others, e)
| [], _ -> cvoidfun e
| _ -> Cfun(params, e)
let capply e l = match l with [] -> cvoidapply e | _ -> Capply(e, l)
let cifthen c e = match c with Cconstant(Cbool(true)) -> e | _ -> Cifthen(c, e)
let cifthenelse c e1 e2 =
match c with
| Cconstant(Cbool(true)) -> e1
| Cconstant(Cbool(false)) -> e2
| _ -> Cifthenelse(c, e1, e2)
let cseq e1 e2 =
match e1, e2 with
| Cconstant(Cvoid), _ -> e2
| _, Cconstant(Cvoid) -> e1
| e1, Cseq l2 -> Cseq(e1 :: l2)
| Cseq(l1), e2 -> Cseq (l1 @ [e2])
| _ -> Cseq[e1;e2]

131
compiler/obc/ml/caml_aux.ml
View file

@ -1,131 +0,0 @@
(**************************************************************************)
(* *)
(* Lucid Synchrone *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* $Id: caml_aux.ml,v 1.1.1.1 2005-11-03 15:45:23 pouzet Exp $ *)
(* file caml-aux.ml *)
(* auxiliary functions for caml expressions *)
(* free variables *)
open Misc;;
open Caml;;
open Declarative;;
(* convertions from declarative structures to caml ones *)
(* immediates *)
let caml_of_declarative_immediate = function
| Dbool b -> if b then Ftrue else Ffalse
| Dint i -> Fint i
| Dfloat f -> Ffloat f
| Dchar c -> Fchar c
| Dstring s -> Fstring s
(* globals *)
let string_of_global g =
let pref = g.dqualid.dqual in
(if (pref <> "") && (pref <> "Lucy_pervasives") then
g.dqualid.dqual^"."
else "") ^ g.dqualid.did
(* pat_desc *)
let rec caml_pattern_of_pat_desc = function
| Dvarpat i -> Fvarpat ("x__"^(string_of_int i))
| Dconstantpat i -> Fimpat (caml_of_declarative_immediate i)
| Dtuplepat pl -> Ftuplepat (List.map caml_of_declarative_pattern pl)
| Dconstruct0pat g -> Fconstruct0pat (string_of_global g)
| Dconstruct1pat (g,p) -> Fconstruct1pat (string_of_global g,
caml_of_declarative_pattern p)
| Drecordpat gpl -> Frecordpat (List.map
(fun (x,y) ->
(string_of_global x,
caml_of_declarative_pattern y))
gpl)
(* patterns *)
and caml_of_declarative_pattern p = caml_pattern_of_pat_desc p.dp_desc
(* ---- end of convertions *)
let rec flat_exp_of_pattern = function
| Fpunit -> Fim Funit
| Fimpat i -> Fim i
| Fvarpat v -> Fvar { cvar_name=v; cvar_imported=false }
| Fconstruct0pat c -> Fconstruct0 c
| Fconstruct1pat (c,p) -> Fconstruct1 (c, flat_exp_of_pattern p)
| Ftuplepat pl -> Ftuple (List.map flat_exp_of_pattern pl)
| Frecordpat cpl ->
Frecord (List.map (fun (x,y) -> (x,flat_exp_of_pattern y)) cpl)
(* small functions manipulating lists *)
let union x1 x2 =
let rec rec_union l = function
[] -> l
| h::t -> if List.mem h l then (rec_union l t) else (rec_union (h::l) t)
in
rec_union x1 x2
let subtract x1 x2 =
let rec sub l = function
[] -> l
| h::t -> if List.mem h x2 then (sub l t) else (sub (h::l) t)
in
sub [] x1
let flat l =
let rec f ac = function
[] -> ac
| t::q -> f (ac@t) q
in
f [] l
let intersect x1 x2 =
let rec inter l = function
[] -> l
| h::t -> if List.mem h x1 then (inter (h::l) t) else (inter l t)
in
inter [] x2
(* make a variable *)
let make_var n = Fvar {cvar_name = n;cvar_imported = false}
and make_imported_var n b = Fvar {cvar_name = n;cvar_imported = b}
let nil_ident = "Lucy__nil"
let state_ident = "Lucy__state"
(* makes a conditional *)
let ifthenelse(c,e1,e2) =
match c with
Fim(Ftrue) -> e1
| Fim(Ffalse) -> e2
| _ -> Fifthenelse(c,e1,e2)
(* makes a list of conditionnals *)
let ifseq l =
let rec ifs l =
let (c,e)::t = l in
if t = [] then
e
else
ifthenelse (c, e, ifs t)
in
ifs l

404
compiler/obc/ml/caml_printer.ml
View file

@ -1,404 +0,0 @@
(**************************************************************************)
(* *)
(* Lucid Synchrone *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* $Id: caml_printer.ml,v 1.20 2008-06-17 13:21:12 pouzet Exp $ *)
(** Printing [Caml] code *)
open Misc
open Names
open Format
open Declarative
open Declarative_printer
open Caml
(** Generic printing of a list.
This function seems to appear in several places... *)
let print_list print print_sep l =
let rec printrec l =
match l with
[] -> ()
| [x] ->
print x
| x::l ->
open_box 0;
print x;
print_sep ();
print_space ();
printrec l;
close_box () in
printrec l
(** Prints an immediate. A patch is needed on float number for
[ocaml] < 3.05. *)
let print_immediate i =
match i with
Cbool(b) -> print_string (if b then "true" else "false")
| Cint(i) -> print_int i
| Cfloat(f) -> print_float f
| Cchar(c) -> print_char '\''; print_char c; print_char '\''
| Cstring(s) -> print_string "\"";
print_string (String.escaped s);
print_string "\""
| Cvoid -> print_string "()"
(** Prints a name. Infix chars are surrounded by parenthesis *)
let is_infix =
let module StrSet = Set.Make(String) in
let set_infix =
List.fold_right
StrSet.add
["or"; "quo"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]
StrSet.empty in
fun s -> StrSet.mem s set_infix
let print_name s =
let c = String.get s 0 in
let s = if is_infix s then "(" ^ s ^ ")"
else match c with
| 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> s
| '*' -> "( " ^ s ^ " )"
| _ -> if s = "()" then s else "(" ^ s ^ ")" in
print_string s
(** Prints a global name *)
let print_qualified_ident {qual=q;id=n} =
(* special case for values imported from the standard library *)
if (q = pervasives_module) or (q = Modules.compiled_module_name ())
or (q = "")
then print_name n
else
begin
print_string q;
print_string ".";
print_name n
end
let priority exp =
match exp with
Crecord _ | Crecord_access _ | Cvar _ | Ctuple _
| Cglobal _ | Cconstant _ | Cconstruct(_, []) | Cderef _ -> 3
| Clet _ | Cfun _ | Cseq _ -> 1
| Cset _ | Clabelset _
| Cref _ | Capply _ | Cmagic _ | Cconstruct _ -> 2
| Cifthen _ | Cifthenelse _ | Cmatch _ -> 0
let priority_pattern p =
match p with
Cconstructpat _ | Cconstantpat _ | Cvarpat _
| Ctuplepat _ | Crecordpat _ -> 2
| _ -> 1
(** Emission of code *)
let rec print pri e =
open_box 2;
(* if the priority of the context is higher than the *)
(* priority of e, we ass a parenthesis *)
let pri_e = priority e in
if pri > pri_e then print_string "(";
begin match e with
Cconstant(e) -> print_immediate e
| Cglobal(gl) -> print_qualified_ident gl
| Cvar(s) -> print_name s
| Cconstruct(gl, e_list) ->
print_qualified_ident gl;
if e_list <> [] then print_tuple e_list
| Capply(f,l) ->
print pri_e f;
print_space ();
print_list (print (pri_e + 1)) (fun () -> ()) l
| Cfun(pat_list,e) ->
print_string "fun";
print_space ();
print_list (print_pattern 0) (fun () -> ()) pat_list;
print_space ();
print_string "->";
print_space ();
print 0 e
(* local definition *)
| Clet(is_rec, l, e) -> print_let is_rec l e
| Cifthenelse(e1,e2,e3) ->
print_string "if";
print_space ();
print (pri_e - 1) e1;
print_space ();
print_string "then";
print_space ();
print 2 e2;
print_space ();
print_string "else";
print_space ();
print 2 e3
| Cifthen(e1,e2) ->
print_string "if";
print_space ();
print (pri_e - 1) e1;
print_space ();
print_string "then";
print_space ();
print 2 e2
| Ctuple(l) -> print_tuple l
| Crecord(l) ->
print_string "{";
print_list
(fun (gl, e) -> print_qualified_ident gl;
print_string " = ";
print 1 e)
(fun () -> print_string ";") l;
print_string "}"
| Crecord_access(e, gl) ->
print pri_e e;
print_string ".";
print_qualified_ident gl
| Cmatch(e,l) ->
print_string "match ";
print 0 e;
print_string " with";
print_space ();
List.iter
(fun pat_expr ->
print_string "| ";
print_match_pat_expr 2 pat_expr) l
| Cseq l -> print_list (print 2) (fun () -> print_string ";") l
| Cderef(e) ->
print_string "!";
print pri_e e
| Cref(e) ->
print_string "ref";
print_space ();
print (pri_e + 1) e
| Cset(s, e) ->
print_string s;
print_string " :=";
print_space ();
print pri_e e
| Clabelset(s, l, e) ->
print_string s;
print_string ".";
print_string l;
print_space ();
print_string "<-";
print_space ();
print pri_e e
| Cmagic(e) ->
print_string "Obj.magic";
print_space ();
print (pri_e+1) e
end;
if pri > pri_e then print_string ")";
close_box()
and print_tuple e_list =
print_string "(";
print_list (print 2) (fun () -> print_string ",") e_list;
print_string ")"
and print_let_pat_expr (pat, expr) =
match pat, expr with
pat, Cfun(pat_list, expr) ->
open_box 2;
print_list (print_pattern 0) (fun () -> ()) (pat :: pat_list);
print_string " =";
print_space ();
print 0 expr;
close_box ()
| _ ->
print_pattern 0 pat;
print_string " = ";
print 0 expr
and print_let is_rec l e =
open_box 0;
if is_rec then print_string "let rec " else print_string "let ";
print_list print_let_pat_expr
(fun () -> print_string "\n"; print_string "and ") l;
print_string " in";
print_break 1 0;
print 0 e;
close_box ()
and print_pattern pri pat =
open_box 2;
let pri_e = priority_pattern pat in
if pri > pri_e then print_string "(";
begin match pat with
Cconstantpat(i) -> print_immediate i
| Cvarpat(v) -> print_string v
| Cconstructpat(gl, pat_list) ->
print_qualified_ident gl;
if pat_list <> [] then print_tuple_pat pat_list
| Ctuplepat(pat_list) ->
print_tuple_pat pat_list
| Crecordpat(l) ->
print_string "{";
print_list (fun (gl, pat) -> print_qualified_ident gl;
print_string "=";
print_pattern (pri_e - 1) pat)
(fun () -> print_string ";") l;
print_string "}"
| Corpat(pat1, pat2) ->
print_pattern pri_e pat1;
print_string "|";
print_pattern pri_e pat2
| Caliaspat(pat, s) ->
print_pattern pri_e pat;
print_space ();
print_string "as";
print_space ();
print_string s
| Cwildpat -> print_string "_"
end;
if pri > pri_e then print_string ")";
close_box ()
and print_tuple_pat pat_list =
print_string "(";
print_list (print_pattern 0) (fun () -> print_string ",") pat_list;
print_string ")"
and print_match_pat_expr prio (pat, expr) =
open_box 2;
print_pattern 0 pat;
print_space (); print_string "->"; print_space ();
print prio expr;
close_box ();
print_space ();;
(* print a definition *)
let print_definition (name, e) =
print_string "let ";
print_let_pat_expr (Cvarpat(name), e)
(* print code *)
let print_code e = print 0 e
(* print types *)
let rec print_type typ =
open_box 1;
begin match typ with
Darrow(is_node, typ1, typ2) ->
print_type typ1;
if is_node then print_string " => " else print_string " -> ";
print_type typ2
| Dproduct(ty_list) ->
print_list print_type (fun _ -> print_string " *") ty_list
| Dconstr(qual_ident, ty_list) ->
if ty_list <> [] then
begin
print_string "(";
print_list print_type (fun _ -> print_string ",") ty_list;
print_string ")";
print_space ()
end;
print_qualified_ident qual_ident
| Dtypvar(i) -> print_type_name i
| Dbase(b) -> print_base_type b
| Dsignal(ty) -> print_type ty; print_space (); print_string "sig"
end;
close_box ()
and print_type_name n =
print_string "'a";
print_int n
and print_base_type b =
match b with
Dtyp_bool -> print_string "bool"
| Dtyp_int -> print_string "int"
| Dtyp_float -> print_string "float"
| Dtyp_unit -> print_string "unit"
| Dtyp_string -> print_string "string"
| Dtyp_char -> print_string "char"
(* print variant *)
let print_variant (qualid, { arg = typ_list; res = typ }) =
print_string " | ";
print_qualified_ident qualid;
match typ_list with
[] -> (* arity = 0 *)
()
| _ -> print_string " of ";
print_list print_type (fun () -> print_string "*") typ_list
let print_record (qualid, is_mutable, { res = typ1 }) =
if is_mutable then print_string "mutable ";
print_qualified_ident qualid;
print_string ":";
print_type typ1;
print_string ";"
let print_type_declaration s { d_type_desc = td; d_type_arity = l } =
open_box 2;
if l <> [] then
begin
print_string "(";
print_list print_type_name (fun _ -> print_string ",") l;
print_string ")";
print_space ()
end;
print_string s;
print_string " = ";
begin match td with
Dabstract_type -> ()
| Dabbrev(ty) ->
print_type ty
| Dvariant_type variant_list ->
List.iter print_variant variant_list
| Drecord_type record_list ->
print_string "{";
print_list print_record (fun _ -> ()) record_list;
print_string "}"
end;
print_newline ();
close_box ()
let print_type_declarations l =
let rec printrec l =
match l with
[] -> ()
| [s, d] -> print_type_declaration s d
| (s, d) :: l ->
print_type_declaration s d;
print_string "and ";
printrec l in
open_box 0;
print_string "type ";
printrec l;
print_newline ();
close_box ();;
(* the main function *)
set_max_boxes max_int ;;
let output_expr oc e =
(* emit on channel oc *)
set_formatter_out_channel oc;
print 0 e;
print_flush ()
let output_code oc c =
(* emit on channel oc *)
set_formatter_out_channel oc;
print_code c
let output_definitions oc d_list =
(* emit on channel oc *)
set_formatter_out_channel oc;
print_list print_definition print_newline d_list;
print_flush ()
let output oc caml_code =
set_formatter_out_channel oc;
(* print type declarations *)
let l = Misc.listoftable caml_code.c_types in
if l <> [] then print_type_declarations l;
(* print value definitions *)
print_list print_definition print_newline caml_code.c_code;
print_flush ()

46
compiler/obc/ml/cenvironment.ml
View file

@ -1,46 +0,0 @@
(**************************************************************************)
(* *)
(* Lucid Synchrone *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* $Id: cenvironment.ml,v 1.1 2006-03-18 08:04:25 pouzet Exp $ *)
open Misc
open Declarative
(** Environment with static link **)
type cblock =
{ c_block: block; (* table of free names *)
c_state: name; (* the name of the internal state *)
c_write: name; (* temporary values *)
}
type env = cblock list
let empty_env = []
let current env = List.hd env
let cblock env = (current env).c_block
let statename env = (current env).c_state
let push_block block env =
{ c_block = block;
c_state = symbol#name;
c_write = symbol#name } :: env
let push block env =
if env = empty_env
then push_block block env
else let cblock = current env in
{ cblock with c_block = block } :: env
let rec findall env i =
match env with
[] -> raise Not_found
| { c_block = b; c_state = st; c_write = wt } :: env ->
try
Hashtbl.find b.b_env i, st, wt
with
Not_found -> findall env i
let find env i =
let id, _, _ = findall env i in
id

848
compiler/obc/ml/coiteration.ml
View file

@ -1,848 +0,0 @@
(**************************************************************************)
(* *)
(* Lucid Synchrone *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* $Id: coiteration.ml,v 1.27 2008-06-10 06:54:36 delaval Exp $ *)
(** Translating [declarative] code into sequential [caml] code. *)
open Misc
open Names
open Declarative
open Rw
open Dmisc
open Caml
open Cenvironment
let prefix_for_names = "_"
let prefix_for_inits = "_init"
let prefix_for_memos = "_pre"
let prefix_for_statics = "_static"
let prefix_for_clocks = "_cl"
let prefix_for_lasts = "__last"
let prefix_state_type = "_state_"
let prefix_state_constr = "`St_"
let prefix_state_label = "_mem_"
let prefix_state_constr_nil = "`Snil_"
let prefix_for_self_state = "_self_"
let prefix_for_temp = "_temp_"
(** the type of unknown states *)
(* type 'a state = Snil | St of 'a *)
let state_nil = Cconstruct(qualid prefix_state_constr_nil, [])
let state_nil_pat = Cconstructpat(qualid prefix_state_constr_nil, [])
let state_pat pat_list = Cconstructpat(qualid prefix_state_constr, pat_list)
let state e_list = Cconstruct(qualid prefix_state_constr, e_list)
let state_record name_e_list =
Crecord(List.map (fun (name, e) -> (qualid name), e) name_e_list)
let intro_state_type () =
let tname = prefix_state_type in
let result_type =
Dconstr(qualid prefix_state_type, [Dtypvar(0)]) in
let variants =
[(qualid prefix_state_constr_nil, { arg = []; res = result_type });
(qualid prefix_state_constr, {arg = [Dtypvar(0)]; res = result_type})]
in
let type_def =
{ d_type_desc = Dvariant_type(variants);
d_type_arity = [0] } in
add_type (tname, type_def)
(** introduce a new type for enumerated states *)
(* type ('a1,...,'an) state_k = St1 of 'a1 | ... Stm of 'an *)
let intro_enum_type n =
let l = Misc.from n in
(* name of the result type *)
let tname = prefix_state_type ^ (string_of_int(symbol#name)) in
let result_type =
Dconstr(qualid tname, List.map (fun name -> Dtypvar(name)) l) in
let variants =
List.map
(fun name ->
(qualid (tname ^ prefix_state_constr ^ (string_of_int name)),
{ arg = [Dtypvar(name)]; res = result_type })) l in
let type_def =
{ d_type_desc = Dvariant_type(variants);
d_type_arity = l } in
add_type (tname, type_def);
tname ^ prefix_state_constr
(** introduce a new type for record states *)
(* type ('a1,...,'an) state_k = {mutable name1:a1;...;mutable namen:an} *)
let intro_record_type name_value_list =
let l = Misc.from (List.length name_value_list) in
let tname = prefix_state_type ^ (string_of_int(symbol#name)) in
let result_type =
Dconstr(qualid tname, List.map (fun name -> Dtypvar(name)) l) in
let labels =
List.map2
(fun (name,_) ai ->
(qualid name,
true,
{ res = Dtypvar(ai); arg = result_type })) name_value_list l in
let type_def =
{ d_type_desc = Drecord_type(labels);
d_type_arity = l } in
add_type (tname, type_def)
(** the intermediate code generated during the compilation process *)
type tcode =
Tlet of pattern * cexp
| Tset of string * cexp
| Tlabelset of string * string * cexp
| Tletrec of (pattern * cexp) list
| Texp of cexp
(* and its translation into caml code *)
let rec clet tcode ce =
let code2c tcode ce =
match tcode with
Tlet(p, c) -> Clet(false, [p,c], ce)
| Tset(s, e) -> cseq (Cset(s,e)) ce
| Tlabelset(s, n, e) -> cseq (Clabelset(s, n, e)) ce
| Tletrec(l) -> Clet(true, l, ce)
| Texp(c) when ce = cvoid -> c
| Texp(c) -> cseq c ce in
match tcode with
[] -> ce
| tc :: tcode -> code2c tc (clet tcode ce)
let cseq tcode = clet tcode cvoid
let ifthen c ce =
match c with
Cconstant(Cbool(true)) -> ce
| _ -> Cifthen(c, ce)
let merge code ce l =
(* we make special treatments for conditionals *)
match l with
[] -> code
| [Cconstantpat(Cbool(b1)), c1;
Cconstantpat(Cbool(b2)), c2] ->
if b1 then
Texp(Cifthenelse(ce, c1, c2)) :: code
else
Texp(Cifthenelse(ce, c2, c1)) :: code
(* general case *)
| _ -> Texp(Cmatch(ce, l)) :: code
(** extract the set of static computations from an expression *)
let rec static acc e =
let acc, desc = match e.d_desc with
| Dconstant _ | Dvar _ | Dfun _ -> acc, e.d_desc
| Dtuple l ->
let acc, l = static_list acc l in
acc, Dtuple(l)
| Dprim(g, e_list) ->
(* pointwise application *)
let acc, e_list = static_list acc e_list in
acc, Dprim(g, e_list)
| Dconstruct(g, e_list) ->
let acc, e_list = static_list acc e_list in
acc, Dconstruct(g, e_list)
| Drecord(gl_expr_list) ->
let static_record (gl, expr) (acc, gl_expr_list) =
let acc, e = static acc expr in
acc, (gl, e) :: gl_expr_list in
let acc, l =
List.fold_right static_record gl_expr_list (acc, []) in
acc, Drecord(l)
| Drecord_access(expr, gl) ->
let acc, e = static acc expr in
acc, Drecord_access(e, gl)
| Difthenelse(e0, e1, e2) ->
let acc, e0 = static acc e0 in
let acc, e1 = static acc e1 in
let acc, e2 = static acc e2 in
acc, Difthenelse(e0, e1, e2)
| Dlet(block, e_let) ->
let acc, block = static_block acc block in
let acc, e = static acc e_let in
acc, Dlet(block, e_let)
| Dapply(is_state, f, l) ->
let acc, f = static acc f in
let acc, l = static_list acc l in
acc, Dapply(is_state, f, l)
| Deseq(e1, e2) ->
let acc, e1 = static acc e1 in
let acc, e2 = static acc e2 in
acc, Deseq(e1, e2)
| Dwhen(e1) ->
let acc, e1 = static acc e1 in
acc, Dwhen(e1)
| Dclock(ck) ->
acc, Dclock(ck)
| Dlast _ | Dinit _ | Dpre _ | Dtest _ ->
(* this case should not arrive *)
fatal_error "static" in
acc, { e with d_desc = desc }
and static_list acc l =
match l with
[] -> acc, []
| e :: l ->
let acc, e = static acc e in
let acc, l = static_list acc l in
acc, e :: l
and static_block acc b =
let acc, eq = static_eq acc b.b_equations in
acc, { b with b_equations = eq }
(* extract the set of static computations from an equation *)
and static_eqs acc eq_list =
match eq_list with
[] -> acc, []
| eq :: eq_list ->
let acc, eq = static_eq acc eq in
let acc, eq_list = static_eqs acc eq_list in
acc, dcons eq eq_list
and static_eq acc eq =
match eq with
Dget _ -> acc, eq
| Dequation(pat, e) ->
let acc, e = static acc e in
acc, Dequation(pat, e)
| Dwheneq(eq, ck) ->
let acc, eq = static_eq acc eq in
acc, Dwheneq(eq, ck)
| Dmerge(is_static, e, p_block_list) ->
let acc, e = static acc e in
let acc, p_block_list = static_pat_block_list acc p_block_list in
acc, Dmerge(is_static, e, p_block_list)
| Dnext(n, e) ->
let acc, e = static acc e in
acc, Dnext(n, e)
| Dseq(eq_list) ->
let acc, eq_list = static_eqs acc eq_list in
acc, Dseq(eq_list)
| Dpar(eq_list) ->
let acc, eq_list = static_eqs acc eq_list in
acc, Dpar(eq_list)
| Dblock(block) ->
let acc, block = static_block acc block in
acc, Dblock(block)
| Dstatic(pat, e) ->
(pat, e) :: acc, no_equation
| Demit _ | Dlasteq _ | Dautomaton _ | Dreset _ | Dpresent _ ->
(* these cases should not arrive since control structures have *)
(* been translated into the basic kernel *)
fatal_error "static_eq"
and static_pat_block_list acc p_block_list =
(* treat one handler *)
let static_pat_block acc (pat, block) =
let acc, block = static_block acc block in
acc, (pat, block) in
match p_block_list with
[] -> acc, []
| pat_block :: pat_block_list ->
let acc, pat_block = static_pat_block acc pat_block in
let acc, pat_block_list = static_pat_block_list acc pat_block_list in
acc, pat_block :: pat_block_list
(** Auxiliary definitions **)
let string_of_ident ident =
let prefix =
match ident.id_kind with
Kinit -> prefix_for_inits
| Kstatic -> prefix_for_statics
| Kmemo -> prefix_for_memos
| Kclock -> prefix_for_clocks
| Klast -> prefix_for_lasts
| _ -> prefix_for_names in
let suffix =
match ident.id_original with
None -> ""
| Some(n) when (is_an_infix_or_prefix_operator n) -> "__infix"
| Some(n) -> "__" ^ n in
prefix ^ (string_of_int ident.id_name) ^ suffix
let string_of_name env i =
(* find the original name when it exists *)
let ident = find env i in
string_of_ident ident
let name i = prefix_for_names ^ (string_of_int i)
let memo i = prefix_for_memos ^ (string_of_int i)
let initial i = prefix_for_inits ^ (string_of_int i)
let clock i = prefix_for_clocks ^ (string_of_int i)
let stat i = prefix_for_statics ^ (string_of_int i)
(* the name of the current state *)
let selfstate env = prefix_for_self_state ^ (string_of_int (statename env))
(* access to a write variable *)
let access_write wt s = Cderef (Cvar s)
(* makes an access to a name *)
let access env i =
let ident, st, wt = findall env i in
let s = string_of_ident ident in
match ident.id_kind with
Kinit | Kmemo | Kstatic ->
Crecord_access(Cvar(prefix_for_self_state ^ (string_of_int st)),
qualid s)
| _ ->
if is_a_write ident
then access_write wt s
else Cvar(s)
let set name c = Tset(name, c)
let next self name c = Tlabelset(self, name, c)
(** Compilation of functions *)
(* x1...xn.<init, code, res> is translated into
(1) combinatorial function
\x1...xn.code;res
(2) \x1...xn.self.
let self = match !self with
Nil -> let v = { ... init ... } in
self := St(v);v
| St(self) -> self in
code;
res
r = f [...] x1...xn is translated into:
(1) combinatorial function
f = f [...] x1...xn
(2) state function
st = ref Nil initialisation part
r = f x1...xn st step part
Rmk: we can also write: "if reset then self := { ... }"
*)
let co_apply env is_state (init_write, init_mem) f subst e_list =
if is_state then
(* state function *)
let st = prefix_for_names ^ (string_of_int symbol#name) in
let prefix = selfstate env in
(init_write, (st, Cref(state_nil)) :: init_mem),
Capply(f,
(subst @ e_list @ [Crecord_access(Cvar(prefix), qualid st)]))
else
(init_write, init_mem), Capply(f, subst @ e_list)
(* prepare the initialization of memory variables *)
let cmatchstate self states =
let v = prefix_for_names ^ (string_of_int (symbol#name)) in
let st = prefix_state_constr ^ (string_of_int (symbol#name)) in
Cmatch(Cderef(Cvar(self)),
[Cconstructpat(qualid st,[Cvarpat(self)]), Cvar(self);
Cwildpat, Clet(false, [Cvarpat(v), states],
Cseq[Cset(self,
Cconstruct(qualid st, [Cvar(v)]));
Cvar(v)])])
(* prepare the initialization of write variables *)
let define_init_writes env init_write code =
List.fold_right
(fun (name, e) code -> Clet(false, [Cvarpat(name), Cref e], code))
init_write code
let co_fun env
is_state params p_list static (init_write, init_mem) code result =
if init_mem <> [] then intro_record_type init_mem;
let code = clet code result in
let code =
if init_write <> []
then define_init_writes env init_write code
else code in
let self = selfstate env in
if is_state
then
if init_mem = [] then Cfun(params @ p_list @ [Cvarpat(self)], code)
else Cfun(params @ p_list @ [Cvarpat(self)],
Clet(false, [Cvarpat(self),
cmatchstate self
(clet static (state_record init_mem))],
code))
else Cfun(params @ p_list, code)
(** Compilation of pattern matching *)
(*
match e with
P1 -> e1
| ...
| Pn -> en
(1) e is a static computation
- initialisation code
let memory = match e with
P1 -> St1 { ... }
| ...
| Pn -> Stn { ... }
- step code
match memory with
St1{...} -> step1
| ...
| Stn{...} -> stepn
(2) e may evolve at every instant
- init code
...i1...
...in...
- match e with
P1 -> step1
| ...
| Pn -> stepn
for the moment, we treat case (1) as case (2) *)
(*
let co_static_merge e (pat, init_code_fvars_list) =
(* introduces the type definitions for the representation of states *)
let n = List.length init_code_fvars_list in
let prefix_constructor = intro_enum_type n in
(* builds a constructor value *)
let constructor prefix number f_vars =
Cconstruct(qualid (prefix ^ (string_of_int number)),
List.map (fun name -> Cvar(name)) fvars) in
let constructor_pat prefix number f_vars =
Cconstructpat(qualid (prefix ^ (string_of_int number)),
List.map (fun name -> Cvarpat(name)) fvars) in
(* computes the initialisation part *)
let rec states number init_code_fvars_list =
match init_code_fvars_list with
[] -> []
| (pat, init, _, fvars) :: init_code_fvars_list ->
let pat_code = (pat, clet init (constructor prefix number fvars)) in
let pat_code_list = states (number + 1) init_code_fvars_list in
pat_code :: code_list in
(* computes the transition part *)
let rec steps number init_code_fvars_list =
match init_code_fvars_list with
[] -> []
| (_, _, code, fvars) :: init_code_fvars_list ->
let pat_code = (constructor_pat prefix number fvars, code) in
let pat_code_list = steps (number + 1) init_code_fvars_list in
pat_code :: pat_code_list in
(* make the final code *)
let memory = symbol#name in
let init_code = Cmatch(e, states 0 init_code_fvars_list) in
let step_code = Cmatch(Cvar memory, steps 0 init_code_fvars_list) in
Tlet(memory, init_code), step_code
*)
(** Compilation of clocks *)
let rec translate_clock env init ck =
match ck with
Dfalse -> init, cfalse
| Dtrue -> init, ctrue
| Dclockvar(n) -> init, access env n
| Don(is_on, ck, car) ->
let init, ck = translate_clock env init ck in
let init, car = translate_carrier env init car in
init, if is_on then cand car ck
else cand (cnot car) ck
and translate_carrier env init car =
match car with
Dcfalse -> init, cfalse
| Dctrue -> init, ctrue
| Dcvar(n) -> init, access env n
| Dcglobal(g, res, ck) ->
(* a global clock allocates memory *)
(* and is compiled as a function call *)
let res = match res with None -> cfalse | Some(n) -> access env n in
let init, c = translate_clock env init ck in
let init, new_ce =
co_apply env true init (Cglobal g) [c] [res] in
init, new_ce
(** Compiling immediate. *)
let translate_immediate i =
match i with
| Dbool(b) -> Cbool(b)
| Dint(i) -> Cint(i)
| Dfloat(f) -> Cfloat(f)
| Dchar(c) -> Cchar(c)
| Dstring(s) -> Cstring(s)
| Dvoid -> Cvoid
(** Compiling variables. *)
let translate_var env v =
match v with
Dglobal(g) -> Cglobal(g)
| Dlocal(n) -> access env n
(** Compiling a pattern. *)
let rec translate_pat env pat =
match pat with
| Dconstantpat(i) -> Cconstantpat(translate_immediate(i))
| Dvarpat(s) -> Cvarpat(string_of_name env s)
| Dtuplepat(l) -> Ctuplepat(List.map (translate_pat env) l)
| Dconstructpat(gl, pat_list) ->
Cconstructpat(gl, List.map (translate_pat env) pat_list)
| Dorpat(pat1, pat2) -> Corpat(translate_pat env pat1,
translate_pat env pat2)
| Drecordpat(gl_pat_list) ->
Crecordpat
(List.map (fun (gl, pat) -> (gl, translate_pat env pat))
gl_pat_list)
| Daliaspat(pat, i) -> Caliaspat(translate_pat env pat,
string_of_name env i)
| Dwildpat -> Cwildpat
(*
(* add accesses to write variables defined in patterns *)
let rec add_write_access env code pat =
match pat with
Dconstantpat(i) -> code
| Dvarpat(s) when is_a_write (find env s) ->
Tset(string_of_name env s, access env s) :: code
| Dvarpat _ -> code
| Dtuplepat(l) | Dconstructpat(_, l) ->
List.fold_left (add_write_access env) code l
| Dorpat(pat1, pat2) ->
add_write_access env (add_write_access env code pat1) pat2
| Drecordpat(gl_pat_list) ->
List.fold_left (fun code (_, pat) -> add_write_access env code pat)
code gl_pat_list
| Daliaspat(pat, i) ->
add_write_access env (add_write_access env code pat) (Dvarpat(i))
| Dwildpat -> code
*)
(** Compiling an expression *)
(* takes an environment giving information about variables *)
(* and an expression and returns the new code *)
let rec translate env init e =
match e.d_desc with
| Dconstant(i) ->
let i = translate_immediate i in
init, Cconstant(i)
| Dvar(v, subst) ->
let v = translate_var env v in
let init, s = translate_subst env init subst in
let v = match s with [] -> v | l -> Capply(v, l) in
init, v
| Dtuple l ->
let init, lc = translate_list env init l in
init, Ctuple(lc)
| Dfun(is_state, params, p_list, body, result) ->
(* state function *)
let env = push_block body env in
(* compiles types and clock abstractions *)
let params = translate_forall env params in
(* compiles parameters *)
let p_list = List.map (translate_pat env) p_list in
(* remove static computation from the body *)
(* and put it in the allocation place for stateful functions *)
let (static_code, init_code, body, result) =
if is_state
then
let static_code, body = static_block [] body in
let static_code, result = static static_code result in
let static_code = List.rev static_code in
(* translate the static code *)
let static_code, init_code =
translate_static_code env static_code in
(static_code, init_code, body, result)
else
([], ([], []), body, result) in
(* then translate the body *)
let init_code, body = translate_block env init_code body in
let init_code, result = translate env init_code result in
init,
co_fun env is_state params p_list static_code init_code body result
| Dprim(g, e_list) ->
(* pointwise application *)
let init, ce_list = translate_list env init e_list in
init, Capply(Cglobal(g), ce_list)
| Dconstruct(g, e_list) ->
let init, ce_list = translate_list env init e_list in
init, Cconstruct(g, ce_list)
| Drecord(gl_expr_list) ->
let translate_record (gl, expr) (init, gl_expr_list) =
let init, ce = translate env init expr in
init, (gl, ce) :: gl_expr_list in
let init, l =
List.fold_right translate_record gl_expr_list (init, []) in
init, Crecord(l)
| Drecord_access(expr, gl) ->
let init, ce = translate env init expr in
init, Crecord_access(ce, gl)
| Difthenelse(e0, e1, e2) ->
let init, c0 = translate env init e0 in
let init, c1 = translate env init e1 in
let init, c2 = translate env init e2 in
init, Cifthenelse(c0, c1, c2)
| Dlet(block, e_let) ->
let env = push block env in
let init, code = translate_block env init block in
let init, ce = translate env init e_let in
init, clet code ce
| Dapply(is_state, { d_desc = Dvar(f, subst) }, l) ->
let f = translate_var env f in
let init, l = translate_list env init l in
let init, subst = translate_subst env init subst in
co_apply env is_state init f subst l
| Dapply(is_state, f, l) ->
let init, f = translate env init f in
let init, l = translate_list env init l in
co_apply env is_state init f [] l
| Deseq(e1, e2) ->
let init, e1 = translate env init e1 in
let init, e2 = translate env init e2 in
init, Cseq [e1; e2]
| Dwhen(e1) ->
translate env init e1
| Dclock(ck) ->
translate_clock env init ck
| Dlast _ | Dinit _ | Dpre _ | Dtest _ ->
(* this case should not arrive *)
fatal_error "translate"
and translate_list env init l =
match l with
[] -> init, []
| ce :: l ->
let init, ce = translate env init ce in
let init, l = translate_list env init l in
init, ce :: l
and translate_block env init b =
(* allocate the memory in the initialisation part *)
let init = allocate_memory env init in
(* compiles the body *)
let init, code = translate_equation env init [] b.b_equations in
(* sets code in the correct order *)
let code = List.rev code in
(* returns the components of the block *)
init, code
(* the input equations must be already scheduled *)
and translate_equations env init code eq_list =
match eq_list with
[] -> init, code
| eq :: eq_list ->
let init, code = translate_equation env init code eq in
translate_equations env init code eq_list
and translate_equation_into_exp env init eq =
let init, code = translate_equation env init [] eq in
(* sets code in the correct order *)
let code = List.rev code in
init, cseq code
and translate_block_into_exp env init block =
let init, code = translate_block env init block in
init, cseq code
and translate_equation env init code eq =
match eq with
Dget(pat, v) ->
let cpat = translate_pat env pat in
let n = translate_var env v in
init, Tlet(cpat, n) :: code
| Dequation(Dvarpat(n), e) when is_a_write (find env n) ->
let name = string_of_name env n in
let init, ce = translate env init e in
init, (set name ce) :: code
| Dequation(pat, e) | Dstatic(pat, e) ->
let is_rec = is_recursive pat e in
let pat = translate_pat env pat in
let init, ce = translate env init e in
init, if is_rec then Tletrec([pat, ce]) :: code
else Tlet(pat, ce) :: code
| Dwheneq(eq, ck) ->
let init, ce = translate_equation_into_exp env init eq in
let init, ck_ce = translate_clock env init ck in
init, Texp(ifthen ck_ce ce) :: code
| Dmerge(is_static, e, p_block_list) ->
let init, ce = translate env init e in
let init, l = translate_pat_block_list env init p_block_list in
init, merge code ce l
| Dnext(n, e) ->
(* n is either a memo or an initialisation variable *)
let init, ce = translate env init e in
init, (next (selfstate env) (string_of_name env n) ce) :: code
| Dseq(eq_list) | Dpar(eq_list) ->
translate_equations env init code eq_list
| Dblock(block) ->
translate_block env init block
| Demit _ | Dlasteq _ | Dautomaton _ | Dreset _ | Dpresent _ ->
(* these cases should not arrive since control structures have *)
(* been translated into the basic kernel *)
fatal_error "translate_equation"
(* compilation of pattern matching *)
and translate_pat_block_list env init p_block_list =
(* compile one handler *)
let translate_pat_block init (pat, block) =
let env = push block env in
let cpat = translate_pat env pat in
let init, ce = translate_block_into_exp env init block in
init, (cpat, ce) in
match p_block_list with
[] -> init, []
| pat_block :: pat_block_list ->
let init, pat_ce = translate_pat_block init pat_block in
let init, pat_ce_list =
translate_pat_block_list env init pat_block_list in
init, pat_ce :: pat_ce_list
(* translate a pure (stateless) expression *)
and translate_pure env e =
let init, ce = translate env ([], []) e in
assert (init = ([], []));
ce
(* computes extra parameters for clock abstraction *)
and translate_forall env params =
let p_clocks =
List.map (fun n -> Cvarpat(string_of_name env n)) params.s_clock in
let p_carriers =
List.map (fun n -> Cvarpat(string_of_name env n)) params.s_carrier in
p_clocks @ p_carriers
(* generates an application for clock instanciation *)
and translate_subst env init subst =
let rec translate_clock_list init cl_list =
match cl_list with
[] -> init, []
| cl :: cl_list ->
let init, cl = translate_clock env init cl in
let init, cl_list = translate_clock_list init cl_list in
init, cl :: cl_list in
let rec translate_carrier_list init car_list =
match car_list with
[] -> init, []
| car :: car_list ->
let init, car = translate_carrier env init car in
let init, car_list = translate_carrier_list init car_list in
init, car :: car_list in
let init, cl_list = translate_clock_list init subst.s_clock in
let init, car_list = translate_carrier_list init subst.s_carrier in
init, cl_list @ car_list
(* Initialisation code *)
and allocate_memory env init =
let allocate _ ident (acc_write, acc_mem) =
match ident.id_kind with
Kmemo ->
(* we allocate only one cell *)
let default = default_value env ident in
acc_write, (memo ident.id_name, default) :: acc_mem
| Kinit ->
(* init variables are considered to be state variables *)
acc_write, (initial ident.id_name, Cconstant(Cbool(true))) :: acc_mem
| _ when is_a_write ident ->
(* local write variables are allocated too *)
(* but they will be stored in a stack allocated structure *)
let name = string_of_name env ident.id_name in
let default = default_value env ident in
(name, default) :: acc_write, acc_mem
| _ -> acc_write, acc_mem in
Hashtbl.fold allocate (cblock env).b_env init
(* add static code into the initialisation part *)
and translate_static_code env static_code =
(* add one equation *)
(* we compute the list of introduced names and compile the equation *)
let translate_eq acc (pat, e) =
let acc = fv_pat acc pat in
let pat = translate_pat env pat in
let ce = translate_pure env e in
acc, Tlet(pat, ce) in
let rec translate_static_code acc static_code =
match static_code with
[] -> acc, []
| pat_e :: static_code ->
let acc, cpat_ce = translate_eq acc pat_e in
let acc, static_code = translate_static_code acc static_code in
acc, cpat_ce :: static_code in
(* introduced names must be added to the memory *)
let intro acc_mem n =
let v = string_of_name env n in
(* modify the kind of [n] *)
set_static (find env n);
(string_of_name env n, Cvar(v)) :: acc_mem in
(* first compile the static code *)
let acc, static_code = translate_static_code [] static_code in
(* introduced names must be added to the memory initialisation *)
let acc_mem = List.fold_left intro [] acc in
static_code, ([], acc_mem)
(* default value *)
and default_value env ident =
(* find a value from a type *)
let rec value ty =
match ty with
Dproduct(ty_l) -> Ctuple(List.map value ty_l)
| Dbase(b) ->
let v = match b with
Dtyp_bool -> Cbool(false)
| Dtyp_int -> Cint(0)
| Dtyp_float -> Cfloat(0.0)
| Dtyp_unit -> Cvoid
| Dtyp_char -> Cchar(' ')
| Dtyp_string -> Cstring("") in
Cconstant(v)
| Dsignal(ty) -> Ctuple[value ty; cfalse]
| Dtypvar _ | Darrow _ -> cdummy
| Dconstr(qualid, _) ->
try
let desc = find_type qualid in
match desc.d_type_desc with
Dabstract_type -> cdummy
| Dabbrev(ty) ->
value ty
| Dvariant_type l ->
let case = List.hd l in
begin match case with
(qual, { arg = ty_l }) ->
Cconstruct(qual, List.map value ty_l)
end
| Drecord_type l ->
let field_of_type (qual, _, ty_ty) = (qual, value ty_ty.res) in
Crecord (List.map field_of_type l)
with
Not_found -> cdummy in
let value (Dtypforall(_, ty)) = value ty in
match ident.id_value with
None -> value ident.id_typ
| Some(e) -> translate_pure env e
(** Compilation of a table of declarative code *)
let translate table =
let translate (s, e) = (s, translate_pure empty_env e) in
(* introduce the type of states *)
(* intro_state_type (); *)
(* then translate *)
(* translate the code *)
{ c_types = table.d_types;
c_code = List.map translate table.d_code;
c_vars = table.d_vars;
}

295
compiler/obc/ml/declarative.ml
View file

@ -1,295 +0,0 @@
(**************************************************************************)
(* *)
(* Lucid Synchrone *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* $Id: declarative.ml,v 1.18 2007-01-11 07:35:53 pouzet Exp $ *)
(* the intermediate format *)
open Misc
open Names
(* one set of (unique) names *)
type name = int
type global =
Gname of string * name
| Gmodname of qualified_ident
(* type definitions *)
type type_definition =
{ d_type_desc: type_components;
d_type_arity: int list
}
and ('a, 'b) ptyp = { arg: 'a; res: 'b }
and type_components =
Dabstract_type
| Dabbrev of typ
| Dvariant_type of (qualified_ident * (typ list, typ) ptyp) list
| Drecord_type of (qualified_ident * is_mutable * (typ, typ) ptyp) list
and is_mutable = bool
(* types *)
and typs = Dtypforall of name list * typ
and typ =
| Darrow of is_node * typ * typ
| Dproduct of typ list
| Dconstr of qualified_ident * typ list
| Dtypvar of name
| Dbase of base_typ
| Dsignal of typ
and is_node = bool
and base_typ =
Dtyp_bool | Dtyp_int | Dtyp_float | Dtyp_unit |
Dtyp_char | Dtyp_string
type guard = clock
and clock =
| Dfalse (* the false clock *)
| Dtrue (* the base clock *)
| Don of bool * clock * carrier (* "cl on c" or "cl on not c" *)
| Dclockvar of name (* 'a *)
and carrier =
Dcfalse
| Dctrue
| Dcvar of name
| Dcglobal of qualified_ident * name option * clock
(* identifier, reset name and clock *)
(* immediate values *)
type immediate =
| Dbool of bool
| Dint of int
| Dfloat of float
| Dchar of char
| Dstring of string
| Dvoid
type 'a desc =
{ d_desc: 'a;
d_ty: typ;
d_guard: guard
}
(* patterns *)
type pattern =
| Dwildpat
| Dvarpat of name
| Dconstantpat of immediate
| Dtuplepat of pattern list
| Dconstructpat of qualified_ident * pattern list
| Drecordpat of (qualified_ident * pattern) list
| Daliaspat of pattern * name
| Dorpat of pattern * pattern
(* signal expressions *)
type spattern =
| Dandpat of spattern * spattern
| Dexppat of expr
| Dcondpat of expr * pattern
(* expressions *)
and expr = expr_desc desc
and expr_desc =
| Dconstant of immediate
| Dvar of var * subst
| Dlast of name
| Dpre of expr option * expr
| Difthenelse of expr * expr * expr
| Dinit of clock * name option
| Dtuple of expr list
| Dconstruct of qualified_ident * expr list
| Drecord of (qualified_ident * expr) list
| Drecord_access of expr * qualified_ident
| Dprim of qualified_ident * expr list
| Dfun of is_state * params * pattern list * block * expr
| Dapply of is_state * expr * expr list
| Dlet of block * expr
| Deseq of expr * expr
| Dtest of expr (* testing the presence "?" *)
| Dwhen of expr (* instruction "when" *)
| Dclock of clock
and is_state = bool
and var =
| Dlocal of name
| Dglobal of qualified_ident
and is_external = bool (* true for imported ML values *)
(* type and clock instance *)
and ('a, 'b, 'c) substitution =
{ s_typ: 'a list;
s_clock: 'b list;
s_carrier: 'c list }
and subst = (typ, clock, carrier) substitution
and params = (name, name, name) substitution
(* block *)
and block =
{ b_env: (name, ident) Hashtbl.t; (* environment *)
mutable b_write: name list; (* write variables *)
b_equations: equation; (* equations *)
}
(* equation *)
and equation =
Dequation of pattern * expr (* equation p = e *)
| Dnext of name * expr (* next x = e *)
| Dlasteq of name * expr (* last x = e *)
| Demit of pattern * expr (* emit pat = e *)
| Dstatic of pattern * expr (* static pat = e *)
| Dget of pattern * var (* pat = x *)
| Dwheneq of equation * guard (* eq when clk *)
| Dmerge of is_static * expr (* control structure *)
* (pattern * block) list
| Dreset of equation * expr (* reset *)
| Dautomaton of clock * (state_pat * block * block * escape * escape) list
(* automaton weak and strong *)
| Dpar of equation list (* parallel equations *)
| Dseq of equation list (* sequential equations *)
| Dblock of block (* block structure *)
| Dpresent of clock * (spattern * block) list * block
(* presence testing *)
and escape = (spattern * block * is_continue * state) list
and is_static = bool
and is_strong = bool
and is_continue = bool
and state_pat = string * pattern list
and state = string * expr list
(* ident definition *)
and ident =
{ id_name: name; (* its name (unique identifier) *)
id_original: string option; (* its original name when possible *)
id_typ: typs; (* its type *)
id_value: expr option; (* its initial value when possible *)
mutable id_kind: id_kind; (* kind of identifier *)
mutable id_write: bool; (* physically assigned or not *)
mutable id_last: bool; (* do we need its last value also? *)
mutable id_signal: bool; (* is-it a signal? *)
}
(* a local variable in a block may be of four different kinds *)
and id_kind =
Kinit (* initialisation state variable *)
| Kclock (* clock variable *)
| Kreset (* reset variable *)
| Kmemo (* state variable *)
| Kstatic (* static variable *)
| Klast (* last variable *)
| Kvalue (* defined variable *)
| Kshared (* shared variable with several definitions *)
| Kinput (* input variable, i.e, argument *)
(* global definition *)
(* Invariant: expr must be bounded and static *)
(* the declarative code associated to a file *)
type declarative_code =
{ mutable d_modname: string; (* module name *)
mutable d_types: (string, type_definition) Hashtbl.t;
(* type definitions *)
mutable d_code: (string * expr) list; (* value definitions *)
mutable d_vars: string list; (* defined names *)
}
(* the generated code of a module *)
let dc = { d_modname = "";
d_types = Hashtbl.create 7;
d_code = [];
d_vars = []
}
let code () = dc
(* thing to do when starting the production of declarative code *)
(* for a file *)
let start modname =
dc.d_modname <- modname;
dc.d_types <- Hashtbl.create 7;
dc.d_code <- [];
dc.d_vars <- []
(* things to do at the end of the front-end*)
let finish () =
dc.d_code <- List.rev dc.d_code
(* apply a function to every value *)
let replace translate =
let rec replace (s, e) =
let e = translate e in
dc.d_code <- (s, e) :: dc.d_code in
let code = dc.d_code in
dc.d_code <- [];
List.iter replace code;
dc.d_code <- List.rev dc.d_code
(* add an input to the declarative code *)
let add_dec (name, code) =
dc.d_code <- (name, code) :: dc.d_code;
dc.d_vars <- name :: dc.d_vars
(* add a type definition to the declarative code *)
let add_type (name, type_def) =
Hashtbl.add dc.d_types name type_def
(* read code from and write code into a file *)
let read_declarative_code ic = input_value ic
let write_declarative_code oc =
output_value oc (code ())
(* the list of opened modules *)
let dc_modules = (Hashtbl.create 7 : (string, declarative_code) Hashtbl.t)
(* add a module to the list of opened modules *)
let add_module m =
let name = String.uncapitalize m in
try
let fullname = find_in_path (name ^ ".dcc") in
let ic = open_in fullname in
let dc = input_value ic in
Hashtbl.add dc_modules m dc;
close_in ic;
dc
with
Cannot_find_file _ ->
Printf.eprintf
"Cannot find the compiled declarative file %s.dcc.\n"
name;
raise Error
let find_value qualid =
let dc =
if qualid.qual = dc.d_modname then dc
else raise Not_found
(*
try
Hashtbl.find dc_modules qualid.qual
with
Not_found -> add_module qualid.qual *) in
List.assoc qualid.id dc.d_code
let find_type qualid =
if qualid.qual = dc.d_modname then Hashtbl.find dc.d_types qualid.qual
else raise Not_found

699
compiler/obc/ml/declarative_printer.ml
View file

@ -1,699 +0,0 @@
(**************************************************************************)
(* *)
(* Lucid Synchrone *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* $Id: declarative_printer.ml,v 1.13 2007-01-11 07:35:53 pouzet Exp $ *)
open Misc
open Names
open Declarative
open Modules
open Format
(* generic printing of a list *)
let print_list print l =
let rec printrec l =
match l with
[] -> ()
| [x] ->
print x
| x::l ->
print x;
print_space ();
printrec l in
printrec l
(* local name *)
let print_name i =
print_string "/";print_int i
(* global names *)
let print_qualified_ident { qual = q; id = id } =
if (q = pervasives_module) or (q = compiled_module_name ())
or (q = "")
then print_string id
else
begin
print_string q;
print_string ".";
print_string id
end
(* print types *)
let rec print_type typ =
open_box 1;
begin match typ with
Darrow(is_node, typ1, typ2) ->
print_string "(";
if is_node then print_string "=>" else print_string "->";
print_space ();
print_list print_type [typ1;typ2];
print_string ")"
| Dproduct(ty_list) ->
print_string "(";
print_string "*";
print_space ();
print_list print_type ty_list;
print_string ")"
| Dconstr(qual_ident, ty_list) ->
if ty_list <> [] then print_string "(";
print_qualified_ident qual_ident;
if ty_list <> [] then
begin print_space ();
print_list print_type ty_list;
print_string ")"
end
| Dsignal(ty) -> print_type ty; print_space (); print_string "sig"
| Dtypvar(i) -> print_int i
| Dbase(b) -> print_base_type b
end;
close_box ()
and print_base_type b =
match b with
Dtyp_bool -> print_string "bool"
| Dtyp_int -> print_string "int"
| Dtyp_float -> print_string "float"
| Dtyp_unit -> print_string "unit"
| Dtyp_string -> print_string "string"
| Dtyp_char -> print_string "char"
let print_typs (Dtypforall(l, typ)) =
match l with
[] -> (* we do not print the quantifier when there is no type variable *)
print_type typ
| l ->
open_box 1;
print_string "(forall";
print_space ();
print_list print_name l;
print_space ();
print_type typ;
print_string ")";
close_box ()
(* print clocks *)
let rec print_clock clk =
match clk with
| Dfalse -> print_string "false"
| Dtrue -> print_string "true"
| Dclockvar(i) -> print_name i
| Don(b, clk, c) ->
print_string "(";
if b then print_string "on" else print_string "onot";
print_space ();
print_clock clk;
print_space ();
print_carrier c;
print_string ")"
and print_carrier c =
match c with
Dcfalse -> print_string "false"
| Dctrue -> print_string "true"
| Dcvar(i) -> print_name i
| Dcglobal(qual_ident, res, clk) ->
print_qualified_ident qual_ident;
print_string "(";
(match res with
None -> ()
| Some(n) -> print_space ();print_name n;print_space ());
print_clock clk;
print_string ")"
(* immediate values *)
let print_immediate i =
match i with
Dbool(b) -> print_string (if b then "true" else "false")
| Dint(i) -> print_int i
| Dfloat(f) -> print_float f
| Dchar(c) -> print_char c
| Dstring(s) -> print_string s
| Dvoid -> print_string "()"
(* print patterns *)
let atom_pat pat =
match pat with
Dconstantpat _ | Dvarpat _ | Dwildpat -> true
| _ -> false
let rec print_pat pat =
open_box 1;
if not (atom_pat pat) then print_string "(";
begin match pat with
Dwildpat -> print_string "_"
| Dconstantpat(i) -> print_immediate i
| Dvarpat(i) -> print_name i
| Dconstructpat(qual_ident, pat_list) ->
print_string "constr";
print_space ();
print_qualified_ident qual_ident;
if pat_list <> [] then print_space ();
print_list print_pat pat_list
| Dtuplepat(pat_list) ->
print_string ",";
print_space ();
print_list print_pat pat_list
| Drecordpat(l) ->
print_string "record";
print_list
(fun (qual_ident, pat) ->
open_box 1;
print_string "(";
print_qualified_ident qual_ident;
print_space ();
print_pat pat;
print_string ")";
close_box ()) l
| Dorpat(pat1, pat2) ->
print_string "orpat";
print_space ();
print_list print_pat [pat1;pat2]
| Daliaspat(pat, i) ->
print_string "as";
print_space ();
print_pat pat;
print_space ();
print_int i
end;
if not (atom_pat pat) then print_string ")";
close_box ()
(* print statepat *)
let print_statepat (s, l) =
match l with
[] -> print_string s
| l -> print_string "(";
print_string s;
print_space ();
print_list print_pat l;
print_string ")"
(* print expressions *)
let atom e =
match e.d_desc with
Dconstant _ -> true
| _ -> false
(* print variables *)
let print_var v =
match v with
Dlocal(n) ->
print_string "local";
print_space ();
print_name n
| Dglobal(qual_ident) ->
print_string "global";
print_space ();
print_qualified_ident qual_ident
let rec print e =
open_box 1;
if not (atom e) then print_string "(";
begin match e.d_desc with
Dconstant(i) -> print_immediate i
| Dvar(v, subst) ->
print_var v;
print_subst subst
| Dlast(i) ->
print_string "last";
print_space ();
print_name i
| Dpre(opt_default, e) ->
print_string "pre";
print_space ();
begin match opt_default with
None -> print e
| Some(default) ->
print default; print_space (); print e
end
| Dinit(ck, None) ->
print_string "init";
print_space ();
print_clock ck
| Dinit(ck, Some(n)) ->
print_string "init";
print_space ();
print_clock ck;
print_space ();
print_name n
| Difthenelse(e0,e1,e2) ->
print_string "if";
print_space ();
print e0;
print_space ();
print e1;
print_space ();
print e2
| Dtuple(l) ->
print_string ",";
print_space ();
print_list print l
| Dconstruct(qual_ident,l) ->
print_string "constr";
print_space ();
print_qualified_ident qual_ident;
if l <> [] then print_space ();
print_list print l
| Dprim(qual_ident, l) ->
print_string "(";
print_qualified_ident qual_ident;
print_space ();
print_list print l;
print_string ")"
| Drecord(l) ->
print_string "record";
print_space ();
print_list (fun (qual_ident, e) ->
open_box 1;
print_string "(";
print_qualified_ident qual_ident;
print_space ();
print e;
print_string ")";
close_box ()) l
| Drecord_access(e,qual_ident) ->
print_string "access";
print_space ();
print e;
print_space ();
print_qualified_ident qual_ident
| Dfun(is_state, params, args, block, e) ->
print_string ("fun" ^ (if is_state then "(s)" else "(c)"));
print_space ();
print_params params;
print_space ();
print_list print_pat args;
print_space ();
print_block block;
print_space ();
print_string "return ";
print e
| Dapply(is_state, f, e_list) ->
print_string ("apply" ^ (if is_state then "(s)" else "(c)"));
print_space ();
print f;
print_space ();
print_list print e_list
| Dlet(block, e) ->
print_string "let";
print_space ();
print_block block;
print_space ();
print e
| Deseq(e1, e2) ->
print_string "seq";
print_space ();
print e1;
print_space ();
print e2
| Dtest(e1) ->
print_string "test";
print_space ();
print e1
| Dwhen(e1) ->
print_string "when";
print_space ();
print e1
| Dclock(ck) ->
print_string "clock";
print_space ();
print_clock ck
end;
if not (atom e) then print_string ")";
close_box()
and print_block b =
(* print variable definitions *)
let print_env env =
open_box 1;
print_string "(env";
print_space ();
Hashtbl.iter (fun i ident -> print_ident ident;print_space ()) env;
print_string ")";
close_box () in
(* main function *)
open_box 1;
print_string "(";
(* environment *)
print_env b.b_env;
print_space ();
(* equations *)
print_equation b.b_equations;
print_space ();
(* write variables *)
print_string "(write";
print_space ();
print_list print_name b.b_write;
print_string ")";
print_string ")";
close_box ()
(* print ident declarations *)
(* e.g, "(kind x/412 (int) (cl) (write) (last) (signal) (= 412))" *)
and print_ident id =
let print_kind () =
match id.id_kind with
Kinit -> print_string "init"
| Kclock -> print_string "clock"
| Kmemo -> print_string "memo"
| Kstatic -> print_string "static"
| Klast -> print_string "last"
| Kreset -> print_string "reset"
| Kvalue -> print_string "value"
| Kinput -> print_string "input"
| Kshared -> print_string "shared" in
let print_name () =
begin match id.id_original with
None -> ()
| Some(s) -> print_string s
end;
print_name id.id_name in
let print_typs () =
print_string "(";
print_typs id.id_typ;
print_string ")" in
let print_write () =
if id.id_write then
begin print_space (); print_string "(write)" end in
let print_last () =
if id.id_last then
begin print_space (); print_string "(last)" end in
let print_signal () =
if id.id_signal then
begin print_space (); print_string "(signal)" end in
let print_expr () =
match id.id_value with
None -> ()
| Some(e) ->
print_space ();print_string "(= "; print e; print_string ")" in
(* main function *)
open_box 1;
print_string "(";
print_kind ();
print_space ();
print_name ();
print_space ();
print_typs ();
print_space ();
print_write ();
print_last ();
print_signal ();
print_expr ();
print_string ")";
close_box ()
(* prints a sequence of sets of parallel equations *)
and print_equation eq =
open_box 1;
print_string "(";
begin match eq with
Dequation(pat, e) ->
print_string "let";
print_space ();
print_pat pat;
print_space ();
print e;
print_space ();
print_clock e.d_guard
| Dlasteq(n, e) ->
print_string "last";
print_space ();
print_name n;
print_space ();
print e;
print_space ();
print_clock e.d_guard
| Demit(pat, e) ->
print_string "emit";
print_space ();
print_pat pat;
print_space ();
print e;
print_space ();
print_clock e.d_guard
| Dstatic(pat, e) ->
print_string "static";
print_space ();
print_pat pat;
print_space ();
print e;
print_space ();
print_clock e.d_guard
| Dnext(n, e) ->
print_string "next";
print_space ();
print_name n;
print_space ();
print e;
print_space ();
print_clock e.d_guard
| Dget(pat, v) ->
print_string "get";
print_space ();
print_pat pat;
print_space ();
print_var v
| Dwheneq(eq, clk) ->
print_string "when";
print_space ();
print_clock clk;
print_space ();
print_equation eq
| Dmerge(is_static, e, pat_block_list) ->
print_string "merge";
print_space ();
if is_static then print_string "static"
else print_clock e.d_guard;
print_space ();
print e;
print_space ();
print_list (fun (pat, block) ->
open_box 1;
print_string "(";
print_pat pat;
print_space ();
print_block block;
print_string ")";
close_box ()) pat_block_list
| Dpresent(ck, scondpat_block_list, block) ->
print_string "present";
print_space ();
print_clock ck;
print_space ();
print_list (fun (scondpat, block) ->
open_box 1;
print_string "(";
print_spat scondpat;
print_space ();
print_block block;
print_string ")";
close_box ()) scondpat_block_list;
print_space ();
print_block block
| Dreset(eq, e) ->
print_string "reset";
print_space ();
print_equation eq;
print_space ();
print e
| Dautomaton(ck, handlers) ->
print_string "automaton";
print_space ();
print_clock ck;
print_space ();
print_list print_handler handlers
| Dpar(eq_list) ->
print_string "par";
print_space ();
print_list print_equation eq_list
| Dseq(eq_list) ->
print_string "seq";
print_space ();
print_list print_equation eq_list
| Dblock(b) ->
print_string "block";
print_space ();
print_block b
end;
print_string ")";
close_box ()
(* print the handlers of an automaton *)
and print_handler (statepat, b_weak, b_strong, weak_escape, strong_escape) =
open_box 1;
print_string "(state";
print_space ();
print_statepat statepat;
print_space ();
print_block b_weak;
print_space ();
print_block b_strong;
print_space ();
print_string "(weak ";
print_escape weak_escape;
print_string ")";
print_space ();
print_string "(strong ";
print_escape weak_escape;
print_string ")";
print_string ")";
close_box ()
and print_escape escape_list =
print_list
(fun (spat, b, is_continue, state) ->
print_string "(";
if is_continue then print_string "continue " else print_string "then ";
print_spat spat;
print_space ();
print_block b;
print_space ();
print_state state;
print_string ")")
escape_list;
close_box ()
(* print type and clock instance *)
and print_subst { s_typ = st; s_clock = scl; s_carrier = sc } =
match st, scl, sc with
[],[],[] -> ()
| l1,l2,l3 ->
print_string "[";
print_list print_type l1;
print_string "]";
print_space ();
print_string "[";
print_list print_clock l2;
print_string "]";
print_space ();
print_string "[";
print_list print_carrier l3;
print_string "]";
and print_params { s_typ = pt; s_clock = pcl; s_carrier = pc } =
match pt, pcl, pc with
[],[],[] -> ()
| l1,l2,l3 ->
print_string "[";
print_list print_name l1;
print_string "]";
print_space ();
print_string "[";
print_list print_name l2;
print_string "]";
print_space ();
print_string "[";
print_list print_name l3;
print_string "]"
and print_state (s, l) =
match l with
[] -> print_string s
| l -> print_string "(";
print_string s;
print_space ();
print_list print l;
print_string ")"
and atom_spat spat =
match spat with
Dexppat _ | Dcondpat _ -> true
| _ -> false
and print_spat spat =
open_box 1;
if not (atom_spat spat) then print_string "(";
begin match spat with
Dandpat(spat1, spat2) ->
print_string "& ";
print_spat spat1;
print_space ();
print_spat spat2
| Dexppat(e) ->
print e
| Dcondpat(e, pat) ->
print_string "is ";
print e;
print_space ();
print_pat pat
end;
if not (atom_spat spat) then print_string ")";
close_box ()
(* the main entry for printing definitions *)
let print_definition (name, e) =
open_box 2;
print_string "(def ";
if is_an_infix_or_prefix_operator name
then begin print_string "( "; print_string name; print_string " )" end
else print_string name;
print_space ();
print e;
print_string ")";
print_newline ();
close_box ()
(* print types *)
let print_variant (qualid, { arg = typ_list; res = typ }) =
print_string "(";
print_qualified_ident qualid;
print_string "(";
print_list print_type typ_list;
print_string ")";
print_space ();
print_type typ;
print_string ")"
let print_record (qualid, is_mutable, { arg = typ1; res = typ2 }) =
print_string "(";
if is_mutable then print_string "true" else print_string "false";
print_space ();
print_qualified_ident qualid;
print_space ();
print_type typ1;
print_space ();
print_type typ2;
print_string ")"
let print_type_declaration s { d_type_desc = td; d_type_arity = arity } =
open_box 2;
print_string "(type[";
print_list print_name arity;
print_string "]";
print_space ();
print_string s;
print_space ();
begin match td with
Dabstract_type -> ()
| Dabbrev(ty) ->
print_type ty
| Dvariant_type variant_list ->
List.iter print_variant variant_list
| Drecord_type record_list ->
List.iter print_record record_list
end;
print_string ")";
print_newline ();
close_box ();;
(* the main functions *)
set_max_boxes max_int ;;
let output_equations oc eqs =
set_formatter_out_channel oc;
List.iter print_equation eqs
let output oc declarative_code =
set_formatter_out_channel oc;
(* print type declarations *)
Hashtbl.iter print_type_declaration declarative_code.d_types;
(* print value definitions *)
List.iter print_definition declarative_code.d_code;
print_flush ()

63
compiler/obc/ml/default_value.ml
View file

@ -1,63 +0,0 @@
(**************************************************************************)
(* *)
(* Lucid Synchrone *)
(* *)
(* Author : Gregoire Hamon, Marc Pouzet *)
(* Organization : SPI team, LIP6 laboratory, University Paris 6 *)
(* *)
(**************************************************************************)
(* $Id: default_value.ml,v 1.1.1.1 2005-11-03 15:45:23 pouzet Exp $ *)
(** Computes a default value from a type *)
open Misc
open Names
open Def_types
open Types
open Initialization
open Caml
let default x ty =
let rec def ty =
match ty with
TypeVar{contents = Typindex _} -> Cdummy ""
| TypeVar{contents = Typlink ty} -> def ty
| Tarrow _ -> x
| Tproduct(t_list) ->
if t_list = []
then Cdummy ""
else Ctuple (List.map def t_list)
| Tconstr (info, tlist) ->
if info.qualid.qual = pervasives_module then
match info.qualid.id with
| "int" -> Cim (Cint 0)
| "bool" | "clock" -> Cim (Cbool false)
| "float" -> Cim (Cfloat 0.0)
| "char" -> Cim (Cchar 'a')
| "string" -> Cim (Cstring "")
| "unit" -> Cim (Cvoid)
| _ -> Cdummy ""
else
match info.info_in_table.type_desc with
Abstract_type -> Cdummy ""
| Variant_type l ->
begin
let case = List.hd l in
match case.info_in_table.typ_desc with
Tarrow (ty1, ty2) ->
Cconstruct1 ({ cqual = case.qualid.qual;
cid = case.qualid.id }, def ty1)
| _ ->
Cconstruct0 { cqual = case.qualid.qual;
cid = case.qualid.id }
end
| Record_type l ->
let field_of_type x =
let ty1,_ = filter_arrow x.info_in_table.typ_desc in
({ cqual = x.qualid.qual; cid = x.qualid.id }, def ty1) in
Crecord (List.map field_of_type l)
in
def ty

295
compiler/obc/ml/misc.ml
View file

@ -1,295 +0,0 @@
(**************************************************************************)
(* *)
(* Lucid Synchrone *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* $Id: misc.ml,v 1.11 2006-09-30 12:27:27 pouzet Exp $ *)
(* version of the compiler *)
let version = "3.0b"
let date = DATE
(* standard module *)
let pervasives_module = Pervasives
let standard_lib = STDLIB
(* variable creation *)
(* generating names *)
class name_generator =
object
val mutable counter = 0
method name =
counter <- counter + 1;
counter
method reset =
counter <- 0
method init i =
counter <- i
end
(* association table with memoization *)
class name_assoc_table f =
object
val mutable counter = 0
val mutable assoc_table: (int * string) list = []
method name var =
try
List.assq var assoc_table
with
not_found ->
let n = f counter in
counter <- counter + 1;
assoc_table <- (var,n) :: assoc_table;
n
method reset =
counter <- 0;
assoc_table <- []
end
(* error during the whole process *)
exception Error
(* internal error : for example, an abnormal pattern matching failure *)
(* gives the name of the function *)
exception Internal_error of string
let fatal_error s = raise (Internal_error s)
let not_yet_implemented s =
Printf.eprintf "The construction %s is not implemented yet.\n" s;
raise Error
(* creating a name generator for type and clock calculus *)
(* ensure unicity for the whole process *)
let symbol = new name_generator
(* generic and non generic variables in the various type systems *)
let generic = -1
let notgeneric = 0
let maxlevel = max_int
let binding_level = ref 0
let top_binding_level () = !binding_level = 0
let push_binding_level () = binding_level := !binding_level + 1
let pop_binding_level () =
binding_level := !binding_level - 1;
assert (!binding_level > generic)
let reset_binding_level () = binding_level := 0
(* realtime mode *)
let realtime = ref false
(* assertions *)
let no_assert = ref false
(* converting integers into variable names *)
(* variables are printed 'a, 'b *)
let int_to_letter bound i =
if i < 26
then String.make 1 (Char.chr (i+bound))
else String.make 1 (Char.chr ((i mod 26) + bound)) ^ string_of_int (i/26)
let int_to_alpha i = int_to_letter 97 i
(* printing information *)
class on_off =
object
val mutable status = false
method set = status <- true
method get = status
end
let print_type = new on_off
let print_clock = new on_off
let print_init = new on_off
let print_causality = new on_off
let no_causality = ref false
let no_initialisation = ref false
let no_deadcode = ref false
(* control what is done in the compiler *)
exception Stop
let only = ref ""
let set_only_info o = only := o
let parse_only () =
if !only = "parse" then raise Stop
let type_only () =
if !only = "type" then raise Stop
let clock_only () =
if !only = "clock" then raise Stop
let caus_only () =
if !only = "caus" then raise Stop
let init_only () =
if !only = "init" then raise Stop
let dec_only () =
if !only = "parse" or !only = "type"
or !only = "clock" or !only = "init"
or !only = "dec" then raise Stop
(* load paths *)
let load_path = ref ([] : string list)
(* no link *)
let no_link = ref false
(* simulation node *)
let simulation_node = ref ""
(* sampling rate *)
let sampling_rate : int option ref = ref None
(* level of inlining *)
let inlining_level = ref 10
(* emiting declarative code *)
let print_declarative_code = ref false
let print_auto_declarative_code = ref false
let print_total_declarative_code = ref false
let print_last_declarative_code = ref false
let print_signals_declarative_code = ref false
let print_reset_declarative_code = ref false
let print_linearise_declarative_code = ref false
let print_initialize_declarative_code = ref false
let print_split_declarative_code = ref false
let print_inline_declarative_code = ref false
let print_constant_declarative_code = ref false
let print_deadcode_declarative_code = ref false
let print_copt_declarative_code = ref false
(* total emission of signals *)
let set_total_emit = ref false
(* generating C *)
let make_c_code = ref false
(* profiling information about the compilation *)
let print_exec_time = ref false
exception Cannot_find_file of string
let find_in_path 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
(* Prompts: [error_prompt] is printed before compiler error *)
(* and warning messages *)
let error_prompt = ">"
(* list intersection *)
let intersect l1 l2 =
List.exists (fun el -> List.mem el l1) l2
(* remove an entry from an association list *)
let rec remove n l =
match l with
[] -> raise Not_found
| (m, v) :: l ->
if n = m then l else (m, v) :: remove n l
(* list substraction. l1 - l2 *)
let sub_list l1 l2 =
let rec sl l l1 =
match l1 with
[] -> l
| h :: t -> sl (if List.mem h l2 then l else (h :: l)) t in
sl [] l1
(* union *)
let rec union l1 l2 =
match l1, l2 with
[], l2 -> l2
| l1, [] -> l1
| x :: l1, l2 ->
if List.mem x l2 then union l1 l2 else x :: union l1 l2
let addq x l = if List.memq x l then l else x :: l
let rec unionq l1 l2 =
match l1, l2 with
[], l2 -> l2
| l1, [] -> l1
| x :: l1, l2 ->
if List.memq x l2 then unionq l1 l2 else x :: unionq l1 l2
(* intersection *)
let rec intersection l1 l2 =
match l1, l2 with
([], _) | (_, []) -> []
| x :: l1, l2 -> if List.mem x l2 then x :: intersection l1 l2
else intersection l1 l2
(* the last element of a list *)
let rec last l =
match l with
[] -> raise (Failure "last")
| [x] -> x
| _ :: l -> last l
(* iterator *)
let rec map_fold f acc l =
match l with
[] -> acc, []
| x :: l ->
let acc, v = f acc x in
let acc, l = map_fold f acc l in
acc, v :: l
(* flat *)
let rec flat l =
match l with
[] -> []
| x :: l -> x @ flat l
(* reverse *)
let reverse l =
let rec reverse acc l =
match l with
[] -> acc
| x :: l -> reverse (x :: acc) l in
reverse [] l
(* generic printing of a list *)
let print_list print print_sep l =
let rec printrec l =
match l with
[] -> ()
| [x] ->
print x
| x::l ->
print x;
print_sep ();
printrec l in
printrec l
(* generates the sequence of integers *)
let rec from n = if n = 0 then [] else n :: from (n-1)
(* for infix operators, print parenthesis around *)
let is_an_infix_or_prefix_operator op =
if op = "" then false
else
let c = String.get op 0 in
not (((c >= 'a') & (c <= 'z')) or ((c >= 'A') & (c <= 'Z')))
(* making a list from a hash-table *)
let listoftable t =
Hashtbl.fold (fun key value l -> (key, value) :: l) t []

2
compiler/obc/ml/ml.ml
View file

@ -1,2 +0,0 @@

12
compiler/utilities/misc.ml
View file

@ -169,19 +169,19 @@ let fold_righti f l acc =
aux 0 l acc
exception Assert_false
let internal_error passe code =
let internal_error passe =
Format.eprintf "@.---------\n
Internal compiler error\n
Passe : %s, Code : %d\n
----------@." passe code;
Passe : %s\n
----------@." passe;
raise Assert_false
exception Unsupported
let unsupported passe code =
let unsupported passe =
Format.eprintf "@.---------\n
Unsupported feature, please report it\n
Passe : %s, Code : %d\n
----------@." passe code;
Passe : %s\n
----------@." passe;
raise Unsupported
(* Functions to decompose a list into a tuple *)

4
compiler/utilities/misc.mli
View file

@ -98,7 +98,7 @@ val (|>) : 'a -> ('a -> 'b) -> 'b
val file_extension : string -> string
(** Internal error : Is used when an assertion wrong *)
val internal_error : string -> int -> 'a
val internal_error : string -> 'a
(** Unsupported : Is used when something should work but is not currently supported *)
val unsupported : string -> int -> 'a
val unsupported : string -> 'a

8
lib/pervasives.epi
View file

@ -1,6 +1,5 @@
(* the core module *)
(* $Id: pervasives.epi 77 2009-03-11 16:07:00Z delaval $ *)
(* pour debugger set arguments -nopervasives -i lib/pervasives.epi *)
(* The core module *)
(* To compile : heptc -nopervasives pervasives.epi *)
type bool = true | false
type int
type float
@ -15,6 +14,7 @@ val fun (-)(int;int) returns (int)
val fun (-.)(float;float) returns (float)
val fun (/)(int;int) returns (int)
val fun (/.)(float;float) returns (float)
val fun ( = )(int;int) returns (bool)
val fun ( <= )(int;int) returns (bool)
val fun ( <=. )(float;float) returns (bool)
val fun ( < )(int;int) returns (bool)
@ -32,4 +32,4 @@ val fun do_stuff(int) returns (int)
val fun between(int;int) returns (int)
val fun exit(bool) returns ()
val fun assert(bool) returns ()
val fun assert(bool) returns ()

2
test/async/pipline_a.ept
View file

@ -27,4 +27,4 @@ let
nf = normalized_movie<<100>>(f);
r = mean<<100>>(nf)
tel

2
test/async/rapide_lent.ept
View file

@ -13,7 +13,7 @@ let
cpt = size fby (if big_step then size else cpt - 1);
y = merge big_step
(true -> 0 -> (pre (lent(size))))
(false -> 0 fby y when false(big_step));
(false -> 0 fby y when false(big_step));
z = do_stuff(1) - y;
tel

2
test/async/rapide_lent_a.ept
View file

@ -13,7 +13,7 @@ let
cpt = size fby (if big_step then size else cpt - 1);
y = merge big_step
(true -> 0 -> !(pre (async lent(size))))
(false -> 0 fby y when false(big_step));
(false -> 0 fby y when false(big_step));
z = do_stuff(1) - y;
tel

2
test/async/tt.ept
View file

@ -9,4 +9,4 @@ let
t = async 0 fby async counter(false,true);
b = counter(false,true) -1 = !t;
tel

2
test/bad/bad_flatten.ept
View file

@ -9,4 +9,4 @@ let
done;
z = t2
tel

7
test/bad/clock_annot.ept Normal file
View file

@ -0,0 +1,7 @@
node f(x:int) returns (y:int on ck; ck,ck2:bool)
let
ck = true;
ck2 = true;
y = (x :: ck2)
tel

13
test/bad/clock_causality.ept Normal file
View file

@ -0,0 +1,13 @@
node cross<<l:int>>(x:int) returns (y:int; c:bool)
let
c = (0 fby y) = l;
y = merge c (true -> x) (false -> 0);
tel
node main(x:int) returns (z:int)
var y,t : int; c : bool;
let
y = 0 fby (y+1);
(t,c) = cross<<4>>(y);
z = merge c (true -> y + t) (false -> 0)
tel

5
test/bad/clock_dep.ept Normal file
View file

@ -0,0 +1,5 @@
node cross<<l:int>>(x:int; x2:int; c:bool) returns (y:int; c2:bool)
let
c2 = c;
y = x + (x2 when c2) ;
tel

2
test/bad/t2.ept
View file

@ -8,7 +8,7 @@ node h(x,z,m:int) returns (o:int)
automaton
state S1
var r:int;
do
do
k = m + 2;
r = k + 3;
w = 1 + 2;

6
test/bad/t3.ept
View file

@ -5,9 +5,9 @@ let
automaton
state A
do y = 2
until y = 2 then B
until y = 2 then B
state B
do y = 3
until y = 3 then C
do y = 3
until y = 3 then C
end
tel

8
test/bad/t4.ept
View file

@ -7,11 +7,11 @@ let
state B do y = x until y = 2 then A
end;
automaton
state C
do z = y
state C
do z = y
until z = 3 then D
state D
do z = x
state D
do z = x
until z = 4 then A
end
tel

22
test/bad/t5.ept
View file

@ -1,20 +1,20 @@
node f(x:int) returns (y,z:int)
let
automaton
state A
state A
do y = x;
z = 4;
z = 4;
until y = 2 then B
state B
state B
do y = x;
automaton
state C
do z = y
until z = 3 then D
state D
do z = x
until z = 4 then A
end
automaton
state C
do z = y
until z = 3 then D
state D
do z = x
until z = 4 then A
end
until y = 2 then A
end;
tel

11
test/bad/when_merge1.ept Normal file
View file

@ -0,0 +1,11 @@
(* pour debugger ../../compiler/hec.byte -i -v -I ../../lib t1.ept *)
(* pour debugger
directory parsing global analysis dataflow sequential sigali simulation translation main
set arguments -v ../test/good/t1.ept *)
type t = A | B
node fusion(x1:int on B(c); x2:int; c:t) returns (y :int)
let
y = merge c (A -> x1) (B -> x2)
tel

6
test/good/array2.ept
View file

@ -8,12 +8,12 @@ tel
node sumdup (a, acc_in:int) returns (o:int; acc_out:int)
let
acc_out = acc_in + a;
o = acc_out;
acc_out = acc_in + a;
o = acc_out;
tel
node p(a:int^n) returns (o:int^n)
var acc:int;
let
(o, acc) = mapfold<<n>> sumdup (a, 0);
(o, acc) = mapfold<<n>> sumdup (a, 0);
tel

2
test/good/array_fill.ept
View file

@ -1,7 +1,7 @@
const n : int = 33
node stopbb(shiftenable : bool) returns (dataout : bool^n)
var last dataint : bool^n; f : bool;
var last dataint : bool^n; f : bool;
let
f = false;
dataout = (f^n) fby dataint;

4
test/good/array_iterators.ept
View file

@ -51,5 +51,5 @@ tel
node itmapi(a:int^n) returns (o:int^n)
let
o = mapi <<n>> m(<a>)(a);
tel
o = mapi <<n>> m<(a)>(a);
tel

11
test/good/auto.ept
View file

@ -3,14 +3,19 @@ let
o = 0 fby (o + 1);
tel
node main() returns (c : bool)
node f() returns(x,y : bool)
let
(x,y) = (true,false)
tel
node main() returns (c,c1 : bool)
let
automaton
state One
do c = true;
do (c,c1) = f()
until count() = 5 then Two
state Two
do c = false
do (c,c1) = f()
until count() = 3 then One
end
tel

21
test/good/auto2.ept Normal file
View file

@ -0,0 +1,21 @@
node count() returns (o : int)
let
o = 0 fby (o + 1);
tel
node f() returns(x,y : bool)
let
(x,y) = (true,false)
tel
node main() returns (c,c1 : bool)
let
automaton
state One
do (c,c1) = f()
until count() = 5 then Two
state Two
do (c,c1) = f()
until count() = 3 then One
end
tel

2
test/good/autohiera.ept
View file

@ -19,7 +19,7 @@ let
state B
do
until count() = 3 then A
end
end
until count() = 5 then Two
state Two
do c = x;

2
test/good/autohiera2.ept
View file

@ -15,7 +15,7 @@ let
state B
do c = not(x);
until true then A
end
end
until true then Two
state Two
do c = x;

13
test/good/clock_causality.ept Normal file
View file

@ -0,0 +1,13 @@
node cross<<l:int>>(x:int) returns (y:int; c:bool)
let
c = x = l;
y = x when c;
tel
node main(x:int) returns (z:int)
var y,t : int; c : bool;
let
y = 0 fby (y+1);
(t,c) = cross<<4>>(x);
z = merge c (true -> y + t) (false -> 0)
tel

21
test/good/current.ept Normal file
View file

@ -0,0 +1,21 @@
node current (c : bool; x : int on c) returns ( y : int )
let
y = merge c (true -> x) (false -> 0 fby y whenot c)
tel
node internal_current (c : bool; x : int on c) returns ( y : int on c)
var x_cur : int;
let
x_cur = merge c (true -> x) (false -> 0 fby x_cur whenot c);
y = x_cur when c
tel
node use_current (c : bool; x : int) returns (b : bool on c; y : int on c)
var x_cur, y2 :int;
let
x_cur = current(c,x);
y = x_cur when c;
y2 = internal_current(c,x);
b = y = y2;
tel

2
test/good/flatten.ept
View file

@ -14,4 +14,4 @@ let
done;
z = t;
tel

18
test/good/or_keep.ept
View file

@ -6,15 +6,15 @@ tel
node f<<n : int>>(i : bool^n) returns (o, b : bool; nat : int)
let
b = fold<<n>> (or) (i, false);
automaton
state Idle
do o = false; nat = 0;
unless b then Emit
state Emit
do o = true;
nat = nat();
until nat > 3 then Idle
unless b then Emit
automaton
state Idle
do o = false; nat = 0;
unless b then Emit
state Emit
do o = true;
nat = nat();
until nat > 3 then Idle
unless b then Emit
end
tel

10
test/good/side_effet.ept Normal file
View file

@ -0,0 +1,10 @@
node hello() returns (b:bool)
var tmp : bool;
let
tmp = (*printf("hello")*) true;
automaton
state A var ttmp :bool; do
b = true;
ttmp = (*printf("hello")*) true;
end;
tel

16
test/good/t.ept Normal file
View file

@ -0,0 +1,16 @@
node count() returns (o : int)
let
o = 0 fby 1;
tel
node main() returns (c : int)
let
automaton
state One
do c = count ()
until count() = 5 then Two
state Two
do c = count ()
until count() = 3 then One
end
tel

14
test/good/t1.ept
View file

@ -65,14 +65,14 @@ node i(x, y: int) returns (o: int)
node j(x, y: int) returns (o: int)
let
automaton
state I
state I
var z: int;
do o = 1; z = 2
until (o = 2) then J
state J
do o = 2
until (o = 1) then I
end
end
tel
node (++)(up, down: int) returns (o: int)
@ -83,13 +83,13 @@ node (++)(up, down: int) returns (o: int)
state Init
var k : int;
do k = 0 -> pre k + 2;
cpt = 0
until
cpt = 0
until
(up = 1) then Up
state Up
do cpt = last cpt + 1
until (down = 1) then Down
| (down = 0) then Up
| (down = 0) then Up
state Down
do cpt = (last cpt) + 1
until (up = 1) then Up
@ -98,7 +98,7 @@ node (++)(up, down: int) returns (o: int)
node f(x: bool) returns (y: bool)
var z: bool;
let
let
y = x or x & x;
z = true -> if y then not (pre z) else pre z;
tel
@ -117,7 +117,7 @@ modes(v0) =
end
val gain : int >
modes last o : int when up: int -> int when down: int -> int
modes last o : int when up: int -> int when down: int -> int
end with { up # down }
let node gain(v0)(up, down) returns (o)

2
test/good/t15.ept
View file

@ -1,6 +1,6 @@
(* Crashes the pass removing intermediate equations. *)
node foo() returns (res:int)
let
let
res = if true then 1 else 1;
tel

2
test/good/t16.ept
View file

@ -2,7 +2,7 @@
node foo() returns (tmt1:int)
var v_1:int; tmt2:int;
let
let
tmt1 = (1 + tmt2);
tmt2 = 0 fby v_1;
v_1 = tmt1;

4
test/good/t2.ept
View file

@ -49,7 +49,7 @@ node hh(x,z,m:int) returns (o:int)
automaton
state S1
var r:int;
do
do
k = m + 2;
r = k + 3;
w = 1 + 2;
@ -59,7 +59,7 @@ node hh(x,z,m:int) returns (o:int)
state S2
do
k = 2;
until (1 = 0) then S2
until (1 = 0) then S2
end;(*
present
| (x = 0) do o = pre o + 2

2
test/good/t2open.ept
View file

@ -18,7 +18,7 @@ node h(x,z,m:int) returns (o:int)
automaton
state S1
var r:int;
do
do
k = m + 2;
r = k + 3;
w = 1 + 2;

6
test/good/t3.ept
View file

@ -6,9 +6,9 @@ node f(x,z:int) returns (o:int)
let
r = false;
automaton
state Init
do o = 1 + 2
until (o = 0) then Two
state Init
do o = 1 + 2
until (o = 0) then Two
state Two do o = 2 + 3 until (o = 1) then Two
end;
automaton

8
test/good/t6.ept
View file

@ -5,12 +5,12 @@ node f(x,z:int) returns (o1,o2:int)
switch (x = z)
| true do
o1 = 0 -> pre o1 + 2;
o2 = o4 + 1;
o4 = 3
o2 = o4 + 1;
o4 = 3
| false do
o1 = 4;
o2 = 5;
o4 = 5
o2 = 5;
o4 = 5
end;
tel

28
test/good/tt.ept Normal file
View file

@ -0,0 +1,28 @@
node f(x:bool;c:bool) returns (o:bool)
let
automaton
state A
var l:bool; do
l = x when c;
o = merge c (true -> l) (false -> false)
until true then B
state B
do o = false
end
tel
(*
node clock_on<<pref, per : int>>(w1, w2 : bool) returns (o : bool)
let
automaton
state FirstPeriod
var w2' : bool; do
w2' = w1 when w2;
o = false;
until true then Cruise
state Cruise do
o = true;
end
tel
*)

6
test/good/tttt.ept Normal file
View file

@ -0,0 +1,6 @@
node f(c:bool;x:int) returns (o:int)
let
reset
o = merge c (true -> (0 fby x) when c) (false -> 0 fby (o whenot c));
every true
tel

166
test/good/when_merge1.ept
View file

@ -15,170 +15,12 @@ node t2bool(x: t) returns (b: bool)
b = merge x (A-> true) (B-> false)
tel
(*
node mm(x: int) returns (o: int)
var last m: int = 0;
node filter(x:int; c:t) returns (y:int on A(c))
let
switch (x = 0)
| true do m = last m + 1; o = m
| false do m = 2; o = m
end
y = x when A(c)
tel
node mmm(x: int) returns (o2: int)
var last m: int = 1; o: int;
node fusion(x1:int; x2:int; c:t) returns (y :int)
let
automaton
state I
do m = 0; o = last m + 1 until (o = 1) then J
state J
do m = last m + 1; o = 0
end;
o2 = 1 -> pre o
y = merge c (A -> x1) (B -> x2)
tel
node m(x: int) returns (o: int)
var last o2 : int = 1;
let
automaton
state I
do o2 = 1
unless (last o2 = 2) then J
state J
do o2 = 3
unless (last o2 = 1) then I
end;
o = o2;
tel
node h(z: int; x, y: int) returns (o2: int)
var o1, o: int;
let
(o1, o2) = if z<0 then (1, 2) else (3, 4);
o = 0 -> pre o + 2
tel
node i(x, y: int) returns (o: int)
var z, k: int;
let
reset
o = 0 + x + y;
reset
z = 1 + o + 3;
k = z + o + 2
every (x = x)
every (x = y)
tel
node j(x, y: int) returns (o: int)
let
automaton
state I
var z: int;
do o = 1; z = 2
until (o = 2) then J
state J
do o = 2
until (o = 1) then I
end
tel
node (++)(up, down: int) returns (o: int)
var last cpt: int = 42;
let
o = last cpt;
automaton
state Init
var k : int;
do k = 0 -> pre k + 2;
cpt = 0
until
(up = 1) then Up
state Up
do cpt = last cpt + 1
until (down = 1) then Down
| (down = 0) then Up
state Down
do cpt = (last cpt) + 1
until (up = 1) then Up
end;
tel
node f(x: bool) returns (y: bool)
var z: bool;
let
y = x or x & x;
z = true -> if y then not (pre z) else pre z;
tel
(*
let increasing(x) returns (o)
do true -> x >= pre(x) + 1 done
modes(v0) =
last o = v0
when up(x) returns (w)
assume (x >= 0) ensure (w >= 0)
do w = x + last o + 2; o = w + 4 done
when down(x) returns (w)
do w = x - last o + 2; o = w + 2 done
end
val gain : int >
modes last o : int when up: int -> int when down: int -> int
end with { up # down }
let node gain(v0)(up, down) returns (o)
assume (v0 >= 0) & (increasing up)
guaranty (deacreasing o)
last o = 0 in
automaton
state Await
do
unless down then Down(1) | up then Up(1)
state Down(d)
let rec cpt = 1 -> pre cpt + 1 in
do o = last o - d
until (cpt >= 5) then Down(d-5)
until up then Up(1)
state Up(d)
let rec cpt = 1 -> pre cpt + 1 in
do o = last o + d
until (cpt >= 5) then Up(d+5)
until down then Down(1)
state Unreachable
let rec c = 0 + 2 in
var m in
do o = m + 2; m = 3 + c done
end
node g(x, y: int) returns (o: int)
let
o = x ++ y;
tel
node dfby(x)(y) returns (o)
let
o = x fby (x fby y)
tel
node f(x)(y) returns (o)
var last o = x;
let
o = last o + y
tel
val f : int > (int => int)
static x = e in ...
(if c then (fun x -> x + 2) else (fun k -> k + 3))(x+2)
let M(x1,..., xn) =
let y1 = ... in ... let yk = ... in
modes
mem m1 = ...; mem ml = ...;
step (...) returns (...) ...
reset = ...
end
*) *)

38
test/image_filters/convolutions.ept
View file

@ -1,8 +1,8 @@
(* Deal with matrix of size n*m, apply coeff :
kt
kl k kr
kb
centered on [>i<][>j<]. *)
kt
kl k kr
kb
centered on [>i<][>j<]. *)
fun kernel_1 << n,m,k,kl,kt,kr,kb :int>> (t :int^n^m; i,x,j :int) returns (r :int)
let
r = k*t[>i<][>j<] + kl*t[>i<][>j-1<] + kt*t[>i-1<][>j<] + kr*t[>i<][>j+1<] + kb*t[>i+1<][>j<]
@ -10,38 +10,38 @@ tel
fun convol_1_h <<n,m,k,kl,kt,kr,kb :int>> (t:int^n^m; line : int^m; i :int) returns (r :int^m)
let
r = mapi<<m>> (kernel_1<<n,m,k,kl,kt,kr,kb>>)(<t,i>) (line)
r = mapi<<m>> (kernel_1<<n,m,k,kl,kt,kr,kb>>)<(t,i)> (line)
tel
fun convol_1 <<n,m,k,kl,kt,kr,kb :int>> (t:int^n^m) returns (r :int^n^m)
let
r = mapi<<n>> ( convol_1_h<<n,m,k,kl,kt,kr,kb>> ) (<t>) (t)
r = mapi<<n>> ( convol_1_h<<n,m,k,kl,kt,kr,kb>> ) <(t)> (t)
tel
(* Deal with matrix of size n*m, apply coeff :
ktt
klt kt ktr
kll kl k kr krr
kbl kb krb
kbb
centered on [>i<][>j<]. *)
ktt
klt kt ktr
kll kl k kr krr
kbl kb krb
kbb
centered on [>i<][>j<]. *)
fun kernel_2 <<n,m,ktt,klt,kt,ktr,kll,kl,k,kr,krr,kbl,kb,krb,kbb :int>> (t :int^n^m; i,x,j :int) returns (r :int)
let
r = ktt*t[>i-2<][>j<]+
klt*t[>i-1<][>j-1<]+ kt*t[>i-1<][>j<]+ ktr*t[>i-1<][>j+1<]+
kll*t[>i<][>j-2<]+ kl*t[>i<][>j-1<]+ k*t[>i<][>j<]+ kr*t[>i<][>j+1<]+ krr*t[>i<][>j+2<]+
kbl*t[>i+1<][>j-1<]+ kb*t[>i+1<][>j<]+ krb*t[>i+1<][>j+1<]+
kbb*t[>i+2<][>j<];
r = ktt*t[>i-2<][>j<]+
klt*t[>i-1<][>j-1<]+ kt*t[>i-1<][>j<]+ ktr*t[>i-1<][>j+1<]+
kll*t[>i<][>j-2<]+ kl*t[>i<][>j-1<]+ k*t[>i<][>j<]+ kr*t[>i<][>j+1<]+ krr*t[>i<][>j+2<]+
kbl*t[>i+1<][>j-1<]+ kb*t[>i+1<][>j<]+ krb*t[>i+1<][>j+1<]+
kbb*t[>i+2<][>j<];
tel
fun convol_2_h<<n,m,ktt,klt,kt,ktr,kll,kl,k,kr,krr,kbl,kb,krb,kbb :int>> (t:int^n^m; line : int^m; i :int) returns (r :int^m)
let
r = mapi<<m>> (kernel_2<<n,m,ktt,klt,kt,ktr,kll,kl,k,kr,krr,kbl,kb,krb,kbb>>) (<t,i>) (line)
r = mapi<<m>> (kernel_2<<n,m,ktt,klt,kt,ktr,kll,kl,k,kr,krr,kbl,kb,krb,kbb>>) <(t,i)> (line)
tel
fun convol_2<<n,m,ktt,klt,kt,ktr,kll,kl,k,kr,krr,kbl,kb,krb,kbb :int>>(t:int^n^m) returns (r :int^n^m)
let
r = mapi<<n>> (convol_2_h<<n,m,ktt,klt,kt,ktr,kll,kl,k,kr,krr,kbl,kb,krb,kbb>>) (<t>) (t)
r = mapi<<n>> (convol_2_h<<n,m,ktt,klt,kt,ktr,kll,kl,k,kr,krr,kbl,kb,krb,kbb>>) <(t)> (t)
tel

2
test/image_filters/pip.ept
View file

@ -7,7 +7,7 @@ fun pip<<n1,m1,n2,m2,x,y :int>> (t1 :int^n1^m1; t2 :int^n2^m2) returns (r :int^n
var t12 :int^m1^n2;
let
t12 = map<<n2>> (pip_line<<m1,m2,y>>) (t1[x..x+n2-1], t2);
r = t1[0 .. x-1] @ t12 @ t1[x+n2 .. n1-1];
r = t1[0 .. x-1] @ t12 @ t1[x+n2 .. n1-1];
tel
node main() returns (r :int^10^10)

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