diff --git a/.gitignore b/.gitignore index faee133..c7523d0 100644 --- a/.gitignore +++ b/.gitignore @@ -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 diff --git a/compiler/global/clocks.ml b/compiler/global/clocks.ml index e818cc5..cf43a74 100644 --- a/compiler/global/clocks.ml +++ b/compiler/global/clocks.ml @@ -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) diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index d9adb81..456b68b 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -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 "@[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 "@[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 diff --git a/compiler/global/idents.ml b/compiler/global/idents.ml index 318ef35..f053693 100644 --- a/compiler/global/idents.ml +++ b/compiler/global/idents.ml @@ -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 diff --git a/compiler/global/idents.mli b/compiler/global/idents.mli index 571c665..7130fd7 100644 --- a/compiler/global/idents.mli +++ b/compiler/global/idents.mli @@ -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 diff --git a/compiler/global/modules.ml b/compiler/global/modules.ml index e4ee1ff..b92c8ca 100644 --- a/compiler/global/modules.ml +++ b/compiler/global/modules.ml @@ -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 diff --git a/compiler/global/names.ml b/compiler/global/names.ml index 3f64dab..ef7d72a 100644 --- a/compiler/global/names.ml +++ b/compiler/global/names.ml @@ -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 = diff --git a/compiler/global/signature.ml b/compiler/global/signature.ml index 2db89e8..6db616c 100644 --- a/compiler/global/signature.ml +++ b/compiler/global/signature.ml @@ -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 diff --git a/compiler/global/static.ml b/compiler/global/static.ml index fe41b2a..d74f4b1 100644 --- a/compiler/global/static.ml +++ b/compiler/global/static.ml @@ -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 - +*) diff --git a/compiler/heptagon/analysis/causality.ml b/compiler/heptagon/analysis/causality.ml index cc6bb8b..69681db 100644 --- a/compiler/heptagon/analysis/causality.ml +++ b/compiler/heptagon/analysis/causality.ml @@ -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) -> diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 052d38f..c1f1236 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -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; diff --git a/compiler/heptagon/hept_mapfold.ml b/compiler/heptagon/hept_mapfold.ml index 3b27e08..86df74a 100644 --- a/compiler/heptagon/hept_mapfold.ml +++ b/compiler/heptagon/hept_mapfold.ml @@ -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 = { diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index 275689e..b2627d4 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -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 diff --git a/compiler/heptagon/hept_utils.ml b/compiler/heptagon/hept_utils.ml index 8953540..3fe7b30 100644 --- a/compiler/heptagon/hept_utils.ml +++ b/compiler/heptagon/hept_utils.ml @@ -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 } + diff --git a/compiler/heptagon/heptagon.ml b/compiler/heptagon/heptagon.ml index 663ed71..3aadc1b 100644 --- a/compiler/heptagon/heptagon.ml +++ b/compiler/heptagon/heptagon.ml @@ -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) -*) diff --git a/compiler/heptagon/main/hept_compiler.ml b/compiler/heptagon/main/hept_compiler.ml index b622669..00a5c1f 100644 --- a/compiler/heptagon/main/hept_compiler.ml +++ b/compiler/heptagon/main/hept_compiler.ml @@ -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 diff --git a/compiler/heptagon/parsing/hept_lexer.mll b/compiler/heptagon/parsing/hept_lexer.mll index e370f0d..7bdc4f0 100644 --- a/compiler/heptagon/parsing/hept_lexer.mll +++ b/compiler/heptagon/parsing/hept_lexer.mll @@ -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} diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index 17fb065..40e3b3e 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -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 Constructor %token 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 } ; %% diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index d163ccd..87ae38e 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -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 diff --git a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml index b26e184..631939d 100644 --- a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml +++ b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml @@ -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; } diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index a6caf59..3d0cad3 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -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 diff --git a/compiler/heptagon/parsing/hept_static_scoping.ml b/compiler/heptagon/parsing/hept_static_scoping.ml index 6d93815..7f2d87a 100644 --- a/compiler/heptagon/parsing/hept_static_scoping.ml +++ b/compiler/heptagon/parsing/hept_static_scoping.ml @@ -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 *) diff --git a/compiler/heptagon/transformations/automata.ml b/compiler/heptagon/transformations/automata.ml index d678540..013bc4e 100644 --- a/compiler/heptagon/transformations/automata.ml +++ b/compiler/heptagon/transformations/automata.ml @@ -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 diff --git a/compiler/heptagon/transformations/every.ml b/compiler/heptagon/transformations/every.ml index 836f9d9..c81ff95 100644 --- a/compiler/heptagon/transformations/every.ml +++ b/compiler/heptagon/transformations/every.ml @@ -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) diff --git a/compiler/heptagon/transformations/inline.ml b/compiler/heptagon/transformations/inline.ml index 80ce425..487b551 100644 --- a/compiler/heptagon/transformations/inline.ml +++ b/compiler/heptagon/transformations/inline.ml @@ -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 diff --git a/compiler/heptagon/transformations/itfusion.ml b/compiler/heptagon/transformations/itfusion.ml index 0caf3aa..57fea0b 100644 --- a/compiler/heptagon/transformations/itfusion.ml +++ b/compiler/heptagon/transformations/itfusion.ml @@ -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 diff --git a/compiler/heptagon/transformations/normalize.ml b/compiler/heptagon/transformations/normalize.ml index 27608c5..18d265d 100644 --- a/compiler/heptagon/transformations/normalize.ml +++ b/compiler/heptagon/transformations/normalize.ml @@ -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 diff --git a/compiler/heptagon/transformations/present.ml b/compiler/heptagon/transformations/present.ml index a138123..66532a8 100644 --- a/compiler/heptagon/transformations/present.ml +++ b/compiler/heptagon/transformations/present.ml @@ -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 diff --git a/compiler/heptagon/transformations/reset.ml b/compiler/heptagon/transformations/reset.ml index c872601..b5a347d 100644 --- a/compiler/heptagon/transformations/reset.ml +++ b/compiler/heptagon/transformations/reset.ml @@ -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 diff --git a/compiler/heptagon/transformations/switch.ml b/compiler/heptagon/transformations/switch.ml index 6d58091..bcb5f4c 100644 --- a/compiler/heptagon/transformations/switch.ml +++ b/compiler/heptagon/transformations/switch.ml @@ -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) diff --git a/compiler/main/hept2mls.ml b/compiler/main/hept2mls.ml index 984291a..f5b191c 100644 --- a/compiler/main/hept2mls.ml +++ b/compiler/main/hept2mls.ml @@ -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} = diff --git a/compiler/main/hepts.ml b/compiler/main/hepts.ml index 44f623b..eacc261 100644 --- a/compiler/main/hepts.ml +++ b/compiler/main/hepts.ml @@ -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 -node -exec \n" ^ " " ^ Sys.executable_name ^ " -sig .epci -node -exec " and doc_sig = ".epci\tCompiled interface containing 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 diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 29e31f0..29eb6bc 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -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 diff --git a/compiler/main/mls2seq.ml b/compiler/main/mls2seq.ml index 1484058..c0f3d83 100644 --- a/compiler/main/mls2seq.ml +++ b/compiler/main/mls2seq.ml @@ -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 diff --git a/compiler/minils/analysis/clocking.ml b/compiler/minils/analysis/clocking.ml index 3b3d774..78a45b9 100644 --- a/compiler/minils/analysis/clocking.ml +++ b/compiler/minils/analysis/clocking.ml @@ -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 diff --git a/compiler/minils/analysis/init.ml b/compiler/minils/analysis/init.ml deleted file mode 100644 index 65e50f8..0000000 --- a/compiler/minils/analysis/init.ml +++ /dev/null @@ -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) - diff --git a/compiler/minils/analysis/level_clock.ml b/compiler/minils/analysis/level_clock.ml new file mode 100644 index 0000000..b7bfe75 --- /dev/null +++ b/compiler/minils/analysis/level_clock.ml @@ -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 \ No newline at end of file diff --git a/compiler/minils/main/mls_compiler.ml b/compiler/minils/main/mls_compiler.ml index 8a42098..9bbfc40 100644 --- a/compiler/minils/main/mls_compiler.ml +++ b/compiler/minils/main/mls_compiler.ml @@ -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 *) (* diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index 7c60316..b8323fd 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -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 <> (extvalue, extvalue...) reset ident *) + (** map f <> <(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 } diff --git a/compiler/minils/mls_mapfold.ml b/compiler/minils/mls_mapfold.ml index 2575d0d..ff66125 100644 --- a/compiler/minils/mls_mapfold.ml +++ b/compiler/minils/mls_mapfold.ml @@ -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 diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index a1609ab..611dcb0 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -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 "@[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 diff --git a/compiler/minils/mls_utils.ml b/compiler/minils/mls_utils.ml index 6844894..5dc009a 100644 --- a/compiler/minils/mls_utils.ml +++ b/compiler/minils/mls_utils.ml @@ -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 } diff --git a/compiler/minils/transformations/callgraph.ml b/compiler/minils/transformations/callgraph.ml index 2a68a18..2299b7a 100644 --- a/compiler/minils/transformations/callgraph.ml +++ b/compiler/minils/transformations/callgraph.ml @@ -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; diff --git a/compiler/minils/transformations/checkpass.ml b/compiler/minils/transformations/checkpass.ml index 2a023a2..8b375fd 100644 --- a/compiler/minils/transformations/checkpass.ml +++ b/compiler/minils/transformations/checkpass.ml @@ -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 diff --git a/compiler/minils/transformations/normalize_mem.ml b/compiler/minils/transformations/normalize_mem.ml index a54c2a5..21ecfba 100644 --- a/compiler/minils/transformations/normalize_mem.ml +++ b/compiler/minils/transformations/normalize_mem.ml @@ -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) diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index bfb6c5c..17b928e 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -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 diff --git a/compiler/obc/c/cmain.ml b/compiler/obc/c/cmain.ml index c7761a4..39b66c1 100644 --- a/compiler/obc/c/cmain.ml +++ b/compiler/obc/c/cmain.ml @@ -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 "")]))]) diff --git a/compiler/obc/control.ml b/compiler/obc/control.ml index 7b73da2..c9cf5d5 100644 --- a/compiler/obc/control.ml +++ b/compiler/obc/control.ml @@ -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 = diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index 074b00c..83570ca 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -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 diff --git a/compiler/obc/ml/caml.ml b/compiler/obc/ml/caml.ml deleted file mode 100644 index 99b7420..0000000 --- a/compiler/obc/ml/caml.ml +++ /dev/null @@ -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] - diff --git a/compiler/obc/ml/caml_aux.ml b/compiler/obc/ml/caml_aux.ml deleted file mode 100644 index 48da556..0000000 --- a/compiler/obc/ml/caml_aux.ml +++ /dev/null @@ -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 - - - - - - - - - - - - - - - - diff --git a/compiler/obc/ml/caml_printer.ml b/compiler/obc/ml/caml_printer.ml deleted file mode 100644 index 536a407..0000000 --- a/compiler/obc/ml/caml_printer.ml +++ /dev/null @@ -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 () - diff --git a/compiler/obc/ml/cenvironment.ml b/compiler/obc/ml/cenvironment.ml deleted file mode 100644 index d410adb..0000000 --- a/compiler/obc/ml/cenvironment.ml +++ /dev/null @@ -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 diff --git a/compiler/obc/ml/coiteration.ml b/compiler/obc/ml/coiteration.ml deleted file mode 100644 index 712d1cb..0000000 --- a/compiler/obc/ml/coiteration.ml +++ /dev/null @@ -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. 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; - } diff --git a/compiler/obc/ml/declarative.ml b/compiler/obc/ml/declarative.ml deleted file mode 100644 index ae6db9e..0000000 --- a/compiler/obc/ml/declarative.ml +++ /dev/null @@ -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 diff --git a/compiler/obc/ml/declarative_printer.ml b/compiler/obc/ml/declarative_printer.ml deleted file mode 100644 index 6c93d2c..0000000 --- a/compiler/obc/ml/declarative_printer.ml +++ /dev/null @@ -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 () - diff --git a/compiler/obc/ml/default_value.ml b/compiler/obc/ml/default_value.ml deleted file mode 100644 index ff2800a..0000000 --- a/compiler/obc/ml/default_value.ml +++ /dev/null @@ -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 - - diff --git a/compiler/obc/ml/misc.ml b/compiler/obc/ml/misc.ml deleted file mode 100644 index 3b0b07d..0000000 --- a/compiler/obc/ml/misc.ml +++ /dev/null @@ -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 [] diff --git a/compiler/obc/ml/ml.ml b/compiler/obc/ml/ml.ml deleted file mode 100644 index 139597f..0000000 --- a/compiler/obc/ml/ml.ml +++ /dev/null @@ -1,2 +0,0 @@ - - diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index f02f364..a8e7e55 100644 --- a/compiler/utilities/misc.ml +++ b/compiler/utilities/misc.ml @@ -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 *) diff --git a/compiler/utilities/misc.mli b/compiler/utilities/misc.mli index 16783a9..dfcb41a 100644 --- a/compiler/utilities/misc.mli +++ b/compiler/utilities/misc.mli @@ -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 diff --git a/lib/pervasives.epi b/lib/pervasives.epi index e0aded0..36ec716 100644 --- a/lib/pervasives.epi +++ b/lib/pervasives.epi @@ -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 () \ No newline at end of file +val fun assert(bool) returns () diff --git a/test/async/pipline_a.ept b/test/async/pipline_a.ept index 501ad72..0f98593 100644 --- a/test/async/pipline_a.ept +++ b/test/async/pipline_a.ept @@ -27,4 +27,4 @@ let nf = normalized_movie<<100>>(f); r = mean<<100>>(nf) tel - + diff --git a/test/async/rapide_lent.ept b/test/async/rapide_lent.ept index ac0aa53..cf53ad9 100644 --- a/test/async/rapide_lent.ept +++ b/test/async/rapide_lent.ept @@ -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 diff --git a/test/async/rapide_lent_a.ept b/test/async/rapide_lent_a.ept index 1c53a99..76bd479 100644 --- a/test/async/rapide_lent_a.ept +++ b/test/async/rapide_lent_a.ept @@ -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 diff --git a/test/async/tt.ept b/test/async/tt.ept index e77a98c..ea901e8 100644 --- a/test/async/tt.ept +++ b/test/async/tt.ept @@ -9,4 +9,4 @@ let t = async 0 fby async counter(false,true); b = counter(false,true) -1 = !t; tel - + diff --git a/test/bad/bad_flatten.ept b/test/bad/bad_flatten.ept index a3cb584..d6573ba 100644 --- a/test/bad/bad_flatten.ept +++ b/test/bad/bad_flatten.ept @@ -9,4 +9,4 @@ let done; z = t2 tel - + diff --git a/test/bad/clock_annot.ept b/test/bad/clock_annot.ept new file mode 100644 index 0000000..960bd77 --- /dev/null +++ b/test/bad/clock_annot.ept @@ -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 + diff --git a/test/bad/clock_causality.ept b/test/bad/clock_causality.ept new file mode 100644 index 0000000..d8b3d0b --- /dev/null +++ b/test/bad/clock_causality.ept @@ -0,0 +1,13 @@ +node cross<>(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 diff --git a/test/bad/clock_dep.ept b/test/bad/clock_dep.ept new file mode 100644 index 0000000..906aab4 --- /dev/null +++ b/test/bad/clock_dep.ept @@ -0,0 +1,5 @@ +node cross<>(x:int; x2:int; c:bool) returns (y:int; c2:bool) +let + c2 = c; + y = x + (x2 when c2) ; +tel diff --git a/test/bad/t2.ept b/test/bad/t2.ept index a2e4be5..fe9fc52 100644 --- a/test/bad/t2.ept +++ b/test/bad/t2.ept @@ -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; diff --git a/test/bad/t3.ept b/test/bad/t3.ept index b38e668..ab8a3ce 100644 --- a/test/bad/t3.ept +++ b/test/bad/t3.ept @@ -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 diff --git a/test/bad/t4.ept b/test/bad/t4.ept index 4ecf10a..4947625 100644 --- a/test/bad/t4.ept +++ b/test/bad/t4.ept @@ -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 diff --git a/test/bad/t5.ept b/test/bad/t5.ept index 515ed31..9dadde2 100644 --- a/test/bad/t5.ept +++ b/test/bad/t5.ept @@ -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 diff --git a/test/bad/when_merge1.ept b/test/bad/when_merge1.ept new file mode 100644 index 0000000..8e02bc3 --- /dev/null +++ b/test/bad/when_merge1.ept @@ -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 diff --git a/test/good/array2.ept b/test/good/array2.ept index 628ad1f..73b334e 100644 --- a/test/good/array2.ept +++ b/test/good/array2.ept @@ -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<> sumdup (a, 0); + (o, acc) = mapfold<> sumdup (a, 0); tel diff --git a/test/good/array_fill.ept b/test/good/array_fill.ept index 4078a15..e995185 100644 --- a/test/good/array_fill.ept +++ b/test/good/array_fill.ept @@ -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; diff --git a/test/good/array_iterators.ept b/test/good/array_iterators.ept index fc25bdf..802a793 100644 --- a/test/good/array_iterators.ept +++ b/test/good/array_iterators.ept @@ -51,5 +51,5 @@ tel node itmapi(a:int^n) returns (o:int^n) let - o = mapi <> m()(a); -tel \ No newline at end of file + o = mapi <> m<(a)>(a); +tel diff --git a/test/good/auto.ept b/test/good/auto.ept index 3d42889..ab579f4 100644 --- a/test/good/auto.ept +++ b/test/good/auto.ept @@ -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 diff --git a/test/good/auto2.ept b/test/good/auto2.ept new file mode 100644 index 0000000..ab579f4 --- /dev/null +++ b/test/good/auto2.ept @@ -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 diff --git a/test/good/autohiera.ept b/test/good/autohiera.ept index a112692..db2999f 100644 --- a/test/good/autohiera.ept +++ b/test/good/autohiera.ept @@ -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; diff --git a/test/good/autohiera2.ept b/test/good/autohiera2.ept index 4cf134f..a9ef47b 100644 --- a/test/good/autohiera2.ept +++ b/test/good/autohiera2.ept @@ -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; diff --git a/test/good/clock_causality.ept b/test/good/clock_causality.ept new file mode 100644 index 0000000..097ef2b --- /dev/null +++ b/test/good/clock_causality.ept @@ -0,0 +1,13 @@ +node cross<>(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 diff --git a/test/good/current.ept b/test/good/current.ept new file mode 100644 index 0000000..7a31172 --- /dev/null +++ b/test/good/current.ept @@ -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 diff --git a/test/good/flatten.ept b/test/good/flatten.ept index d78765e..5b42b35 100644 --- a/test/good/flatten.ept +++ b/test/good/flatten.ept @@ -14,4 +14,4 @@ let done; z = t; tel - + diff --git a/test/good/or_keep.ept b/test/good/or_keep.ept index ee40dc9..db46764 100644 --- a/test/good/or_keep.ept +++ b/test/good/or_keep.ept @@ -6,15 +6,15 @@ tel node f<>(i : bool^n) returns (o, b : bool; nat : int) let b = fold<> (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 diff --git a/test/good/side_effet.ept b/test/good/side_effet.ept new file mode 100644 index 0000000..f0eb3a9 --- /dev/null +++ b/test/good/side_effet.ept @@ -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 diff --git a/test/good/t.ept b/test/good/t.ept new file mode 100644 index 0000000..e7e6b54 --- /dev/null +++ b/test/good/t.ept @@ -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 diff --git a/test/good/t1.ept b/test/good/t1.ept index a5aec34..dff140e 100644 --- a/test/good/t1.ept +++ b/test/good/t1.ept @@ -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) diff --git a/test/good/t15.ept b/test/good/t15.ept index ad3287d..4c38dc2 100644 --- a/test/good/t15.ept +++ b/test/good/t15.ept @@ -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 diff --git a/test/good/t16.ept b/test/good/t16.ept index ba4aa6f..41f6a23 100644 --- a/test/good/t16.ept +++ b/test/good/t16.ept @@ -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; diff --git a/test/good/t2.ept b/test/good/t2.ept index d770bb8..e195e48 100644 --- a/test/good/t2.ept +++ b/test/good/t2.ept @@ -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 diff --git a/test/good/t2open.ept b/test/good/t2open.ept index 9c44cb9..5e98bb7 100644 --- a/test/good/t2open.ept +++ b/test/good/t2open.ept @@ -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; diff --git a/test/good/t3.ept b/test/good/t3.ept index a70c31f..b991d3a 100644 --- a/test/good/t3.ept +++ b/test/good/t3.ept @@ -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 diff --git a/test/good/t6.ept b/test/good/t6.ept index 546617a..a248ac7 100644 --- a/test/good/t6.ept +++ b/test/good/t6.ept @@ -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 diff --git a/test/good/tt.ept b/test/good/tt.ept new file mode 100644 index 0000000..e294c39 --- /dev/null +++ b/test/good/tt.ept @@ -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<>(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 +*) diff --git a/test/good/tttt.ept b/test/good/tttt.ept new file mode 100644 index 0000000..03db7a3 --- /dev/null +++ b/test/good/tttt.ept @@ -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 diff --git a/test/good/when_merge1.ept b/test/good/when_merge1.ept index 2449542..c198259 100644 --- a/test/good/when_merge1.ept +++ b/test/good/when_merge1.ept @@ -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 -*) *) diff --git a/test/image_filters/convolutions.ept b/test/image_filters/convolutions.ept index 9ad9217..a20bbe6 100644 --- a/test/image_filters/convolutions.ept +++ b/test/image_filters/convolutions.ept @@ -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 <> (t:int^n^m; line : int^m; i :int) returns (r :int^m) let - r = mapi<> (kernel_1<>)() (line) + r = mapi<> (kernel_1<>)<(t,i)> (line) tel fun convol_1 <> (t:int^n^m) returns (r :int^n^m) let - r = mapi<> ( convol_1_h<> ) () (t) + r = mapi<> ( convol_1_h<> ) <(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 <> (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<> (t:int^n^m; line : int^m; i :int) returns (r :int^m) let - r = mapi<> (kernel_2<>) () (line) + r = mapi<> (kernel_2<>) <(t,i)> (line) tel fun convol_2<>(t:int^n^m) returns (r :int^n^m) let - r = mapi<> (convol_2_h<>) () (t) + r = mapi<> (convol_2_h<>) <(t)> (t) tel diff --git a/test/image_filters/pip.ept b/test/image_filters/pip.ept index 87c7c67..c93f11b 100644 --- a/test/image_filters/pip.ept +++ b/test/image_filters/pip.ept @@ -7,7 +7,7 @@ fun pip<> (t1 :int^n1^m1; t2 :int^n2^m2) returns (r :int^n var t12 :int^m1^n2; let t12 = map<> (pip_line<>) (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) diff --git a/test/tt.ept b/test/tt.ept new file mode 100644 index 0000000..9deef77 --- /dev/null +++ b/test/tt.ept @@ -0,0 +1,15 @@ +node m(x:int) returns (y:int) +let + y = 0 fby x +tel + + +node f(x,y:int;c1,c2:bool) returns (o1,o2:int) +var r:bool; +let + r = true; + reset + o1 = m(x when c1); + o2 = y + every (true when c2) +tel diff --git a/todo.txt b/todo.txt index b83963b..87d7c00 100644 --- a/todo.txt +++ b/todo.txt @@ -1,22 +1,29 @@ Plus ou moins ordonné du plus urgent au moins urgent. -*- Bugs related to matching types without unaliasing it. In lots of parts. Use Modules.unalias_type. +Bugs : + +*- Typer les signatures (verifier que les contraintes sont bien des bools) + +*- Hept mapfold ne parcourt pas les types partout..... cf TODO du code. + +*- Bugs related to matching types without unaliasing it. In lots of parts. Use Modules.unalias_type. *- Les types des patterns dans les boucles crées par concatenate ( entre autres ) sont faux. + +Ameliorations : + +*- Permettre des equations sans variables a gauche. Ou au moins ne pas donner de nom au pattern : _ + *- Collision entre les noms de params et les idents dans les noeuds. *- Optimisations du genre "if true then ... else ... " ou genre "x,y = if b then a,c else a2,c" qui devrait etre transformé en "x = if b then a else s2; y = c" ... *- Optimisation de la traduction des automates : pas besoin de variables de reset pour les états "continue", etc. -*- (LG) Rajouter les annotations d'horloge dans le source (les mettres comme contrainte de sous typage en ck_base ?? voir avec lucy-n) - *- Compléter la passe "static.ml" pour gérer l'ensemble des opérateurs de pervasives -*- Permettre les déclarations des types et des noeuds et des constantes dans un ordre quelconque. - *- Permettre la définition de constantes locales. *- Optimiser le reset en utilisant un memcopy ? ou autre chose ? diff --git a/tools/enforce_style.sh b/tools/enforce_style.sh index 155d7c9..698b491 100755 --- a/tools/enforce_style.sh +++ b/tools/enforce_style.sh @@ -1,2 +1,2 @@ #!/bin/sh -find . \! -path "*_build*" -and \( -iname "*.ml" -or -iname "*.mli" -or -iname "*.mly" -or -iname "*.mll" \) -exec perl -pi -e 's/( |\t)+$//gi; s/\t/ /g' {} \; +find . \! -path "*build*" -and \( -iname "*.ml" -or -iname "*.mli" -or -iname "*.mly" -or -iname "*.mll" -or -iname "*.ept" -or -iname "*.txt" \) -exec perl -pi -e 's/( |\t)+$//gi; s/\t/ /g' {} \;