diff --git a/.gitignore b/.gitignore index d78b817..faee133 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,4 @@ _build *.dot test/*.ml test/_check_builds +lib/java/.classpath diff --git a/compiler/TODO.txt b/compiler/TODO.txt new file mode 100755 index 0000000..a97125e --- /dev/null +++ b/compiler/TODO.txt @@ -0,0 +1,6 @@ +- Ne plus forcer l'ordre constantes puis types puis definitions de noeud. Il +faudra mettre à jour les phases du compilateur et modifier l'ast. +- Ajouter des constantes locales + +- supprimer pinst dans minils +- heptcheck diff --git a/compiler/global/clocks.ml b/compiler/global/clocks.ml index 61702f7..5028474 100644 --- a/compiler/global/clocks.ml +++ b/compiler/global/clocks.ml @@ -94,7 +94,9 @@ let rec skeleton ck = function Format.eprintf "Internal error, an exp with invalid type@."; assert false; | _ -> Cprod (List.map (skeleton ck) ty_list)) - | Tarray _ | Tid _ | Tunit -> Ck ck + | Tarray (t, _) -> skeleton ck t + | Tmutable t -> skeleton ck t + | Tid _ | Tunit -> Ck ck (* TODO here it implicitely says that the base clock is Cbase and that all tuple is on Cbase *) diff --git a/compiler/global/global_compare.ml b/compiler/global/global_compare.ml index 00c75df..02cb472 100644 --- a/compiler/global/global_compare.ml +++ b/compiler/global/global_compare.ml @@ -35,6 +35,7 @@ and link_compare li1 li2 = match li1, li2 with | Cindex _, _ -> 1 | Clink _, _ -> -1 + let rec static_exp_compare se1 se2 = let cr = type_compare se1.se_ty se2.se_ty in @@ -80,7 +81,7 @@ let rec static_exp_compare se1 se2 = | Sfield _, (Svar _ | Sint _ | Sfloat _ | Sbool _ | Sconstructor _) -> -1 | Sfield _, _ -> 1 - | Stuple _, (Srecord _ | Sop _ | Sarray _ | Sarray_power _) -> 1 + | Stuple _, (Srecord _ | Sop _ | Sarray _ | Sarray_power _ ) -> 1 | Stuple _, _ -> -1 | Sarray_power _, (Srecord _ | Sop _ | Sarray _) -> -1 @@ -100,7 +101,12 @@ and type_compare ty1 ty2 = match ty1, ty2 with | Tarray (ty1, se1), Tarray (ty2, se2) -> let cr = type_compare ty1 ty2 in if cr <> 0 then cr else static_exp_compare se1 se2 - | (Tprod _ | Tid _), _ -> 1 - | (Tarray _), _ -> -1 | Tunit, Tunit -> 0 + | Tprod _, _ -> 1 + | Tid _, Tprod _ -> -1 + | Tid _, _ -> 1 + | Tarray _, (Tprod _ | Tid _) -> -1 + | Tarray _, _ -> 1 + | Tmutable _, (Tprod _ | Tid _ | Tarray _) -> -1 + | Tmutable _, _ -> 1 | Tunit, _ -> -1 diff --git a/compiler/global/global_mapfold.ml b/compiler/global/global_mapfold.ml index 1af3f94..facb84a 100644 --- a/compiler/global/global_mapfold.ml +++ b/compiler/global/global_mapfold.ml @@ -5,19 +5,17 @@ open Types open Signature type 'a global_it_funs = { - static_exp : - 'a global_it_funs -> 'a -> static_exp -> static_exp * 'a; - static_exp_desc : - 'a global_it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a; - ty : 'a global_it_funs -> 'a -> ty -> ty * 'a; -(* ct : 'a global_it_funs -> 'a -> ct -> ct * 'a; - ck : 'a global_it_funs -> 'a -> ck -> ck * 'a; - link : 'a global_it_funs -> 'a -> link -> link * 'a; *) - param: 'a global_it_funs -> 'a -> param -> param * 'a; - arg: 'a global_it_funs -> 'a -> arg -> arg * 'a; - node : 'a global_it_funs -> 'a -> node -> node * 'a; - structure: 'a global_it_funs -> 'a -> structure -> structure * 'a; - field: 'a global_it_funs -> 'a -> field -> field * 'a; } + static_exp : 'a global_it_funs -> 'a -> static_exp -> static_exp * 'a; + static_exp_desc : 'a global_it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a; + ty : 'a global_it_funs -> 'a -> ty -> ty * 'a; +(* ct : 'a global_it_funs -> 'a -> ct -> ct * 'a; + ck : 'a global_it_funs -> 'a -> ck -> ck * 'a; + link : 'a global_it_funs -> 'a -> link -> link * 'a; *) + param : 'a global_it_funs -> 'a -> param -> param * 'a; + arg : 'a global_it_funs -> 'a -> arg -> arg * 'a; + node : 'a global_it_funs -> 'a -> node -> node * 'a; + structure : 'a global_it_funs -> 'a -> structure -> structure * 'a; + field : 'a global_it_funs -> 'a -> field -> field * 'a; } let rec static_exp_it funs acc se = funs.static_exp funs acc se and static_exp funs acc se = @@ -59,6 +57,9 @@ and ty funs acc t = match t with let t, acc = ty_it funs acc t in let se, acc = static_exp_it funs acc se in Tarray (t, se), acc + | Tmutable t -> + let t, acc = ty_it funs acc t in + Tmutable t, acc | Tunit -> t, acc (* and ct_it funs acc c = try funs.ct funs acc c with Fallback -> ct funs acc t diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index a009006..9306ae4 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -7,11 +7,33 @@ open Modules open Format open Pp_tools -let print_qualname ff qn = match qn with - | { qual = "Pervasives"; name = n } -> print_name ff n - | { qual = m; name = n } when m = g_env.current_mod -> print_name ff n - | { qual = m; name = n } when m = local_qualname -> print_name ff n - | { qual = m; name = n } -> fprintf ff "%s.%a" m print_name n + +let rec _aux_print_modul ?(full=false) ff m = match m with + | Pervasives -> () + | LocalModule -> () + | _ when m = g_env.current_mod && not full -> () + | 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 + +(** Prints a [modul] with a [.] at the end when not empty *) +let _print_modul ?(full=false) ff m = match m with + | Pervasives -> () + | LocalModule -> () + | _ when m = g_env.current_mod && not full -> () + | 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 + +let _print_qualname ?(full=false) ff { qual = q; name = n} = match q with + | Pervasives -> print_name ff n + | 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 rec print_static_exp ff se = match se.se_desc with @@ -24,9 +46,8 @@ let rec print_static_exp ff se = match se.se_desc with | Sop (op, se_list) -> if is_infix (shortname op) then - let op_s = opname op ^ " " in - fprintf ff "@[%a@]" - (print_list_l print_static_exp "(" op_s ")") se_list + let e1,e2 = Misc.assert_2 se_list in + fprintf ff "(@[%a@ %a %a@])" print_static_exp e1 print_qualname op print_static_exp e2 else fprintf ff "@[<2>%a@,%a@]" print_qualname op print_static_exp_tuple se_list @@ -43,14 +64,16 @@ and print_static_exp_tuple ff l = fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l and print_type ff = function + | Tprod [] -> fprintf ff "INVALID TYPE" | Tprod ty_list -> fprintf ff "@[%a@]" (print_list_r print_type "(" " *" ")") ty_list | Tid id -> print_qualname ff id | Tarray (ty, n) -> fprintf ff "@[%a^%a@]" print_type ty print_static_exp n + | Tmutable ty -> + fprintf ff "@[mutable %a@]" print_type ty | Tunit -> fprintf ff "unit" - let print_field ff field = fprintf ff "@[%a: %a@]" print_qualname field.f_name print_type field.f_type diff --git a/compiler/global/idents.mli b/compiler/global/idents.mli index ee1ab96..a8c6282 100644 --- a/compiler/global/idents.mli +++ b/compiler/global/idents.mli @@ -2,6 +2,7 @@ open Names (** This modules manages unique identifiers, + /!\ To be effective, [enter_node] has to be called when entering a node [gen_fresh] generates an identifier [name] returns a unique name (inside its node) from an identifier. *) @@ -11,7 +12,7 @@ type ident (** Type to be used for local variables *) type var_ident = ident -(** Comparision on idents with the same properties as [Pervasives.compare] *) +(** Comparison on idents with the same properties as [Pervasives.compare] *) val ident_compare : ident -> ident -> int (** Get the full name of an identifier (it is guaranteed to be unique) *) @@ -21,6 +22,9 @@ val name : ident -> string 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 + +(** [gen_var pass_name name] + generates a fresh ident with a sweet [name] *) val gen_var : string -> string -> ident (** [ident_of_name n] returns an identifier corresponding diff --git a/compiler/global/initial.ml b/compiler/global/initial.ml index 000fec4..11244ad 100644 --- a/compiler/global/initial.ml +++ b/compiler/global/initial.ml @@ -14,28 +14,32 @@ open Types let tglobal = [] let cglobal = [] -let pbool = { qual = "Pervasives"; name = "bool" } -let ptrue = { qual = "Pervasives"; name = "true" } -let pfalse = { qual = "Pervasives"; name = "false" } -let por = { qual = "Pervasives"; name = "or" } -let pint = { qual = "Pervasives"; name = "int" } -let pfloat = { qual = "Pervasives"; name = "float" } +let pbool = { qual = Pervasives; name = "bool" } +let tbool = Types.Tid pbool +let ptrue = { qual = Pervasives; name = "true" } +let pfalse = { qual = Pervasives; name = "false" } +let por = { qual = Pervasives; name = "or" } +let pint = { qual = Pervasives; name = "int" } +let tint = Types.Tid pint +let pfloat = { qual = Pervasives; name = "float" } +let tfloat = Types.Tid pfloat -let mk_pervasives s = { qual = "Pervasives"; name = s } + +let mk_pervasives s = { qual = Pervasives; name = s } let mk_static_int_op op args = - mk_static_exp ~ty:(Tid pint) (Sop (op,args)) + mk_static_exp ~ty:tint (Sop (op,args)) let mk_static_int i = - mk_static_exp ~ty:(Tid pint) (Sint i) + mk_static_exp ~ty:tint (Sint i) let mk_static_bool b = - mk_static_exp ~ty:(Tid pbool) (Sbool b) + mk_static_exp ~ty:tbool (Sbool b) (* build the initial environment *) -let initialize modname = - Modules.initialize modname; +let initialize modul = + Modules.initialize modul; List.iter (fun (f, ty) -> Modules.add_type f ty) tglobal; List.iter (fun (f, ty) -> Modules.add_constrs f ty) cglobal diff --git a/compiler/global/modules.ml b/compiler/global/modules.ml index c132353..6273f84 100644 --- a/compiler/global/modules.ml +++ b/compiler/global/modules.ml @@ -23,7 +23,7 @@ exception Already_defined interface_format_version in signature.ml should be incremented. *) (** Object serialized in compiled interfaces. *) type module_object = - { m_name : string; + { m_name : Names.modul; m_values : node NamesEnv.t; m_types : type_def NamesEnv.t; m_consts : const_def NamesEnv.t; @@ -33,11 +33,11 @@ type module_object = type env = { (** Current module name *) - mutable current_mod : module_name; + mutable current_mod : modul; (** Modules opened and loaded into the env *) - mutable opened_mod : module_name list; + mutable opened_mod : modul list; (** Modules loaded into the env *) - mutable loaded_mod : module_name list; + mutable loaded_mod : modul list; (** Node definitions *) mutable values : node QualEnv.t; (** Type definitions *) @@ -53,12 +53,12 @@ type env = { (** The global environnement *) let g_env = - { current_mod = ""; + { current_mod = Module ""; opened_mod = []; loaded_mod = []; values = QualEnv.empty; types = QualEnv.empty; - constrs = QualEnv.empty; + constrs = QualEnv.empty; fields = QualEnv.empty; consts = QualEnv.empty; format_version = interface_format_version } @@ -86,23 +86,28 @@ let _append_module mo = g_env.fields <- QualEnv.append (qualify_all mo.m_fields) g_env.fields; g_env.consts <- QualEnv.append (qualify mo.m_consts) g_env.consts -(** Load a module into the global environnement unless already loaded *) -let _load_module modname = - if is_loaded modname then () +(** Load a module into the global environment unless already loaded *) +let _load_module modul = + if is_loaded modul then () else + 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 + in let name = String.uncapitalize modname in try let filename = Compiler_utils.findfile (name ^ ".epci") in let ic = open_in_bin filename in let mo:module_object = - try - input_value ic - with - | End_of_file | Failure _ -> - close_in ic; - Format.eprintf "Corrupted compiled interface file %s.@\n\ - Please recompile %s.ept first.@." filename name; - raise Errors.Error in + try input_value ic + with End_of_file | Failure _ -> + close_in ic; + Format.eprintf "Corrupted compiled interface file %s.@\n\ + Please recompile %s.ept first.@." filename name; + raise Errors.Error + in if mo.m_format_version <> interface_format_version then ( Format.eprintf "The file %s was compiled with an older version \ @@ -118,20 +123,20 @@ let _load_module modname = (** Opens a module unless already opened - by loading it into the global environnement and seting it as opened *) -let open_module modname = - if is_opened modname then () + by loading it into the global environment and setting it as opened *) +let open_module modul = + if is_opened modul then () else - _load_module modname; - g_env.opened_mod <- modname::g_env.opened_mod + _load_module modul; + g_env.opened_mod <- modul::g_env.opened_mod -(** Initialize the global environnement : +(** Initialize the global environment : set current module and open default modules *) -let initialize modname = - g_env.current_mod <- modname; +let initialize modul = + g_env.current_mod <- modul; g_env.opened_mod <- []; - g_env.loaded_mod <- [modname]; + g_env.loaded_mod <- [modul]; List.iter open_module !default_used_modules @@ -160,7 +165,7 @@ let add_const f v = let replace_value f v = g_env.values <- QualEnv.add f v g_env.values -(** { 3 Find functions look in the global environnement, nothing more } *) +(** { 3 Find functions look in the global environement, nothing more } *) let find_value x = QualEnv.find x g_env.values let find_type x = QualEnv.find x g_env.types @@ -286,6 +291,7 @@ let rec unalias_type t = match t with with Not_found -> raise (Undefined_type ty_name)) | Tarray (ty, n) -> Tarray(unalias_type ty, n) | Tprod ty_list -> Tprod (List.map unalias_type ty_list) + | Tmutable t -> Tmutable (unalias_type t) | Tunit -> Tunit diff --git a/compiler/global/names.ml b/compiler/global/names.ml index 2fe3877..3f64dab 100644 --- a/compiler/global/names.ml +++ b/compiler/global/names.ml @@ -3,25 +3,38 @@ [fullname] longname -> Module.name *) type name = string +type module_name = name -and qualname = { qual: string; name: string } +type modul = + | Pervasives + | LocalModule + | Module of module_name + | QualModule of qualname + +and qualname = { qual: modul; name: name } type type_name = qualname type fun_name = qualname type field_name = qualname type constructor_name = qualname type constant_name = qualname -type module_name = name -let local_qualname = "$$%local_current_illegal_module_name%$$" -let local_qn name = { qual = local_qualname; name = name } +let pervasives_qn name = { qual = Pervasives; name = name } + +let local_qn name = { qual = LocalModule; name = name } + module NamesEnv = struct include (Map.Make(struct type t = name let compare = compare end)) let append env0 env = fold (fun key v env -> add key v env) env0 env end +module ModulEnv = struct + include (Map.Make(struct type t = modul let compare = compare end)) + let append env0 env = fold (fun key v env -> add key v env) env0 env +end + module QualEnv = struct include (Map.Make(struct type t = qualname let compare = compare end)) @@ -30,21 +43,37 @@ module QualEnv = struct 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 -let fullname { qual = qual; name = n; } = qual ^ "." ^ n +let modul { qual = m; } = m + +let rec modul_to_string m = match m with + | Pervasives -> "Pervasives" + | LocalModule -> "\#$%@#_LOCAL_MODULE" + | Module n -> n + | QualModule {qual = q; name = n} -> (modul_to_string q) ^"."^ n + +let fullname {qual = q; name = n} = modul_to_string q ^ "." ^ n + +let rec modul_of_string_list = function + | [] -> LocalModule + | ["Pervasives"] -> Pervasives + | [q] -> Module q + | q::q_l -> QualModule {qual = modul_of_string_list q_l; name = q} let qualname_of_string s = - try - let ind = String.index s '.' in - if ind = 0 || ind = String.length s - 1 - then invalid_arg "mk_longname: ill-formed identifier"; - let n = String.sub s (ind + 1) (String.length s - ind - 1) in - { qual = String.sub s 0 ind; name = n; } - with Not_found -> { qual = ""; name = s } + let q_l_n = Misc.split_string s "." in + match List.rev q_l_n with + | [] -> Misc.internal_error "Names" 0 + | n::q_l -> { qual = modul_of_string_list q_l; name = n } + +let modul_of_string s = + let q_l = Misc.split_string s "." in + modul_of_string_list (List.rev q_l) (** Are infix [or], [quo], [mod], [land], [lor], [lxor], [lsl], [lsr], [asr] @@ -57,7 +86,7 @@ let is_infix s = StrSet.empty in if StrSet.mem s infix_set then true else (match String.get s 0 with - | 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> false + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' | '~' -> false | _ -> true) open Format @@ -69,13 +98,6 @@ let print_name ff n = else n in fprintf ff "%s" n -let print_raw_qualname ff {qual = q; name = n} = - fprintf ff "%s.%a" q print_name n - -let opname qn = match qn with - | { qual = "Pervasives"; name = m; } -> m - | { qual = qual; name = n; } -> qual ^ "." ^ n - (** Use a printer to generate a string compatible with a name *) let print_pp_to_name p x = Misc.sanitize_string (Misc.print_pp_to_string p x) diff --git a/compiler/global/signature.ml b/compiler/global/signature.ml index 7adedc9..f3a6e41 100644 --- a/compiler/global/signature.ml +++ b/compiler/global/signature.ml @@ -30,7 +30,7 @@ type size_constraint = type node = { node_inputs : arg list; node_outputs : arg list; - node_statefull : bool; + node_stateful : bool; node_params : param list; node_params_constraints : size_constraint list } @@ -58,10 +58,10 @@ 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 statefull params = +let mk_node ?(constraints = []) ins outs stateful params = { node_inputs = ins; node_outputs = outs; - node_statefull = statefull; + node_stateful = stateful; node_params = params; node_params_constraints = constraints } diff --git a/compiler/global/static.ml b/compiler/global/static.ml index 6886e72..b099779 100644 --- a/compiler/global/static.ml +++ b/compiler/global/static.ml @@ -17,90 +17,133 @@ open Format open Types open Signature open Modules +open Location -(* unsatisfiable constraint *) -exception Instanciation_failed -exception Partial_instanciation of static_exp exception Not_static -let partial_apply_op op se_list = + + +(** Some evaluations are not possible *) +type eval_error = Division_by_zero +exception Evaluation_failed of eval_error * location + +(** Some unknown operators could be used preventing the evaluation *) +type partial_eval_cause = Unknown_op of fun_name | Unknown_param of qualname +exception Partial_evaluation of partial_eval_cause * location + +let message exn = + begin match exn with + | Evaluation_failed (e,loc) -> + (match e with + | Division_by_zero -> + eprintf "%aForbidden division by 0.@." + print_location loc + ) + | Partial_evaluation (e,loc) -> + (match e with + | Unknown_op op -> + eprintf "%aUnknown operator %a.@." + Location.print_location loc + Global_printer.print_qualname op + | Unknown_param q -> + eprintf "%aUninstanciated param %a.@." + Location.print_location loc + Global_printer.print_qualname q + ) + | _ -> raise exn + end; + raise Errors.Error + + + +(** When not [partial], + @raise Partial_evaluation when the application of the operator can't be evaluated (only Unknown_op). + 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 = "+" } -> + | { qual = Pervasives; name = "+" } -> Sint (n1 + n2) - | { qual = "Pervasives"; name = "-" } -> + | { qual = Pervasives; name = "-" } -> Sint (n1 - n2) - | { qual = "Pervasives"; name = "*" } -> + | { qual = Pervasives; name = "*" } -> Sint (n1 * n2) - | { qual = "Pervasives"; name = "/" } -> - let n = if n2 = 0 then raise Instanciation_failed else n1 / n2 in - Sint n - | { qual = "Pervasives"; name = "=" } -> + | { 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) + | { qual = Pervasives; name = "~-" } -> Sint (-n) | _ -> assert false (*TODO: add missing operators*) ) - | _ -> Sop(op, se_list) + | _ -> if partial then Sop(op, se_list) (* partial evaluation *) + else raise (Partial_evaluation (Unknown_op op, loc)) -let apply_op op se_list = - let se = partial_apply_op op se_list in - match se with - | Sop _ -> raise Not_found - | _ -> se -let eval_core eval apply_op env se = match se.se_desc with +(** When not [partial], + @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 _ | Sconstructor _ | Sfield _ -> se - | Svar ln -> ( - try (* first try to find in global const env *) - let cd = find_const ln in - eval env cd.c_value - with Not_found -> (* then try to find in local env *) - eval env (QualEnv.find ln env)) + | Svar ln -> + (try (* first try to find in global const env *) + let cd = find_const ln in + eval_core partial env cd.c_value + with Not_found -> (* then try to find in local env *) + (try + let se = QualEnv.find ln env in + (match se.se_desc with + | Svar ln' when ln'=ln -> (* prevent basic infinite loop *) + if partial then se else raise Not_found + | _ -> eval_core partial env se + ) + with Not_found -> (* Could not evaluate the var *) + if partial then se + else raise (Partial_evaluation (Unknown_param ln, se.se_loc)) + ) + ) | Sop (op, se_list) -> - let se_list = List.map (eval env) se_list in - { se with se_desc = apply_op op se_list } + let se_list = List.map (eval_core partial env) se_list in + let se_desc = apply_op partial se.se_loc op se_list in + { se with se_desc = se_desc } | Sarray se_list -> - { se with se_desc = Sarray (List.map (eval env) se_list) } + { se with se_desc = Sarray (List.map (eval_core partial env) se_list) } | Sarray_power (se, n) -> - { se with se_desc = Sarray_power (eval env se, eval env n) } + { se with se_desc = Sarray_power (eval_core partial env se, eval_core partial env n) } | Stuple se_list -> - { se with se_desc = Stuple (List.map (eval env) se_list) } + { se with se_desc = Stuple (List.map (eval_core partial env) se_list) } | Srecord f_se_list -> { se with se_desc = Srecord - (List.map (fun (f,se) -> f, eval env se) f_se_list) } + (List.map (fun (f,se) -> f, eval_core partial env se) f_se_list) } + (** [simplify env e] returns e simplified with the variables values taken from [env] or from the global env with [find_const]. Every operator that can be computed is. It can return static_exp with uninstanciated variables.*) -let rec simplify env se = - try eval_core simplify partial_apply_op env se - with _ -> se +let simplify env se = + try eval_core true env se + with exn -> message exn (** [eval env e] does the same as [simplify] but if it returns, there are no variables nor op left. - @raise [Partial_instanciation] when it cannot fully evaluate *) -let rec eval env se = - try eval_core eval apply_op env se - with Not_found -> raise (Partial_instanciation se) + @raise [Errors.Error] when it cannot fully evaluate. *) +let eval env se = + try eval_core false env se + with exn -> message exn (** [int_of_static_exp env e] returns the value of the expression - [e] in the environment [env], mapping vars to integers. Raises - Instanciation_failed if it cannot be computed (if a var has no value).*) -let int_of_static_exp env se = - match (simplify env se).se_desc with - | Sint i -> i - | _ -> - (Format.eprintf "Internal compiler error, \ - [eval_int] received the static_exp %a.@." - Global_printer.print_static_exp se; - assert false) + [e] in the environment [env], mapping vars to integers. + @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 (** [is_true env constr] returns whether the constraint is satisfied in the environment (or None if this can be decided) diff --git a/compiler/global/types.ml b/compiler/global/types.ml index d23b0a9..a5a4545 100644 --- a/compiler/global/types.ml +++ b/compiler/global/types.ml @@ -11,6 +11,7 @@ open Names open Misc open Location + type static_exp = { se_desc: static_exp_desc; se_ty: ty; se_loc: location } and static_exp_desc = @@ -27,18 +28,23 @@ and static_exp_desc = | Sop of fun_name * static_exp list (** defined ops for now in pervasives *) and ty = - | Tprod of ty list - | Tid of type_name - | Tarray of ty * static_exp + | Tprod of ty list (** Product type used for tuples *) + | Tid of type_name (** Usable type_name are alias or pervasives {bool,int,float} (see [Initial]) *) + | Tarray of ty * static_exp (** [base_type] * [size] *) (* TODO obc : array of prod ?? nonono *) + | Tmutable of ty (* TODO obc : do not hack it here *) | Tunit -let invalid_type = Tprod [] +let invalid_type = Tprod [] (** Invalid type given to untyped expression etc. *) let prod = function | [] -> Tunit | [ty] -> ty | ty_list -> Tprod ty_list +let unprod = function + | Tprod l -> l + | t -> [t] + (** DO NOT use this after the typing, since it could give invalid_type *) let mk_static_exp ?(loc = no_location) ?(ty = invalid_type) desc = diff --git a/compiler/heptagon/analysis/causality.ml b/compiler/heptagon/analysis/causality.ml index 289b470..f4582d1 100644 --- a/compiler/heptagon/analysis/causality.ml +++ b/compiler/heptagon/analysis/causality.ml @@ -106,8 +106,8 @@ let rec typing e = | Estruct(l) -> let l = List.map (fun (_, e) -> typing e) l in candlist l - | Eiterator (_, _, _, e_list, _) -> - ctuplelist (List.map typing e_list) + | Eiterator (_, _, _, pe_list, e_list, _) -> + ctuplelist (List.map typing (pe_list@e_list)) | Ewhen (e, c, ce) -> let t = typing e in let tc = typing ce in diff --git a/compiler/heptagon/analysis/initialization.ml b/compiler/heptagon/analysis/initialization.ml index 159b2ba..9232a1f 100644 --- a/compiler/heptagon/analysis/initialization.ml +++ b/compiler/heptagon/analysis/initialization.ml @@ -246,7 +246,8 @@ let rec typing h e = List.fold_left (fun acc (_, e) -> imax acc (itype (typing h e))) izero l in skeleton i e.e_ty - | Eiterator (_, _, _, e_list, _) -> + | Eiterator (_, _, _, pe_list, e_list, _) -> + List.iter (fun e -> initialized_exp h e) pe_list; List.iter (fun e -> initialized_exp h e) e_list; skeleton izero e.e_ty | Ewhen (e, _, ce) -> diff --git a/compiler/heptagon/analysis/statefull.ml b/compiler/heptagon/analysis/statefull.ml index a862492..6080539 100644 --- a/compiler/heptagon/analysis/statefull.ml +++ b/compiler/heptagon/analysis/statefull.ml @@ -6,7 +6,7 @@ (* Organization : Demons, LRI, University of Paris-Sud, Orsay *) (* *) (**************************************************************************) -(* Checks that a node declared stateless is stateless *) +(* Checks that a node declared stateless is stateless, and set possible nodes as stateless. *) open Names open Location open Signature @@ -21,7 +21,7 @@ type error = let message loc kind = begin match kind with | Eshould_be_a_node -> - Format.eprintf "%aThis node is statefull \ + Format.eprintf "%aThis node is stateful \ but was declared stateless.@." print_location loc | Eexp_should_be_stateless -> @@ -30,54 +30,73 @@ let message loc kind = end; raise Errors.Error -(** @returns whether the exp is statefull. Replaces node calls with +let last _ stateful l = match l with + | Var -> l, stateful + | Last _ -> l, true + +(** @returns whether the exp is stateful. Replaces node calls with the correct Efun or Enode depending on the node signature. *) -let edesc funs statefull ed = - (* do the recursion on function args *) - let ed, statefull = Hept_mapfold.edesc funs statefull ed in +let edesc funs stateful ed = + let ed, stateful = Hept_mapfold.edesc funs stateful ed in match ed with | Efby _ | Epre _ -> ed, true | Eapp({ a_op = Earrow }, _, _) -> ed, true | Eapp({ a_op = (Enode f | Efun f) } as app, e_list, r) -> let ty_desc = find_value f in - let op = if ty_desc.node_statefull then Enode f else Efun f in - Eapp({ app with a_op = op }, e_list, r), - ty_desc.node_statefull or statefull - | _ -> ed, statefull + let op = if ty_desc.node_stateful then Enode f else Efun f in + Eapp({ app with a_op = op }, e_list, r), ty_desc.node_stateful or stateful + | _ -> ed, stateful + +let eqdesc funs acc eqd = + let eqd, _ = Hept_mapfold.eqdesc funs acc eqd in + match eqd with + | Eautomaton st_h_l -> + let st_h_l, _ = Misc.mapfold (state_handler_it funs) acc st_h_l in + Eautomaton st_h_l, true + | _ -> raise Errors.Fallback let eq funs acc eq = - let eq, statefull = Hept_mapfold.eq funs acc eq in - { eq with eq_statefull = statefull }, statefull + let eq, stateful = Hept_mapfold.eq funs acc eq in + { eq with eq_stateful = stateful }, stateful let block funs acc b = - let b, statefull = Hept_mapfold.block funs false b in - { b with b_statefull = statefull }, acc or statefull + let b, stateful = Hept_mapfold.block funs false b in + { b with b_stateful = stateful }, acc or stateful +(** Strong preemption should be decided with stateless expressions *) let escape_unless funs acc esc = - let esc, statefull = Hept_mapfold.escape funs false esc in - if statefull then + let esc, stateful = Hept_mapfold.escape funs false esc in + if stateful then message esc.e_cond.e_loc Eexp_should_be_stateless; - esc, acc or statefull + esc, acc or stateful +(** Present conditions should be stateless *) let present_handler funs acc ph = - let p_cond, statefull = Hept_mapfold.exp_it funs false ph.p_cond in - if statefull then + let p_cond, stateful = Hept_mapfold.exp_it funs false ph.p_cond in + if stateful then message ph.p_cond.e_loc Eexp_should_be_stateless; let p_block, acc = Hept_mapfold.block_it funs acc ph.p_block in { ph with p_cond = p_cond; p_block = p_block }, acc + +(** Funs with states are rejected, nodes without state are set as funs *) let node_dec funs _ n = Idents.enter_node n.n_name; - let n, statefull = Hept_mapfold.node_dec funs false n in - if statefull & not (n.n_statefull) then - message n.n_loc Eshould_be_a_node; - n, false + let n, stateful = Hept_mapfold.node_dec funs false n in + if stateful & (not n.n_stateful) then message n.n_loc Eshould_be_a_node; + if not stateful & n.n_stateful (* update the global env if stateful is not necessary *) + then Modules.replace_value n.n_name { (Modules.find_value n.n_name) with Signature.node_stateful = false }; + { n with n_stateful = stateful }, false (* set stateful only if needed *) + let program p = let funs = - { Hept_mapfold.defaults with edesc = edesc; + { Hept_mapfold.defaults with + edesc = edesc; escape_unless = escape_unless; present_handler = present_handler; + eqdesc = eqdesc; + last = last; eq = eq; block = block; node_dec = node_dec } in let p, _ = Hept_mapfold.program_it funs false p in p diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 9115bea..d7d0d04 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -223,7 +223,7 @@ let unify t1 t2 = let kind f ty_desc = let ty_of_arg v = v.a_type in - let op = if ty_desc.node_statefull then Enode f else Efun f in + let op = if ty_desc.node_stateful then Enode f else Efun f in op, List.map ty_of_arg ty_desc.node_inputs, List.map ty_of_arg ty_desc.node_outputs @@ -250,6 +250,7 @@ let build_subst names values = let rec subst_type_vars m = function | Tarray(ty, e) -> Tarray(subst_type_vars m ty, simplify m e) | Tprod l -> Tprod (List.map (subst_type_vars m) l) + | Tmutable t -> Tmutable (subst_type_vars m t) | t -> t let add_distinct_env id ty env = @@ -384,6 +385,8 @@ let rec check_type const_env = function | Tid ty_name -> Tid ty_name (* TODO bug ? should check that ty_name exists ? *) | Tprod l -> Tprod (List.map (check_type const_env) l) + | Tmutable t -> + Tmutable (check_type const_env t) | Tunit -> Tunit and typing_static_exp const_env se = @@ -519,7 +522,7 @@ let rec typing const_env h e = | Eiterator (it, ({ a_op = (Enode f | Efun f); a_params = params } as app), - n, e_list, reset) -> + n, pe_list, e_list, reset) -> let ty_desc = find_value f in let op, expected_ty_list, result_ty_list = kind f ty_desc in let node_params = @@ -529,6 +532,11 @@ let rec typing const_env h e = 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 + (*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 + (*typing of other arguments*) let ty, typed_e_list = typing_iterator const_env h it n expected_ty_list result_ty_list e_list in let typed_params = typing_node_params const_env @@ -540,7 +548,7 @@ let rec typing const_env h e = List.iter add_size_constraint size_constrs; (* return the type *) Eiterator(it, { app with a_op = op; a_params = typed_params } - , typed_n, typed_e_list, reset), ty + , typed_n, typed_pe_list, typed_e_list, reset), ty | Eiterator _ -> assert false | Ewhen (e, c, ce) -> @@ -628,18 +636,14 @@ and typing_app const_env h app e_list = | (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 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 const_env 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 + 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; prod result_ty_list, { app with a_op = op; a_params = typed_params }, @@ -741,6 +745,8 @@ and typing_app const_env h app e_list = mk_static_int_op (mk_pervasives "+") [array_size t1; array_size t2] in Tarray (element_type t1, n), app, [typed_e1; typed_e2] + + and typing_iterator const_env h it n args_ty_list result_ty_list e_list = match it with | Imap -> @@ -831,6 +837,7 @@ and typing_node_params const_env params_sig params = List.map2 (fun p_sig p -> expect_static_exp const_env p_sig.p_type p) params_sig params + let rec typing_pat h acc = function | Evarpat(x) -> let ty = typ_of_name h x in diff --git a/compiler/heptagon/hept_mapfold.ml b/compiler/heptagon/hept_mapfold.ml index 3d730ea..be29712 100644 --- a/compiler/heptagon/hept_mapfold.ml +++ b/compiler/heptagon/hept_mapfold.ml @@ -54,46 +54,25 @@ open Global_mapfold open Heptagon type 'a hept_it_funs = { - app: - 'a hept_it_funs -> 'a -> Heptagon.app -> Heptagon.app * 'a; - block: - 'a hept_it_funs -> 'a -> Heptagon.block -> Heptagon.block * 'a; - edesc: - 'a hept_it_funs -> 'a -> Heptagon.desc -> Heptagon.desc * 'a; - eq: - 'a hept_it_funs -> 'a -> Heptagon.eq -> Heptagon.eq * 'a; - eqdesc: - 'a hept_it_funs -> 'a -> Heptagon.eqdesc -> Heptagon.eqdesc * 'a; - escape_unless : - 'a hept_it_funs -> 'a -> Heptagon.escape -> Heptagon.escape * 'a; - escape_until: - 'a hept_it_funs -> 'a -> Heptagon.escape -> Heptagon.escape * 'a; - exp: - 'a hept_it_funs -> 'a -> Heptagon.exp -> Heptagon.exp * 'a; - pat: - 'a hept_it_funs -> 'a -> pat -> Heptagon.pat * 'a; - present_handler: - 'a hept_it_funs -> 'a -> Heptagon.present_handler - -> Heptagon.present_handler * 'a; - state_handler: - 'a hept_it_funs -> 'a -> Heptagon.state_handler - -> Heptagon.state_handler * 'a; - switch_handler: - 'a hept_it_funs -> 'a -> Heptagon.switch_handler - -> Heptagon.switch_handler * 'a; - var_dec: - 'a hept_it_funs -> 'a -> Heptagon.var_dec -> Heptagon.var_dec * 'a; - last: - 'a hept_it_funs -> 'a -> Heptagon.last -> Heptagon.last * 'a; - contract: - 'a hept_it_funs -> 'a -> Heptagon.contract -> Heptagon.contract * 'a; - node_dec: - 'a hept_it_funs -> 'a -> Heptagon.node_dec -> Heptagon.node_dec * 'a; - const_dec: - 'a hept_it_funs -> 'a -> Heptagon.const_dec -> Heptagon.const_dec * 'a; - program: - 'a hept_it_funs -> 'a -> Heptagon.program -> Heptagon.program * 'a; - global_funs: 'a Global_mapfold.global_it_funs } + app : 'a hept_it_funs -> 'a -> app -> app * 'a; + block : 'a hept_it_funs -> 'a -> block -> block * 'a; + edesc : 'a hept_it_funs -> 'a -> desc -> desc * '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; + 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; + program : 'a hept_it_funs -> 'a -> program -> program * 'a; + global_funs : 'a Global_mapfold.global_it_funs } let rec exp_it funs acc e = funs.exp funs acc e @@ -129,12 +108,13 @@ and edesc funs acc ed = match ed with let args, acc = mapfold (exp_it funs) acc args in let reset, acc = optional_wacc (exp_it funs) acc reset in Eapp (app, args, reset), acc - | Eiterator (i, app, param, args, reset) -> + | Eiterator (i, app, param, pargs, args, reset) -> let app, acc = app_it funs acc app in let param, acc = static_exp_it funs.global_funs acc param in + let pargs, acc = mapfold (exp_it funs) acc pargs in let args, acc = mapfold (exp_it funs) acc args in let reset, acc = optional_wacc (exp_it funs) acc reset in - Eiterator (i, app, param, args, reset), acc + Eiterator (i, app, param, pargs, args, reset), acc | Ewhen (e, c, n) -> let e, acc = exp_it funs acc e in Ewhen (e, c, n), acc @@ -199,7 +179,7 @@ and eqdesc funs acc eqd = match eqd with and block_it funs acc b = funs.block funs acc b and block funs acc b = - (* defnames ty ?? *) + (* TODO defnames ty ?? *) let b_local, acc = mapfold (var_dec_it funs) acc b.b_local in let b_equs, acc = mapfold (eq_it funs) acc b.b_equs in { b with b_local = b_local; b_equs = b_equs }, acc @@ -237,7 +217,7 @@ and present_handler funs acc ph = and var_dec_it funs acc vd = funs.var_dec funs acc vd and var_dec funs acc vd = - (* v_type ??? *) + (* TODO v_type ??? *) let v_last, acc = last_it funs acc vd.v_last in { vd with v_last = v_last }, acc diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index 1af1988..7674de6 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -105,11 +105,12 @@ and print_exp_desc ff = function print_app (app, args) print_every reset | Estruct(f_e_list) -> print_record (print_couple print_qualname print_exp """ = """) ff f_e_list - | Eiterator (it, f, param, args, reset) -> - fprintf ff "@[<2>(%s (%a)<<%a>>)@,%a@]%a" + | Eiterator (it, f, param, pargs, args, reset) -> + fprintf ff "@[<2>(%s (%a)<<%a>>)@,(%a)%a@]%a" (iterator_to_string it) print_app (f, []) print_static_exp param + print_exp_tuple pargs print_exp_tuple args print_every reset | Ewhen (e, c, ec) -> @@ -128,54 +129,55 @@ and print_tag_e_list ff tag_e_list = and print_every ff reset = print_opt (fun ff id -> fprintf ff " every %a" print_exp id) 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@]" - print_qualname f print_params app.a_params print_exp_tuple args - | Eifthenelse -> - let e1, e2, e3 = assert_3 args in - fprintf ff "@[if %a@ then %a@ else %a@]" - print_exp e1 print_exp e2 print_exp e3 - | Efield -> - let r = assert_1 args in - let f = assert_1 app.a_params in - fprintf ff "%a.%a" print_exp r print_static_exp f - | Efield_update -> - let r,e = assert_2 args in - let f = assert_1 app.a_params in - fprintf ff "@[<2>{%a with .%a =@ %a}@]" - print_exp r print_static_exp f print_exp e - | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args - | Earray_fill -> - let e = assert_1 args in - let n = assert_1 app.a_params in - fprintf ff "%a^%a" print_exp e print_static_exp n - | Eselect -> - let e = assert_1 args in - fprintf ff "%a%a" print_exp e print_index app.a_params - | Eselect_slice -> - let e = assert_1 args in - let idx1, idx2 = assert_2 app.a_params in - fprintf ff "%a[%a..%a]" - print_exp e print_static_exp idx1 print_static_exp idx2 - | Eselect_dyn -> - let r, d, e = assert_2min args in - fprintf ff "%a%a default %a" - print_exp r print_dyn_index e print_exp d - | Eupdate -> - let e1, e2, idx = assert_2min args in - fprintf ff "@[<2>(%a with %a =@ %a)@]" - print_exp e1 print_dyn_index idx print_exp e2 - | Econcat -> - let e1, e2 = assert_2 args in - fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2 - | Earrow -> - let e1, e2 = assert_2 args in - fprintf ff "@[<2>%a ->@ %a@]" print_exp e1 print_exp e2 +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@]" + print_qualname f print_params app.a_params print_exp_tuple args + | Eifthenelse -> + let e1, e2, e3 = assert_3 args in + fprintf ff "@[if %a@ then %a@ else %a@]" + print_exp e1 print_exp e2 print_exp e3 + | Efield -> + let r = assert_1 args in + let f = assert_1 app.a_params in + fprintf ff "%a.%a" print_exp r print_static_exp f + | Efield_update -> + let r,e = assert_2 args in + let f = assert_1 app.a_params in + fprintf ff "@[<2>{%a with .%a =@ %a}@]" + print_exp r print_static_exp f print_exp e + | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args + | Earray_fill -> + let e = assert_1 args in + let n = assert_1 app.a_params in + fprintf ff "%a^%a" print_exp e print_static_exp n + | Eselect -> + let e = assert_1 args in + fprintf ff "%a%a" print_exp e print_index app.a_params + | Eselect_slice -> + let e = assert_1 args in + let idx1, idx2 = assert_2 app.a_params in + fprintf ff "%a[%a..%a]" + print_exp e print_static_exp idx1 print_static_exp idx2 + | Eselect_dyn -> + let r, d, e = assert_2min args in + fprintf ff "%a%a default %a" + print_exp r print_dyn_index e print_exp d + | Eupdate -> + let e1, e2, idx = assert_2min args in + fprintf ff "@[<2>(%a with %a =@ %a)@]" + print_exp e1 print_dyn_index idx print_exp e2 + | Econcat -> + let e1, e2 = assert_2 args in + fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2 + | Earrow -> + let e1, e2 = assert_2 args in + fprintf ff "@[<2>%a ->@ %a@]" print_exp e1 print_exp e2 let rec print_eq ff eq = match eq.eq_desc with @@ -281,7 +283,7 @@ let print_node ff (print_local_vars "") nb.b_local print_eq_list nb.b_equs -let print_open_module ff name = fprintf ff "open %a@." print_name name +let print_open_module ff name = fprintf ff "open %s@." (modul_to_string name) let print oc { p_opened = po; p_types = pt; p_nodes = pn; p_consts = pc } = let ff = Format.formatter_of_out_channel oc in diff --git a/compiler/heptagon/heptagon.ml b/compiler/heptagon/heptagon.ml index 8930d05..87a5889 100644 --- a/compiler/heptagon/heptagon.ml +++ b/compiler/heptagon/heptagon.ml @@ -36,7 +36,8 @@ and desc = | Econst of static_exp | Evar of var_ident | Elast of var_ident - | Epre of static_exp option * exp (* the static_exp purpose is the initialization of the mem_var *) + (* the static_exp purpose is the initialization of the mem_var *) + | Epre of static_exp option * exp | Efby of exp * exp | Estruct of (field_name * exp) list | Ewhen of exp * constructor_name * exp @@ -44,7 +45,8 @@ and desc = | Emerge of exp * (constructor_name * exp) list (** merge ident (Constructor -> exp)+ *) | Eapp of app * exp list * exp option - | Eiterator of iterator_type * app * static_exp * exp list * exp option + | Eiterator of iterator_type * app * static_exp + * exp list * exp list * exp option and app = { a_op : op; @@ -74,8 +76,8 @@ and pat = type eq = { eq_desc : eqdesc; - eq_statefull : bool; - eq_loc : location } + eq_stateful : bool; + eq_loc : location; } and eqdesc = | Eautomaton of state_handler list @@ -89,8 +91,8 @@ and block = { b_local : var_dec list; b_equs : eq list; b_defnames : ty Env.t; - b_statefull : bool; - b_loc : location } + b_stateful : bool; + b_loc : location; } and state_handler = { s_state : state_name; @@ -139,7 +141,7 @@ type contract = { type node_dec = { n_name : qualname; - n_statefull : bool; + n_stateful : bool; n_input : var_dec list; n_output : var_dec list; n_contract : contract option; @@ -155,8 +157,8 @@ type const_dec = { c_loc : location } type program = { - p_modname : name; - p_opened : name list; + p_modname : modul; + p_opened : modul list; p_types : type_dec list; p_nodes : node_dec list; p_consts : const_dec list } @@ -164,7 +166,7 @@ type program = { type signature = { sig_name : qualname; sig_inputs : arg list; - sig_statefull : bool; + sig_stateful : bool; sig_outputs : arg list; sig_params : param list; sig_loc : location } @@ -176,7 +178,7 @@ and interface_decl = { interf_loc : location } and interface_desc = - | Iopen of name + | Iopen of modul | Itypedef of type_dec | Iconstdef of const_dec | Isignature of signature @@ -186,25 +188,25 @@ 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_op ?(params=[]) ?(unsafe=false) op = +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_op ~params:params ~unsafe:unsafe op, args, reset) + 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 ?(statefull = true) desc = - { eq_desc = desc; eq_statefull = statefull; eq_loc = no_location; } +let mk_equation ?(stateful = true) desc = + { eq_desc = desc; eq_stateful = stateful; eq_loc = no_location; } let mk_var_dec ?(last = Var) ?(ck = fresh_clock()) name ty = { v_ident = name; v_type = ty; v_clock = ck; v_last = last; v_loc = no_location } -let mk_block ?(statefull = true) ?(defnames = Env.empty) ?(locals = []) eqs = +let mk_block ?(stateful = true) ?(defnames = Env.empty) ?(locals = []) eqs = { b_local = locals; b_equs = eqs; b_defnames = defnames; - b_statefull = statefull; b_loc = no_location } + b_stateful = stateful; b_loc = no_location; } let dfalse = mk_exp (Econst (mk_static_bool false)) (Tid Initial.pbool) @@ -215,15 +217,15 @@ let mk_ifthenelse e1 e2 e3 = { e3 with e_desc = mk_op_app Eifthenelse [e1; e2; e3] } let mk_simple_equation pat e = - mk_equation ~statefull:false (Eeq(pat, e)) + mk_equation ~stateful:false (Eeq(pat, e)) -let mk_switch_equation ?(statefull = true) e l = - mk_equation ~statefull:statefull (Eswitch (e, l)) +let mk_switch_equation ?(stateful = true) e l = + mk_equation ~stateful:stateful (Eswitch (e, l)) -let mk_signature name ins outs statefull params loc = +let mk_signature name ins outs stateful params loc = { sig_name = name; sig_inputs = ins; - sig_statefull = statefull; + sig_stateful = stateful; sig_outputs = outs; sig_params = params; sig_loc = loc } diff --git a/compiler/heptagon/main/hept_parser_scoper.ml b/compiler/heptagon/main/hept_parser_scoper.ml index 013e814..d4cb3fd 100644 --- a/compiler/heptagon/main/hept_parser_scoper.ml +++ b/compiler/heptagon/main/hept_parser_scoper.ml @@ -32,6 +32,7 @@ let parse_program modname lexbuf = let p = do_silent_pass "Parsing" (parse Hept_parser.program) lexbuf in let p = { p with Hept_parsetree.p_modname = modname } in + (* Fuse static exps together *) let p = do_silent_pass "Static Scoping" Hept_static_scoping.program p in @@ -43,6 +44,7 @@ let parse_program modname lexbuf = let parse_interface modname lexbuf = (* Parsing of the file *) let i = do_silent_pass "Parsing" (parse Hept_parser.interface) lexbuf in + (* TODO ? let i = { i with Hept_parsetree.=i_modname = modname } in *) diff --git a/compiler/heptagon/main/heptcheck.ml b/compiler/heptagon/main/heptcheck.ml index 6ca9460..ce15b58 100644 --- a/compiler/heptagon/main/heptcheck.ml +++ b/compiler/heptagon/main/heptcheck.ml @@ -15,7 +15,7 @@ open Hept_compiler open Location -let check_implementation modname filename = +let check_implementation modul filename = (* input and output files *) let source_name = filename ^ ".ept" in @@ -25,11 +25,11 @@ let check_implementation modname filename = in try - Initial.initialize modname; + Initial.initialize modul; add_include (Filename.dirname filename); (* Parsing of the file *) - let p = do_silent_pass "Parsing" (parse_implementation modname) lexbuf in + let p = do_silent_pass "Parsing" (parse_implementation modul) lexbuf in (* Fuse static exps together *) let p = do_silent_pass "Static Scoping" diff --git a/compiler/heptagon/parsing/hept_lexer.mll b/compiler/heptagon/parsing/hept_lexer.mll index 9f035a9..3c8dd74 100644 --- a/compiler/heptagon/parsing/hept_lexer.mll +++ b/compiler/heptagon/parsing/hept_lexer.mll @@ -121,7 +121,9 @@ rule token = parse | [' ' '\t'] + { token lexbuf } | "." {DOT} | "(" {LPAREN} + | "((" {LPARENLPAREN} | ")" {RPAREN} + | "))" {RPARENRPAREN} | "*" { STAR } | "{" {LBRACE} | "}" {RBRACE} diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index a849c22..8ccf3ff 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 RPAREN LBRACE RBRACE COLON SEMICOL +%token DOT LPAREN LPARENLPAREN RPAREN RPARENRPAREN LBRACE RBRACE COLON SEMICOL %token EQUAL EQUALEQUAL LESS_GREATER BARBAR COMMA BAR ARROW LET TEL %token Constructor %token IDENT @@ -58,7 +58,6 @@ open Hept_parsetree %right AROBASE -%nonassoc prec_ident %nonassoc DEFAULT %left ELSE %right ARROW @@ -76,7 +75,7 @@ open Hept_parsetree %right PRE %left POWER %right PREFIX -%left DOT + %start program @@ -94,6 +93,10 @@ slist(S, x) : | {[]} | x=x {[x]} | x=x S r=slist(S,x) {x::r} +/* Separated list with delimiter*/ +delim_slist(S, L, R, x) : + | {[]} + | L l=slist(S, x) R {l} /*Separated Nonempty list */ snlist(S, x) : | x=x {[x]} @@ -125,7 +128,7 @@ pragma_headers: open_modules: | /* empty */ { [] } - | open_modules OPEN Constructor { $3 :: $1 } + | open_modules OPEN modul { $3 :: $1 } ; const_decs: @@ -184,7 +187,7 @@ node_dec: RETURNS LPAREN out_params RPAREN contract b=block(LET) TEL {{ n_name = $2; - n_statefull = $1; + n_stateful = $1; n_input = $5; n_output = $9; n_contract = $11; @@ -309,7 +312,8 @@ sblock(S) : | VAR l=loc_params S eq=equs { mk_block l eq (Loc($startpos,$endpos)) } | eq=equs { mk_block [] eq (Loc($startpos,$endpos)) } -equ: eq=_equ { mk_equation eq (Loc($startpos,$endpos)) } +equ: + | eq=_equ { mk_equation eq (Loc($startpos,$endpos)) } _equ: | pat EQUAL exp { Eeq($1, $3) } | AUTOMATON automaton_handlers END @@ -430,8 +434,6 @@ _simple_exp: Efield [$1] } ; -node_name: - | qualname call_params { mk_app (Enode $1) $2 } merge_handlers: | hs=nonempty_list(merge_handler) { hs } @@ -446,8 +448,9 @@ _exp: { Efby ($1, $3) } | PRE exp { Epre (None, $2) } - | node_name LPAREN exps RPAREN - { Eapp($1, $3) } + /* node call*/ + | n=qualname p=call_params LPAREN args=exps RPAREN + { Eapp(mk_app (Enode n) p , args) } | NOT exp { mk_op_call "not" [$2] } | exp INFIX4 exp @@ -501,11 +504,15 @@ _exp: | exp AROBASE exp { mk_call Econcat [$1; $3] } /*Iterators*/ - | iterator qualname DOUBLE_LESS simple_exp DOUBLE_GREATER LPAREN exps RPAREN - { mk_iterator_call $1 $2 [] $4 $7 } - | iterator LPAREN qualname DOUBLE_LESS array_exp_list DOUBLE_GREATER - RPAREN DOUBLE_LESS simple_exp DOUBLE_GREATER LPAREN exps RPAREN - { mk_iterator_call $1 $3 $5 $9 $12 } + | it=iterator DOUBLE_LESS n=simple_exp DOUBLE_GREATER q=qualname + pargs=delim_slist(COMMA, LPARENLPAREN, RPARENRPAREN, 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, LPARENLPAREN, RPARENRPAREN, exp) + LPAREN args=exps RPAREN + { mk_iterator_call it q sa n pargs args } /*Records operators */ | LBRACE simple_exp WITH DOT c=qualname EQUAL exp RBRACE { mk_call ~params:[mk_field_exp c (Loc($startpos(c),$endpos(c)))] @@ -529,25 +536,32 @@ indexes: | LBRACKET exp RBRACKET indexes { $2::$4 } ; +qualified(X): + | m=modul DOT x=X { Q { qual = m; name = x } } + +modul: + | c=Constructor { Names.Module c } + | m=modul DOT c=Constructor { Names.QualModule { Names.qual = m; Names.name = c} } + constructor: - | Constructor { ToQ $1 } %prec prec_ident - | Constructor DOT Constructor { Q {qual = $1; name = $3} } + | Constructor { ToQ $1 } + | q=qualified(Constructor) { q } ; qualname: - | ident { ToQ $1 } - | Constructor DOT ident { Q {qual = $1; name = $3} } + | i=ident { ToQ i } + | q=qualified(ident) { q } ; -const: c=_const { mk_static_exp c (Loc($startpos,$endpos)) } +const: + | c=_const { mk_static_exp c (Loc($startpos,$endpos)) } _const: - | INT { Sint $1 } - | FLOAT { Sfloat $1 } - | BOOL { Sbool $1 } - | constructor { Sconstructor $1 } - | Constructor DOT ident - { Svar (Q {qual = $1; name = $3}) } + | INT { Sint $1 } + | FLOAT { Sfloat $1 } + | BOOL { Sbool $1 } + | constructor { Sconstructor $1 } + | q=qualified(ident) { Svar q } ; tuple_exp: @@ -604,12 +618,12 @@ interface_decl: _interface_decl: | type_dec { Itypedef $1 } | const_dec { Iconstdef $1 } - | OPEN Constructor { Iopen $2 } + | 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_statefull = $2; + sig_stateful = $2; sig_outputs = $10; sig_params = $4; sig_loc = (Loc($startpos,$endpos)) }) } diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index 106a044..99b6839 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -17,6 +17,8 @@ type var_name = Names.name (** dec_names are locally declared qualified names *) type dec_name = Names.name +type module_name = Names.modul + (** state_names, [automata] translate them in constructors with a fresh type. *) type state_name = Names.name @@ -70,7 +72,7 @@ and edesc = | Efby of exp * exp | Estruct of (qualname * exp) list | Eapp of app * exp list - | Eiterator of iterator_type * app * exp * exp list + | Eiterator of iterator_type * app * exp * exp list * exp list | Ewhen of exp * constructor_name * var_name | Emerge of var_name * (constructor_name * exp) list @@ -160,7 +162,7 @@ type contract = type node_dec = { n_name : dec_name; - n_statefull : bool; + n_stateful : bool; n_input : var_dec list; n_output : var_dec list; n_contract : contract option; @@ -177,7 +179,7 @@ type const_dec = type program = { p_modname : dec_name; p_pragmas : (var_name * string) list; - p_opened : dec_name list; + p_opened : module_name list; p_types : type_dec list; p_nodes : node_dec list; p_consts : const_dec list; } @@ -189,7 +191,7 @@ type arg = type signature = { sig_name : dec_name; sig_inputs : arg list; - sig_statefull : bool; + sig_stateful : bool; sig_outputs : arg list; sig_params : var_dec list; sig_loc : location } @@ -201,7 +203,7 @@ and interface_decl = interf_loc : location } and interface_desc = - | Iopen of dec_name + | Iopen of module_name | Itypedef of type_dec | Iconstdef of const_dec | Isignature of signature @@ -212,17 +214,16 @@ let mk_exp desc ?(ct_annot = Clocks.invalid_clock) loc = { e_desc = desc; e_ct_annot = ct_annot; e_loc = loc } let mk_app op params = - { a_op = op; a_params = params } + { a_op = op; a_params = params; } let mk_call ?(params=[]) op exps = Eapp (mk_app op params, exps) let mk_op_call ?(params=[]) s exps = - mk_call ~params:params - (Efun (Q { Names.qual = "Pervasives"; Names.name = s })) exps + mk_call ~params:params (Efun (Q (Names.pervasives_qn s))) exps -let mk_iterator_call it ln params n exps = - Eiterator (it, mk_app (Enode ln) params, n, exps) +let mk_iterator_call it ln params n pexps exps = + Eiterator (it, mk_app (Enode ln) params, n, pexps, exps) let mk_static_exp desc loc = { se_desc = desc; se_loc = loc } @@ -248,7 +249,7 @@ let mk_var_dec name ty last loc = let mk_block locals eqs loc = { b_local = locals; b_equs = eqs; - b_loc = loc } + b_loc = loc; } let mk_const_dec id ty e loc = { c_name = id; c_type = ty; c_value = e; c_loc = loc } diff --git a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml index 912fefc..afe872f 100644 --- a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml +++ b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml @@ -146,11 +146,12 @@ and edesc funs acc ed = match ed with let app, acc = app_it funs acc app in let args, acc = mapfold (exp_it funs) acc args in Eapp (app, args), acc - | Eiterator (i, app, param, args) -> + | Eiterator (i, app, param, pargs, args) -> let app, acc = app_it funs acc app in let param, acc = exp_it funs acc param in + let pargs, acc = mapfold (exp_it funs) acc pargs in let args, acc = mapfold (exp_it funs) acc args in - Eiterator (i, app, param, args), acc + Eiterator (i, app, param, pargs, args), acc and app_it funs acc a = funs.app funs acc a diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index 9b52935..ca4ccdf 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -172,8 +172,8 @@ let translate_iterator_type = function op (a3) == op (a2,a3) == op (a1,a2,a3) *) let static_app_from_app app args= match app.a_op with - | Efun (Q ({ qual = "Pervasives" } as q)) - | Enode (Q ({ qual = "Pervasives" } as q)) -> + | Efun (Q ({ qual = Pervasives } as q)) + | Enode (Q ({ qual = Pervasives } as q)) -> q, (app.a_params @ args) | _ -> raise Not_static @@ -214,7 +214,8 @@ let rec translate_type loc ty = | Tid ln -> Types.Tid (qualify_type ln) | Tarray (ty, e) -> let ty = translate_type loc ty in - Types.Tarray (ty, expect_static_exp e)) + Types.Tarray (ty, expect_static_exp e) + ) with | ScopingError err -> message loc err @@ -242,18 +243,20 @@ and translate_desc loc env = function List.map (fun (f,e) -> qualify_field f, translate_exp env e) f_e_list in Heptagon.Estruct f_e_list - | Eapp ({ a_op = op; a_params = params }, e_list) -> + | Eapp ({ a_op = op; a_params = params; }, e_list) -> let e_list = List.map (translate_exp env) e_list in let params = List.map (expect_static_exp) params in - let app = Heptagon.mk_op ~params:params (translate_op op) in + let app = Heptagon.mk_app ~params:params (translate_op op) in Heptagon.Eapp (app, e_list, None) - | Eiterator (it, { a_op = op; a_params = params }, n, e_list) -> + + | Eiterator (it, { a_op = op; a_params = params }, n, pe_list, e_list) -> let e_list = List.map (translate_exp env) e_list in + let pe_list = List.map (translate_exp env) pe_list in let n = expect_static_exp n in let params = List.map (expect_static_exp) params in - let app = Heptagon.mk_op ~params:params (translate_op op) in + let app = Heptagon.mk_app ~params:params (translate_op op) in Heptagon.Eiterator (translate_iterator_type it, - app, n, e_list, None) + app, n, pe_list, e_list, None) | Ewhen (e, c, ce) -> let e = translate_exp env e in let c = qualify_constrs c in @@ -269,6 +272,7 @@ and translate_desc loc env = function List.map fun_c_e c_e_list in Heptagon.Emerge (e, c_e_list) + and translate_op = function | Eequal -> Heptagon.Eequal | Earrow -> Heptagon.Earrow @@ -292,8 +296,8 @@ and translate_pat loc env = function let rec translate_eq env eq = { Heptagon.eq_desc = translate_eq_desc eq.eq_loc env eq.eq_desc ; - Heptagon.eq_statefull = false; - Heptagon.eq_loc = eq.eq_loc } + Heptagon.eq_stateful = false; + Heptagon.eq_loc = eq.eq_loc; } and translate_eq_desc loc env = function | Eswitch(e, switch_handlers) -> @@ -322,8 +326,8 @@ and translate_block env b = { Heptagon.b_local = translate_vd_list env b.b_local; Heptagon.b_equs = List.map (translate_eq env) b.b_equs; Heptagon.b_defnames = Env.empty; - Heptagon.b_statefull = false; - Heptagon.b_loc = b.b_loc }, env + Heptagon.b_stateful = false; + Heptagon.b_loc = b.b_loc; }, env and translate_state_handler env sh = let b, env = translate_block env sh.s_block in @@ -398,9 +402,9 @@ let translate_node node = 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 - add_value n (Signature.mk_node i o node.n_statefull p); + add_value n (Signature.mk_node i o node.n_stateful p); { Heptagon.n_name = n; - Heptagon.n_statefull = node.n_statefull; + Heptagon.n_stateful = node.n_stateful; Heptagon.n_input = inputs; Heptagon.n_output = outputs; Heptagon.n_contract = contract; @@ -452,7 +456,7 @@ let translate_program p = let consts = List.map translate_const_dec p.p_consts in let types = List.map translate_typedec p.p_types in let nodes = List.map translate_node p.p_nodes in - { Heptagon.p_modname = p.p_modname; + { Heptagon.p_modname = Names.modul_of_string p.p_modname; Heptagon.p_opened = p.p_opened; Heptagon.p_types = types; Heptagon.p_nodes = nodes; @@ -465,8 +469,8 @@ let translate_signature s = 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 - add_value n (Signature.mk_node i o s.sig_statefull p); - Heptagon.mk_signature n i o s.sig_statefull p s.sig_loc + add_value n (Signature.mk_node i o s.sig_stateful p); + Heptagon.mk_signature n i o s.sig_stateful p 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 e4c9cac..d6f2cc4 100644 --- a/compiler/heptagon/parsing/hept_static_scoping.ml +++ b/compiler/heptagon/parsing/hept_static_scoping.ml @@ -17,8 +17,8 @@ let assert_se e = match e.e_desc with op (a3) == op (a2,a3) == op (a1,a2,a3) *) let static_app_from_app app args = match app.a_op with - | Efun ((Q { Names.qual = "Pervasives" }) as q) - | Enode ((Q { Names.qual = "Pervasives" }) as q) -> + | Efun ((Q { Names.qual = Names.Pervasives }) as q) + | Enode ((Q { Names.qual = Names.Pervasives }) as q) -> q, (app.a_params @ args) | _ -> raise Not_static diff --git a/compiler/heptagon/transformations/every.ml b/compiler/heptagon/transformations/every.ml index d6a6b2c..836f9d9 100644 --- a/compiler/heptagon/transformations/every.ml +++ b/compiler/heptagon/transformations/every.ml @@ -16,11 +16,12 @@ 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.equation_from_exp re in + let re, vre, eqre = Reset.bool_var_from_exp re in Eapp(op, e_list, Some re), (vre::v, eqre::acc_eq_list) - | Eiterator(it, op, n, e_list, Some re) when not (is_var re) -> - let re, vre, eqre = Reset.equation_from_exp re in - Eiterator(it, op, n, 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 + Eiterator(it, op, n, pe_list, e_list, Some re), + (vre::v, eqre::acc_eq_list) | _ -> ed, (v, acc_eq_list) let program p = diff --git a/compiler/heptagon/transformations/inline.ml b/compiler/heptagon/transformations/inline.ml index 972e9e5..e6933ce 100644 --- a/compiler/heptagon/transformations/inline.ml +++ b/compiler/heptagon/transformations/inline.ml @@ -56,7 +56,7 @@ let exp funs (env, newvars, newequs) exp = match exp.e_desc with | Eapp ({ a_op = Enode nn; } as op, argl, rso) when to_be_inlined nn -> let add_reset eq = match rso with | None -> eq - | Some x -> mk_equation ~statefull:false + | Some x -> mk_equation ~stateful:false (Ereset (mk_block [eq], x)) in let ni = mk_unique_node (env nn) in @@ -80,7 +80,7 @@ let exp funs (env, newvars, newequs) exp = match exp.e_desc with fst (Hept_mapfold.node_dec funs () ni) in let mk_input_equ vd e = - mk_equation ~statefull:false (Eeq (Evarpat vd.v_ident, e)) in + mk_equation ~stateful:false (Eeq (Evarpat vd.v_ident, e)) in let mk_output_exp vd = mk_exp (Evar vd.v_ident) vd.v_type in let newvars = ni.n_input @ ni.n_block.b_local @ ni.n_output @ newvars diff --git a/compiler/heptagon/transformations/present.ml b/compiler/heptagon/transformations/present.ml index 1223a56..34e4ba2 100644 --- a/compiler/heptagon/transformations/present.ml +++ b/compiler/heptagon/transformations/present.ml @@ -7,15 +7,16 @@ (* *) (**************************************************************************) (* removing present statements *) + open Heptagon open Hept_mapfold let translate_present_handlers handlers cont = let translate_present_handler { p_cond = e; p_block = b } cont = - let statefull = b.b_statefull or cont.b_statefull in - mk_block ~statefull:statefull ~defnames:b.b_defnames + let stateful = b.b_stateful or cont.b_stateful in + mk_block ~stateful:stateful ~defnames:b.b_defnames [mk_switch_equation - ~statefull:statefull e + ~stateful:stateful e [{ w_name = Initial.ptrue; w_block = b }; { w_name = Initial.pfalse; w_block = cont }]] in let b = List.fold_right translate_present_handler handlers cont in diff --git a/compiler/heptagon/transformations/reset.ml b/compiler/heptagon/transformations/reset.ml index 6e7055e..ec04168 100644 --- a/compiler/heptagon/transformations/reset.ml +++ b/compiler/heptagon/transformations/reset.ml @@ -8,7 +8,7 @@ (**************************************************************************) (* removing reset statements *) -(* REQUIRES automaton switch statefull present *) +(* REQUIRES automaton switch stateful present *) open Misc open Idents @@ -23,12 +23,12 @@ open Initial let fresh = Idents.gen_fresh "reset" (fun () -> "r") -(* get e and return x, var_dec_x, x = e *) -let equation_from_exp e = - let n = fresh() in - { e with e_desc = Evar n }, mk_var_dec n (Tid Initial.pbool), mk_equation (Eeq(Evarpat n, e)) - +(* get e and return r, var_dec_r, r = e *) +let bool_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)) +(** Merge two reset conditions *) let merge_resets res1 res2 = let mk_or e1 e2 = mk_op_app (Efun Initial.por) [e1;e2] in match res1, res2 with @@ -66,15 +66,15 @@ let edesc funs (res,s) ed = ifres res e1 e2 | Eapp({ a_op = Enode _ } as op, e_list, re) -> Eapp(op, e_list, merge_resets res re) - | Eiterator(it, ({ a_op = Enode _ } as op), n, e_list, re) -> - Eiterator(it, op, n, e_list, merge_resets res re) + | 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) | _ -> ed in ed, (res,s) -let eq funs (res,_) eq = Hept_mapfold.eq funs (res,eq.eq_statefull) eq +let eq funs (res,_) eq = Hept_mapfold.eq funs (res,eq.eq_stateful) eq (* Transform reset blocks in blocks with reseted exps, create a var to store the reset condition evaluation. *) let eqdesc funs (res,stateful) = function @@ -82,10 +82,10 @@ let eqdesc funs (res,stateful) = function if stateful then ( let e, _ = Hept_mapfold.exp_it funs (res,true) e in - let e, vd, eq = equation_from_exp e in + let e, vd, eq = bool_var_from_exp e in let r = merge_resets res (Some e) in let b, _ = Hept_mapfold.block_it funs (r,true) b in - let b = { b with b_equs = eq::b.b_equs; b_local = vd::b.b_local; b_statefull = true } in + let b = { b with b_equs = eq::b.b_equs; b_local = vd::b.b_local; b_stateful = true } in Eblock(b), (res,true)) else ( let b, _ = Hept_mapfold.block_it funs (res,false) b in diff --git a/compiler/heptagon/transformations/switch.ml b/compiler/heptagon/transformations/switch.ml index 2523432..a2ae409 100644 --- a/compiler/heptagon/transformations/switch.ml +++ b/compiler/heptagon/transformations/switch.ml @@ -155,11 +155,11 @@ let exp funs (env,h) e = | Evar _ -> Env.sample_var e env, (env,h) | _ -> Hept_mapfold.exp funs (env,h) e -(* update statefull and loc *) +(* update stateful and loc *) let eq funs (env,h) eq = let eqd = match eq.eq_desc with - | Eblock b -> (* probably created by eqdesc, so update statefull and loc *) - Eblock { b with b_statefull = eq.eq_statefull; b_loc = eq.eq_loc } + | Eblock b -> (* probably created by eqdesc, so update stateful and loc *) + Eblock { b with b_stateful = eq.eq_stateful; b_loc = eq.eq_loc } | _ -> eq.eq_desc in Hept_mapfold.eq funs (env,h) {eq with eq_desc = eqd} diff --git a/compiler/main/hept2mls.ml b/compiler/main/hept2mls.ml index a2c36ac..2e08119 100644 --- a/compiler/main/hept2mls.ml +++ b/compiler/main/hept2mls.ml @@ -209,8 +209,7 @@ let rec translate_op = function | Heptagon.Econcat -> Econcat | Heptagon.Earray -> Earray | Heptagon.Etuple -> Etuple - | Heptagon.Earrow -> - Error.message no_location Error.Eunsupported_language_construct + | Heptagon.Earrow -> Error.message no_location Error.Eunsupported_language_construct let translate_app app = mk_app ~params:app.Heptagon.a_params @@ -238,10 +237,11 @@ let rec translate env mk_exp ~loc:loc ~ty:ty (Eapp (translate_app app, List.map (translate env) e_list, translate_reset reset)) - | Heptagon.Eiterator(it, app, n, e_list, reset) -> + | Heptagon.Eiterator(it, app, n, pe_list, e_list, reset) -> mk_exp ~loc:loc ~ty:ty (Eiterator (translate_iterator_type it, translate_app app, n, + List.map (translate env) pe_list, List.map (translate env) e_list, translate_reset reset)) | Heptagon.Efby _ @@ -377,7 +377,7 @@ let translate_contract env contract = let node { Heptagon.n_name = n; Heptagon.n_input = i; Heptagon.n_output = o; - Heptagon.n_contract = contract; + Heptagon.n_contract = contract; Heptagon.n_stateful = stateful; Heptagon.n_block = { Heptagon.b_local = v; Heptagon.b_equs = eq_list }; Heptagon.n_loc = loc; Heptagon.n_params = params; @@ -390,10 +390,11 @@ let node translate_eqs env IdentSet.empty (locals, [], []) eq_list in let l_eqs, _ = add_locals IdentSet.empty l_eqs [] s_eqs in { n_name = n; + n_stateful = stateful; n_input = List.map translate_var i; n_output = List.map translate_var o; n_contract = contract; - n_controller_call = ([],[]); + (* n_controller_call = ([],[]); *) n_local = locals; n_equs = l_eqs; n_loc = loc ; diff --git a/compiler/main/heptc.ml b/compiler/main/heptc.ml index e037c6d..33aa914 100644 --- a/compiler/main/heptc.ml +++ b/compiler/main/heptc.ml @@ -72,8 +72,8 @@ let compile_program modname source_f = let compile source_f = let modname = source_f |> Filename.basename |> Filename.chop_extension |> String.capitalize in - - Initial.initialize modname; + let modul = Names.modul_of_string modname in + Initial.initialize modul; source_f |> Filename.dirname |> add_include; match Misc.file_extension source_f with diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index b5f188d..9a97916 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -13,28 +13,36 @@ open Names open Idents open Signature open Obc -open Types -open Control -open Static +open Obc_utils open Obc_mapfold +open Types +open Static open Initial -let fresh_it () = Idents.gen_var "mls2obc" "i" -let gen_obj_name n = - (shortname n) ^ "_mem" ^ (gen_symbol ()) +let fresh_it () = + let id = Idents.gen_var "mls2obc" "i" in + id, mk_var_dec id Initial.tint -let op_from_string op = { qual = "Pervasives"; name = op; } +let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst") -let rec lhs_of_idx_list e = function - | [] -> e | idx :: l -> mk_lhs (Larray (lhs_of_idx_list e l, idx)) +let op_from_string op = { qual = Pervasives; name = op; } + +let rec pattern_of_idx_list p l = + let rec aux ty l = match ty, l with + | _, [] -> p + | Tarray (ty',_), idx :: l -> mk_pattern ty' (Larray (aux ty' l, idx)) + | _ -> internal_error "mls2obc" 1 + in + aux p.pat_ty l let array_elt_of_exp idx e = - match e.e_desc with - | Econst ({ se_desc = Sarray_power (c, _) }) -> - mk_exp (Econst c) - | _ -> - mk_lhs_exp (Larray(lhs_of_exp e, mk_exp (Elhs idx))) + match e.e_desc, Modules.unalias_type e.e_ty with + | Econst ({ se_desc = Sarray_power (c, _) }), Tarray (ty,_) -> + mk_exp ty (Econst c) + | _, Tarray (ty,_) -> + mk_pattern_exp ty (Larray(pattern_of_exp e, mk_exp Initial.tint (Epattern idx))) + | _ -> internal_error "mls2obc" 2 (** Creates the expression that checks that the indices in idx_list are in the bounds. If idx_list=[e1;..;ep] @@ -43,21 +51,17 @@ let array_elt_of_exp idx e = (** TODO: Add check for idx >= 0 *) let rec bound_check_expr idx_list bounds = match (idx_list, bounds) with - | [idx], [n] -> - mk_exp (Eop (op_from_string "<", - [idx; mk_exp (Econst n)])) + | [idx], [n] -> mk_exp_bool (Eop (op_from_string "<", [idx; mk_exp_int (Econst n)])) | (idx :: idx_list, n :: bounds) -> - let e = mk_exp (Eop (op_from_string "<", - [idx; mk_exp (Econst n)])) in - mk_exp (Eop (op_from_string "&", - [e; bound_check_expr idx_list bounds])) - | (_, _) -> assert false + let e = mk_exp_bool (Eop (op_from_string "<", [idx; mk_exp_int (Econst n)])) in + mk_exp_bool (Eop (op_from_string "&", [e; bound_check_expr idx_list bounds])) + | (_, _) -> internal_error "mls2obc" 3 let reinit o = Acall ([], o, Mreset, []) let rec translate_pat map = function - | Minils.Evarpat x -> [ var_from_name map x ] + | Minils.Evarpat x -> [ Control.var_from_name map x ] | Minils.Etuplepat pat_list -> List.fold_right (fun pat acc -> (translate_pat map pat) @ acc) pat_list [] @@ -72,11 +76,10 @@ let translate_var_dec l = let rec translate map e = let desc = match e.Minils.e_desc with | Minils.Econst v -> Econst v - | Minils.Evar n -> Elhs (var_from_name map n) + | Minils.Evar n -> Epattern (Control.var_from_name map n) | Minils.Eapp ({ Minils.a_op = Minils.Eequal }, e_list, _) -> Eop (op_from_string "=", List.map (translate map ) e_list) - | Minils.Eapp ({ Minils.a_op = Minils.Efun n }, - e_list, _) when Mls_utils.is_op n -> + | Minils.Eapp ({ Minils.a_op = Minils.Efun n }, e_list, _) when Mls_utils.is_op n -> Eop (n, List.map (translate map ) e_list) | Minils.Ewhen (e, _, _) -> let e = translate map e in @@ -88,100 +91,97 @@ let rec translate map e = let f_e_list = List.map (fun (f, e) -> (f, (translate map e))) f_e_list in Estruct (type_name, f_e_list) | Minils.Eapp ({ Minils.a_op = Minils.Efield; Minils.a_params = params }, e_list, _) -> - let f = match (assert_1 params).se_desc with Sfield f -> f | _ -> assert false in + let f = match (assert_1 params).se_desc with Sfield f -> f | _ -> internal_error "mls2obc" 4 in let e = translate map (assert_1 e_list) in - Elhs (mk_lhs (Lfield (lhs_of_exp e, f))) + Epattern (mk_pattern e.e_ty (Lfield (pattern_of_exp e, f))) (*Remaining array operators*) | Minils.Eapp ({ Minils.a_op = Minils.Earray }, e_list, _) -> Earray (List.map (translate map ) e_list) | Minils.Eapp ({ Minils.a_op = Minils.Eselect; Minils.a_params = idx }, e_list, _) -> let e = translate map (assert_1 e_list) in - let idx_list = List.map (fun idx -> mk_exp (Econst idx)) idx in - Elhs (lhs_of_idx_list (lhs_of_exp e) idx_list) - | _ -> - Format.eprintf "%a@." Mls_printer.print_exp e; - assert false + let idx_list = List.map (fun idx -> mk_exp tint (Econst idx)) idx in + Epattern (pattern_of_idx_list (pattern_of_exp e) idx_list) + (* Already treated cases when translating the [eq] *) + | Minils.Eiterator _ | Minils.Emerge _ | Minils.Efby _ + | Minils.Eapp ({Minils.a_op=(Minils.Enode _|Minils.Efun _|Minils.Econcat|Minils.Eupdate|Minils.Eselect_dyn + |Minils.Eselect_slice|Minils.Earray_fill|Minils.Efield_update|Minils.Eifthenelse + |Minils.Etuple)}, _, _) -> + (*Format.eprintf "%aThis should not be treated as an exp in mls2obc : %a@." + Location.print_location e.Minils.e_loc Mls_printer.print_exp e; + assert false*) + internal_error "mls2obc" 5 in - mk_exp ~ty:e.Minils.e_ty desc + mk_exp e.Minils.e_ty desc (* [translate pat act = si, d] *) and translate_act map pat ({ Minils.e_desc = desc } as act) = match pat, desc with - | Minils.Etuplepat p_list, - Minils.Eapp ({ Minils.a_op = Minils.Etuple }, act_list, _) -> + | Minils.Etuplepat p_list, Minils.Eapp ({ Minils.a_op = Minils.Etuple }, act_list, _) -> List.flatten (List.map2 (translate_act map) p_list act_list) - | Minils.Etuplepat p_list, - Minils.Econst { se_desc = Stuple se_list } -> + | Minils.Etuplepat p_list, Minils.Econst { se_desc = Stuple se_list } -> let const_list = Mls_utils.exp_list_of_static_exp_list se_list in - List.flatten (List.map2 (translate_act map) p_list const_list) + List.flatten (List.map2 (translate_act map) p_list const_list) + (* When Merge *) | pat, Minils.Ewhen (e, _, _) -> translate_act map pat e | pat, Minils.Emerge (x, c_act_list) -> - let lhs = var_from_name map x in - [Acase (mk_exp (Elhs lhs), - translate_c_act_list map pat c_act_list)] - - | Minils.Evarpat x, - Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) -> - let cpt1 = fresh_it () in - let cpt2 = fresh_it () in - let x = var_from_name map x in + let pattern = Control.var_from_name map x in + [Acase (mk_exp pattern.pat_ty (Epattern pattern), translate_c_act_list map pat c_act_list)] + (* Array ops *) + | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) -> + let cpt1, cpt1d = fresh_it () in + let cpt2, cpt2d = fresh_it () in + let x = Control.var_from_name map x in + let t = x.pat_ty in (match e1.Minils.e_ty, e2.Minils.e_ty with - | Tarray (_, n1), Tarray (_, n2) -> + | Tarray (t1, n1), Tarray (t2, n2) -> let e1 = translate map e1 in let e2 = translate map e2 in let a1 = - Afor (cpt1, mk_static_int 0, n1, - mk_block [Aassgn (mk_lhs (Larray (x, mk_evar cpt1)), - mk_lhs_exp (Larray (lhs_of_exp e1, - mk_evar cpt1)))] ) in - let idx = mk_exp (Eop (op_from_string "+", - [ mk_exp (Econst n1); mk_evar cpt2])) in + Afor (cpt1d, mk_static_int 0, n1, + mk_block [Aassgn (mk_pattern t1 (Larray (x, mk_evar_int cpt1)), + mk_pattern_exp t1 (Larray (pattern_of_exp e1, mk_evar_int cpt1)))] ) in + let idx = mk_exp_int (Eop (op_from_string "+", [ mk_exp_int (Econst n1); mk_evar_int cpt2])) in let a2 = - Afor (cpt2, mk_static_int 0, n2, - mk_block [Aassgn (mk_lhs (Larray (x, idx)), - mk_lhs_exp (Larray (lhs_of_exp e2, - mk_evar cpt2)))] ) + Afor (cpt2d, mk_static_int 0, n2, + mk_block [Aassgn (mk_pattern t2 (Larray (x, idx)), + mk_pattern_exp t2 (Larray (pattern_of_exp e2, mk_evar_int cpt2)))] ) in [a1; a2] | _ -> assert false ) - - | Minils.Evarpat x, - Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; - Minils.a_params = [n] }, [e], _) -> - let cpt = fresh_it () in + | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; Minils.a_params = [n] }, [e], _) -> + let cpt, cptd = fresh_it () in let e = translate map e in - [ Afor (cpt, mk_static_int 0, n, - mk_block [Aassgn (mk_lhs (Larray (var_from_name map x, - mk_evar cpt)), e) ]) ] - - | Minils.Evarpat x, - Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice; - Minils.a_params = [idx1; idx2] }, [e], _) -> - let cpt = fresh_it () in + let x = Control.var_from_name map x in + let t = match x.pat_ty with + | Tarray (t,_) -> t + | _ -> Misc.internal_error "mls2obc select slice type" 5 + in + [ Afor (cptd, mk_static_int 0, n, mk_block [Aassgn (mk_pattern t (Larray (x, mk_evar_int cpt)), e) ]) ] + | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice; Minils.a_params = [idx1; idx2] }, [e], _) -> + let cpt, cptd = fresh_it () in let e = translate map e in - let idx = mk_exp (Eop (op_from_string "+", - [mk_evar cpt; - mk_exp (Econst idx1) ])) in + let x = Control.var_from_name map x in + let t = match x.pat_ty with + | Tarray (t,_) -> t + | _ -> Misc.internal_error "mls2obc select slice type" 5 + in + let idx = mk_exp_int (Eop (op_from_string "+", [mk_evar_int cpt; mk_exp_int (Econst idx1) ])) in (* bound = (idx2 - idx1) + 1*) let bound = mk_static_int_op (op_from_string "+") - [ mk_static_int 1; - mk_static_int_op (op_from_string "-") [idx2;idx1] ] in - [ Afor (cpt, mk_static_int 0, bound, - mk_block [Aassgn (mk_lhs (Larray (var_from_name map x, - mk_evar cpt)), - mk_lhs_exp (Larray (lhs_of_exp e, idx)))] ) ] - - | Minils.Evarpat x, - Minils.Eapp ({ Minils.a_op = Minils.Eselect_dyn }, e1::e2::idx, _) -> - let x = var_from_name map x in + [ mk_static_int 1; mk_static_int_op (op_from_string "-") [idx2;idx1] ] in + [ Afor (cptd, mk_static_int 0, bound, + mk_block [Aassgn (mk_pattern t (Larray (x, mk_evar_int cpt)), + mk_pattern_exp t (Larray (pattern_of_exp e, idx)))] ) ] + | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_dyn }, e1::e2::idx, _) -> + let x = Control.var_from_name map x in let bounds = Mls_utils.bounds_list e1.Minils.e_ty in let e1 = translate map e1 in let idx = List.map (translate map) idx in - let true_act = - Aassgn (x, mk_exp (Elhs (lhs_of_idx_list (lhs_of_exp e1) idx))) in + let p = pattern_of_idx_list (pattern_of_exp e1) idx in + let true_act = Aassgn (x, mk_exp p.pat_ty (Epattern p)) in let false_act = Aassgn (x, translate map e2) in let cond = bound_check_expr idx bounds in [ Acase (cond, [ ptrue, mk_block [true_act]; @@ -194,7 +194,7 @@ and translate_act map pat let x = var_from_name map x in let bounds = Mls_utils.bounds_list e1.Minils.e_ty in let idx = List.map (translate map) idx in - let action = Aassgn (lhs_of_idx_list x idx, + let action = Aassgn (pattern_of_idx_list x idx, translate map e2) in let cond = bound_check_expr idx bounds in let action = Acase (cond, [ ptrue, mk_block [action] ]) in @@ -203,17 +203,14 @@ and translate_act map pat (** TODO: remplacer par o = { f = v; g = a.g; h = a.h; ... } *) | Minils.Evarpat x, - Minils.Eapp ({ Minils.a_op = Minils.Efield_update; - Minils.a_params = [{ se_desc = Sfield f }] }, - [e1; e2], _) -> - let x = var_from_name map x in + Minils.Eapp ({ Minils.a_op = Minils.Efield_update; Minils.a_params = [{ se_desc = Sfield f }] }, [e1; e2], _) -> + let x = Control.var_from_name map x in let copy = Aassgn (x, translate map e1) in - let action = Aassgn (mk_lhs (Lfield (x, f)), - translate map e2) in - [copy; action] + let action = Aassgn (mk_pattern x.pat_ty (Lfield (x, f)), translate map e2) in (* TODO wrong type *) + [copy; action] | Minils.Evarpat n, _ -> - [Aassgn (var_from_name map n, translate map act)] + [Aassgn (Control.var_from_name map n, translate map act)] | _ -> Format.eprintf "%a The pattern %a should be a simple var to be translated to obc.@." Location.print_location act.Minils.e_loc Mls_printer.print_pat pat; @@ -224,30 +221,37 @@ and translate_c_act_list map pat c_act_list = (fun (c, act) -> (c, mk_block (translate_act map pat act))) c_act_list -let mk_obj_call_from_context (o, _) n = - match o with - | Oobj _ -> Oobj n - | Oarray (_, lhs) -> Oarray(n, lhs) +(** In an iteration, objects used are element of object arrays *) +type obj_array = { oa_index : Obc.pattern; oa_size : static_exp } -let size_from_call_context (_, n) = n +(** A [None] context is normal, otherwise, we are in an iteration *) +type call_context = obj_array option -let empty_call_context = Oobj "n", None +let mk_obj_call_from_context c n = match c with + | None -> Oobj n + | Some oa -> Oarray (n, oa.oa_index) -(** [si] is the initialization actions used in the reset method. +let size_from_call_context c = match c with + | None -> None + | Some oa -> Some (oa.oa_size) + +let empty_call_context = None + +(** [si] the initialization actions used in the reset method, [j] obj decs - [s] is the list of actions used in the step method. + [s] the actions used in the step method. [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 match (pat, desc) with | Minils.Evarpat n, Minils.Efby (opt_c, e) -> - let x = var_from_name map n in + let x = Control.var_from_name map n in let si = (match opt_c with | None -> si - | Some c -> (Aassgn (x, mk_exp (Econst c))) :: si) in - let action = Aassgn (var_from_name map n, translate map e) in - v, si, j, (control map ck action) :: s + | Some c -> (Aassgn (x, mk_exp x.pat_ty (Econst c))) :: si) in + let action = Aassgn (Control.var_from_name map n, translate map e) in + v, si, j, (Control.control map ck action) :: s | Minils.Etuplepat p_list, Minils.Eapp({ Minils.a_op = Minils.Etuple }, act_list, _) -> @@ -268,63 +272,61 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } let action = Acase (cond, [ptrue, mk_block ~locals:vt true_act; pfalse, mk_block ~locals:vf false_act]) in - v, si, j, (control map ck action) :: s + v, si, j, (Control.control map ck action) :: s - | pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app, - e_list, r) -> + | pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app, e_list, r) -> let name_list = translate_pat map pat in let c_list = List.map (translate map) e_list in - let v', si', j', action = mk_node_call map call_context - app loc name_list c_list in - let action = List.map (control map ck) action in + let v', si', j', action = mk_node_call map call_context app loc name_list c_list e.Minils.e_ty in + let action = List.map (Control.control map ck) action in let s = (match r, app.Minils.a_op with | Some r, Minils.Enode _ -> let ck = Clocks.Con (ck, Initial.ptrue, r) in - let ra = List.map (control map ck) si' in + let ra = List.map (Control.control map ck) si' in ra @ action @ s | _, _ -> action @ s) in v' @ v, si'@si, j'@j, s - | pat, Minils.Eiterator (it, app, n, e_list, reset) -> + | pat, Minils.Eiterator (it, app, n, pe_list, e_list, reset) -> let name_list = translate_pat map pat in - let c_list = - List.map (translate map) e_list in - let x = fresh_it () in - let call_context = Oarray ("n", mk_lhs (Lvar x)), Some n in + let p_list = List.map (translate map) pe_list in + let c_list = List.map (translate map) e_list in + let x, xd = fresh_it () in + let call_context = + Some { oa_index = mk_pattern_int (Lvar x); oa_size = n} in let si', j', action = translate_iterator map call_context it - name_list app loc n x c_list in - let action = List.map (control map ck) action in + name_list app loc n x xd p_list c_list e.Minils.e_ty in + let action = List.map (Control.control map ck) action in let s = (match reset, app.Minils.a_op with | Some r, Minils.Enode _ -> let ck = Clocks.Con (ck, Initial.ptrue, r) in - let ra = List.map (control map ck) si' in + let ra = List.map (Control.control map ck) si' in ra @ action @ s | _, _ -> action @ s) in (v, si' @ si, j' @ j, s) | (pat, _) -> let action = translate_act map pat e in - let action = List.map (control map ck) action in + let action = List.map (Control.control map ck) action in v, si, j, action @ s and translate_eq_list map call_context act_list = List.fold_right (translate_eq map call_context) act_list ([], [], [], []) -and mk_node_call map call_context app loc name_list args = +and mk_node_call map call_context app loc name_list args ty = match app.Minils.a_op with | Minils.Efun f when Mls_utils.is_op f -> - let e = mk_exp (Eop(f, args)) in - [], [], [], [Aassgn(List.hd name_list, e) ] + let e = mk_exp ty (Eop(f, args)) in + [], [], [], [Aassgn(List.hd name_list, e)] | Minils.Enode f when Itfusion.is_anon_node f -> - let add_input env vd = - Env.add vd.Minils.v_ident (mk_lhs (Lvar vd.Minils.v_ident)) env in - let build env vd a = - Env.add vd.Minils.v_ident a env in + let add_input env vd = Env.add vd.Minils.v_ident + (mk_pattern vd.Minils.v_type (Lvar vd.Minils.v_ident)) env in + let build env vd a = Env.add vd.Minils.v_ident a env in let subst_act_list env act_list = let exp funs env e = match e.e_desc with - | Elhs { pat_desc = Lvar x } -> + | Epattern { pat_desc = Lvar x } -> let e = (try Env.find x env with Not_found -> e) in @@ -345,74 +347,98 @@ and mk_node_call map call_context app loc name_list args = v @ nd.Minils.n_local, si, j, subst_act_list env s | Minils.Enode f | Minils.Efun f -> - let o = mk_obj_call_from_context call_context (gen_obj_name f) in + let o = mk_obj_call_from_context call_context (gen_obj_ident f) in let obj = - { o_name = obj_ref_name o; o_class = f; + { o_ident = obj_ref_name o; o_class = f; o_params = app.Minils.a_params; o_size = size_from_call_context call_context; o_loc = loc } in - let si = - (match app.Minils.a_op with - | Minils.Efun _ -> [] - | Minils.Enode _ -> [reinit o] - | _ -> assert false) in - [], si, [obj], [Acall (name_list, o, Mstep, args)] + let si = (match app.Minils.a_op with + | Minils.Efun _ -> [] + | Minils.Enode _ -> [reinit o] + | _ -> assert false) in + let s = [Acall (name_list, o, Mstep, args)] in + [], si, [obj], s | _ -> assert false -and translate_iterator map call_context it name_list app loc n x c_list = - let array_of_output name_list = - List.map (fun l -> mk_lhs (Larray (l, mk_evar x))) name_list in +and translate_iterator map call_context it name_list + app loc n x xd p_list c_list ty = + let unarray ty = match ty with + | Tarray (t,_) -> t + | _ -> + Format.eprintf "%a" Global_printer.print_type ty; + internal_error "mls2obc" 6 + 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 + in let array_of_input c_list = - List.map (array_elt_of_exp (mk_lhs (Lvar x))) c_list in - + List.map (array_elt_of_exp (mk_pattern_int (Lvar x))) c_list in match it with | Minils.Imap -> let c_list = array_of_input c_list in - let name_list = array_of_output name_list in + let ty_list = List.map unarray (Types.unprod ty) in + let name_list = array_of_output name_list ty_list in + let node_out_ty = Types.prod ty_list in let v, si, j, action = mk_node_call map call_context - app loc name_list c_list in + app loc name_list (p_list@c_list) node_out_ty in let v = translate_var_dec v in let b = mk_block ~locals:v action in - si, j, [ Afor (x, mk_static_int 0, n, b) ] + let bi = mk_block si in + [Afor (xd, mk_static_int 0, n, bi)], j, + [Afor (xd, mk_static_int 0, n, b)] | Minils.Imapfold -> let (c_list, acc_in) = split_last c_list in let c_list = array_of_input c_list in - let (name_list, acc_out) = split_last name_list in - let name_list = array_of_output name_list in - let v, si, j, action = mk_node_call map call_context - app loc (name_list @ [ acc_out ]) - (c_list @ [ mk_exp (Elhs acc_out) ]) in + let ty_list = Misc.map_butlast unarray (Types.unprod ty) in + let ty_name_list, ty_acc_out = Misc.split_last ty_list in + let (name_list, acc_out) = Misc.split_last name_list in + let name_list = array_of_output name_list ty_name_list in + let node_out_ty = Types.prod ty_list in + let v, si, j, action = mk_node_call map call_context app loc + (name_list @ [ acc_out ]) + (p_list @ c_list @ [ mk_exp acc_out.pat_ty (Epattern acc_out) ]) + node_out_ty + in let v = translate_var_dec v in let b = mk_block ~locals:v action in - si, j, [Aassgn (acc_out, acc_in); - Afor (x, mk_static_int 0, n, b)] + let bi = mk_block si in + [Afor (xd, mk_static_int 0, n, bi)], j, + [Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b)] | Minils.Ifold -> let (c_list, acc_in) = split_last c_list in let c_list = array_of_input c_list in let acc_out = last_element name_list in - let v, si, j, action = mk_node_call map call_context - app loc name_list (c_list @ [ mk_exp (Elhs acc_out) ]) in + let v, si, j, action = + mk_node_call map call_context app loc name_list + (p_list @ c_list @ [ mk_exp acc_out.pat_ty (Epattern acc_out) ]) ty + in let v = translate_var_dec v in let b = mk_block ~locals:v action in - si, j, [ Aassgn (acc_out, acc_in); - Afor (x, mk_static_int 0, n, b) ] + let bi = mk_block si in + [Afor (xd, mk_static_int 0, n, bi)], j, + [ Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b) ] | Minils.Ifoldi -> let (c_list, acc_in) = split_last c_list in let c_list = array_of_input c_list in let acc_out = last_element name_list in - let v, si, j, action = mk_node_call map call_context - app loc name_list (c_list @ [ mk_evar x; mk_exp (Elhs acc_out) ]) in + let v, si, j, action = mk_node_call map call_context app loc name_list + (p_list @ c_list @ [ mk_evar_int x; + mk_exp acc_out.pat_ty (Epattern acc_out) ]) ty + in let v = translate_var_dec v in let b = mk_block ~locals:v action in - si, j, [ Aassgn (acc_out, acc_in); - Afor (x, mk_static_int 0, n, b) ] + let bi = mk_block si in + [Afor (xd, mk_static_int 0, n, bi)], j, + [ Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b) ] let remove m d_list = List.filter (fun { Minils.v_ident = n } -> not (List.mem_assoc n m)) d_list -let translate_contract map mem_vars = +let translate_contract map mem_var_tys = function | None -> ([], [], [], []) | Some @@ -420,58 +446,51 @@ let translate_contract map mem_vars = Minils.c_eq = eq_list; Minils.c_local = d_list; } -> - let (v, si, j, s_list) = translate_eq_list map - empty_call_context eq_list in + let (v, si, j, s_list) = translate_eq_list map empty_call_context eq_list in let d_list = translate_var_dec (v @ d_list) in let d_list = List.filter - (fun vd -> not (List.mem vd.v_ident mem_vars)) d_list in + (fun vd -> not (List.exists (fun (i,_) -> i = vd.v_ident) mem_var_tys)) d_list in (si, j, s_list, d_list) (** Returns a map, mapping variables names to the variables where they will be stored. *) -let subst_map inputs outputs locals mems = +let subst_map inputs outputs locals mem_tys = (* Create a map that simply maps each var to itself *) - let m = + let map = List.fold_left - (fun m { Minils.v_ident = x } -> Env.add x (mk_lhs (Lvar x)) m) + (fun m { Minils.v_ident = x; Minils.v_type = ty } -> Env.add x (mk_pattern ty (Lvar x)) m) Env.empty (inputs @ outputs @ locals) in - List.fold_left (fun m x -> Env.add x (mk_lhs (Lmem x)) m) m mems + List.fold_left (fun map (x, x_ty) -> Env.add x (mk_pattern x_ty (Lmem x)) map) map mem_tys let translate_node - ({ - Minils.n_name = f; - Minils.n_input = i_list; - Minils.n_output = o_list; - Minils.n_local = d_list; - Minils.n_equs = eq_list; - Minils.n_contract = contract; - Minils.n_params = params; - Minils.n_loc = loc; + ({ Minils.n_name = f; Minils.n_input = i_list; Minils.n_output = o_list; + Minils.n_local = d_list; Minils.n_equs = eq_list; Minils.n_stateful = stateful; + Minils.n_contract = contract; Minils.n_params = params; Minils.n_loc = loc; } as n) = - let mem_vars = Mls_utils.node_memory_vars n in - let subst_map = subst_map i_list o_list d_list mem_vars in - let (v, si, j, s_list) = translate_eq_list subst_map - empty_call_context eq_list in - let (si', j', s_list', d_list') = - translate_contract subst_map mem_vars contract in + Idents.enter_node f; + let mem_var_tys = Mls_utils.node_memory_vars n in + let subst_map = subst_map i_list o_list d_list mem_var_tys in + let (v, si, j, s_list) = translate_eq_list subst_map empty_call_context eq_list in + let (si', j', s_list', d_list') = translate_contract subst_map mem_var_tys contract in let i_list = translate_var_dec i_list in let o_list = translate_var_dec o_list in let d_list = translate_var_dec (v @ d_list) in - let m, d_list = List.partition - (fun vd -> List.mem vd.v_ident mem_vars) d_list in - let s = joinlist (s_list @ s_list') in + let m, d_list = List.partition (fun vd -> List.exists (fun (i,_) -> i = vd.v_ident) mem_var_tys) d_list in + let s = Control.joinlist (s_list @ s_list') in let j = j' @ j in - let si = joinlist (si @ si') in - let stepm = { - m_name = Mstep; m_inputs = i_list; m_outputs = o_list; - m_body = mk_block ~locals:(d_list' @ d_list) s } in - let resetm = { - m_name = Mreset; m_inputs = []; m_outputs = []; - m_body = mk_block si } in - { cd_name = f; cd_mems = m; cd_params = params; - cd_objs = j; cd_methods = [stepm; resetm]; - cd_loc = loc } + let si = Control.joinlist (si @ si') in + let stepm = { m_name = Mstep; m_inputs = i_list; m_outputs = o_list; + m_body = mk_block ~locals:(d_list' @ d_list) s } + in + let resetm = { m_name = Mreset; m_inputs = []; m_outputs = []; m_body = mk_block si } in + if stateful + then { cd_name = f; cd_stateful = true; cd_mems = m; cd_params = params; + cd_objs = j; cd_methods = [stepm; resetm]; cd_loc = loc; } + else ( (* Functions won't have [Mreset] or memories, they still have [params] and instances (of functions) *) + { cd_name = f; cd_stateful = false; cd_mems = []; cd_params = params; + cd_objs = j; cd_methods = [stepm]; cd_loc = loc; } + ) let translate_ty_def { Minils.t_name = name; Minils.t_desc = tdesc; Minils.t_loc = loc } = @@ -479,8 +498,8 @@ let translate_ty_def { Minils.t_name = name; Minils.t_desc = tdesc; | Minils.Type_abs -> Type_abs | Minils.Type_alias ln -> Type_alias ln | Minils.Type_enum tag_name_list -> Type_enum tag_name_list - | Minils.Type_struct field_ty_list -> - Type_struct field_ty_list in + | Minils.Type_struct field_ty_list -> Type_struct field_ty_list + in { t_name = name; t_desc = tdesc; t_loc = loc } let translate_const_def { Minils.c_name = name; Minils.c_value = se; @@ -490,19 +509,12 @@ let translate_const_def { Minils.c_name = name; Minils.c_value = se; c_type = ty; c_loc = loc } -let program { - Minils.p_modname = p_modname; - Minils.p_opened = p_module_list; - Minils.p_types = p_type_list; - Minils.p_nodes = p_node_list; - Minils.p_consts = p_const_list -} = - { - p_modname = p_modname; - p_opened = p_module_list; - p_types = List.map translate_ty_def p_type_list; - p_consts = List.map translate_const_def p_const_list; - p_defs = List.map translate_node p_node_list; - } +let program { Minils.p_modname = p_modname; Minils.p_opened = p_module_list; Minils.p_types = p_type_list; + Minils.p_nodes = p_node_list; Minils.p_consts = p_const_list } = + { p_modname = p_modname; + p_opened = p_module_list; + p_types = List.map translate_ty_def p_type_list; + p_consts = List.map translate_const_def p_const_list; + p_classes = List.map translate_node p_node_list; } diff --git a/compiler/minils/analysis/clocking.ml b/compiler/minils/analysis/clocking.ml index b13cc27..981cf27 100644 --- a/compiler/minils/analysis/clocking.ml +++ b/compiler/minils/analysis/clocking.ml @@ -43,11 +43,15 @@ let rec typing h e = | None -> fresh_clock () | Some(reset) -> typ_of_name h reset in typing_op op args h e ck - | Eiterator (_, _, _, args, r) -> (* Typed exactly as a fun or a node... *) + (* 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)) args; skeleton ck e.e_ty) + in + List.iter (expect h (Ck ck)) pargs; + List.iter (expect h (Ck ck)) args; + skeleton ck e.e_ty | Ewhen (e, c, n) -> let ck_n = typ_of_name h n in (expect h (skeleton ck_n e.e_ty) e; skeleton (Con (ck_n, c, n)) e.e_ty) diff --git a/compiler/minils/main/mls2seq.ml b/compiler/minils/main/mls2seq.ml index c41e56e..5443fad 100644 --- a/compiler/minils/main/mls2seq.ml +++ b/compiler/minils/main/mls2seq.ml @@ -15,16 +15,17 @@ open Misc (** Definition of a target. A target starts either from dataflow code (ie Minils) or sequential code (ie Obc), - with or without static parameters*) + with or without static parameters *) type target = | Obc of (Obc.program -> unit) | Obc_no_params of (Obc.program -> unit) + | Obc_scalar of (Obc.program ->unit) | Minils of (Minils.program -> unit) | Minils_no_params of (Minils.program -> unit) (** Writes a .epo file for program [p]. *) let write_object_file p = - let filename = (filename_of_name p.Minils.p_modname)^".epo" in + let filename = (Names.modul_to_string p.Minils.p_modname)^".epo" in let epoc = open_out_bin filename in output_value epoc p; close_out epoc; @@ -32,13 +33,15 @@ let write_object_file p = (** Writes a .obc file for program [p]. *) let write_obc_file p = - let obc_name = (filename_of_name p.Obc.p_modname)^".obc" in + let obc_name = (Names.modul_to_string p.Obc.p_modname)^".obc" in let obc = open_out obc_name in Obc_printer.print obc p; close_out obc; comment "Generation of Obc code" + let targets = [ "c", Obc_no_params Cmain.program; + "java", Obc_scalar Java_main.program; "obc", Obc write_obc_file; "obc_np", Obc_no_params write_obc_file; "epo", Minils write_object_file ] @@ -64,10 +67,14 @@ let generate_target p s = let p_list = Callgraph.program p in let o_list = List.map Mls2obc.program p_list in print_unfolded p_list; - comment "Translation to Obc"; + comment "Obc Callgraph"; if !verbose then List.iter (Obc_printer.print stdout) o_list; List.iter convert_fun o_list + | Obc_scalar convert_fun -> + let p = p |> Mls2obc.program |> Scalarize.program in + convert_fun p + (** Translation into dataflow and sequential languages, defaults to obc. *) let program p = diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index 361cfe2..1eba85f 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -58,7 +58,7 @@ and edesc = (** merge ident (Constructor -> exp)+ *) | Estruct of (field_name * exp) list (** { field=exp; ... } *) - | Eiterator of iterator_type * app * static_exp * exp list * var_ident option + | Eiterator of iterator_type * app * static_exp * exp list * exp list * var_ident option (** map f <> (exp, exp...) reset ident *) and app = { a_op: op; a_params: static_exp list; a_unsafe: bool } @@ -106,11 +106,12 @@ type contract = { type node_dec = { n_name : qualname; + n_stateful : bool; 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; + (* 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; @@ -124,9 +125,9 @@ type const_dec = { c_loc : location } type program = { - p_modname : name; + p_modname : modul; p_format_version : string; - p_opened : name list; + p_opened : modul list; p_types : type_dec list; p_nodes : node_dec list; p_consts : const_dec list } @@ -146,13 +147,14 @@ let mk_equation ?(loc = no_location) pat exp = let mk_node ?(input = []) ?(output = []) ?(contract = None) ?(local = []) ?(eq = []) - ?(loc = no_location) ?(param = []) ?(constraints = []) + ?(stateful = true) ?(loc = no_location) ?(param = []) ?(constraints = []) ?(pinst = ([],[])) name = { n_name = name; + n_stateful = stateful; n_input = input; n_output = output; n_contract = contract; - n_controller_call = pinst; + (* n_controller_call = pinst;*) n_local = local; n_equs = eq; n_loc = loc; @@ -170,8 +172,7 @@ let mk_app ?(params=[]) ?(unsafe=false) op = (** The modname field has to be set when known, TODO LG : format_version *) let mk_program o n t c = - { p_modname = ""; p_format_version = ""; + { p_modname = Module ""; p_format_version = ""; p_opened = o; p_nodes = n; p_types = t; p_consts = c } let void = mk_exp ~ty:Types.Tunit (Eapp (mk_app Etuple, [], None)) - diff --git a/compiler/minils/mls_compare.ml b/compiler/minils/mls_compare.ml index a4fe171..b9b9a77 100644 --- a/compiler/minils/mls_compare.ml +++ b/compiler/minils/mls_compare.ml @@ -48,8 +48,8 @@ let rec exp_compare e1 e2 = let cr = compare fn1 fn2 in if cr <> 0 then cr else exp_compare e1 e2 in list_compare compare_fne fnel1 fnel2 - | Eiterator (it1, app1, se1, el1, vio1), - Eiterator (it2, app2, se2, el2, vio2) -> + | Eiterator (it1, app1, se1, pel1, el1, vio1), + Eiterator (it2, app2, se2, pel2, el2, vio2) -> let cr = compare it1 it2 in if cr <> 0 then cr else let cr = static_exp_compare se1 se2 in @@ -57,7 +57,9 @@ let rec exp_compare e1 e2 = let cr = app_compare app1 app2 in if cr <> 0 then cr else let cr = option_compare ident_compare vio1 vio2 in - if cr <> 0 then cr else list_compare exp_compare el1 el2 + if cr <> 0 then cr else + let cr = list_compare exp_compare pel1 pel2 in + if cr <> 0 then cr else list_compare exp_compare el1 el2 | Econst _, _ -> 1 @@ -90,7 +92,7 @@ and app_compare app1 app2 = | (Eequal | Etuple | Efun _ | Enode _ | Eifthenelse | Efield | Efield_update), _ -> -1 | (Earray | Earray_fill | Eselect | Eselect_slice | Eselect_dyn | Eupdate - | Econcat), _ -> 1 in + | Econcat ), _ -> 1 in if cr <> 0 then cr else list_compare static_exp_compare app1.a_params app2.a_params diff --git a/compiler/minils/mls_mapfold.ml b/compiler/minils/mls_mapfold.ml index 314ff4b..d5e7aa2 100644 --- a/compiler/minils/mls_mapfold.ml +++ b/compiler/minils/mls_mapfold.ml @@ -73,11 +73,12 @@ and edesc funs acc ed = match ed with (n,e), acc in let n_e_list, acc = mapfold aux acc n_e_list in Estruct n_e_list, acc - | Eiterator (i, app, param, args, reset) -> + | Eiterator (i, app, param, pargs, args, reset) -> let app, acc = app_it funs acc app in let param, acc = static_exp_it funs.global_funs acc param in + let pargs, acc = mapfold (exp_it funs) acc pargs in let args, acc = mapfold (exp_it funs) acc args in - Eiterator (i, app, param, args, reset), acc + Eiterator (i, app, param, pargs, args, reset), acc and app_it funs acc a = funs.app funs acc a diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index 8bebfc0..76bbe40 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -102,59 +102,61 @@ and print_exp_desc ff = function print_ident x print_tag_e_list tag_e_list | Estruct f_e_list -> print_record (print_couple print_qualname print_exp """ = """) ff f_e_list - | Eiterator (it, f, param, args, reset) -> - fprintf ff "@[<2>(%s (%a)<<%a>>)@,%a@]%a" + | Eiterator (it, f, param, pargs, args, reset) -> + fprintf ff "@[<2>(%s (%a)<<%a>>)@,(%a)%a@]%a" (iterator_to_string it) print_app (f, []) print_static_exp param + print_exp_tuple pargs print_exp_tuple args print_every 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@]" - print_qualname f print_params app.a_params print_exp_tuple args - | Eifthenelse -> - let e1, e2, e3 = assert_3 args in - fprintf ff "@[if %a@ then %a@ else %a@]" - print_exp e1 print_exp e2 print_exp e3 - | Efield -> - let r = assert_1 args in - let f = assert_1 app.a_params in - fprintf ff "%a.%a" print_exp r print_static_exp f - | Efield_update -> - let r,e = assert_2 args in - let f = assert_1 app.a_params in - fprintf ff "@[<2>{%a with .%a =@ %a}@]" - print_exp r print_static_exp f print_exp e - | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args - | Earray_fill -> - let e = assert_1 args in - let n = assert_1 app.a_params in - fprintf ff "%a^%a" print_exp e print_static_exp n - | Eselect -> - let e = assert_1 args in - fprintf ff "%a%a" print_exp e print_index app.a_params - | Eselect_slice -> - let e = assert_1 args in - let idx1, idx2 = assert_2 app.a_params in - fprintf ff "%a[%a..%a]" - print_exp e print_static_exp idx1 print_static_exp idx2 - | Eselect_dyn -> - let r, d, e = assert_2min args in - fprintf ff "%a%a default %a" - print_exp r print_dyn_index e print_exp d - | Eupdate -> - let e1, e2, idx = assert_2min args in - fprintf ff "@[<2>(%a with %a =@ %a)@]" - print_exp e1 print_dyn_index idx print_exp e2 - | Econcat -> - let e1, e2 = assert_2 args in - fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2 +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@]" + print_qualname f print_params app.a_params print_exp_tuple args + | Eifthenelse -> + let e1, e2, e3 = assert_3 args in + fprintf ff "@[if %a@ then %a@ else %a@]" + print_exp e1 print_exp e2 print_exp e3 + | Efield -> + let r = assert_1 args in + let f = assert_1 app.a_params in + fprintf ff "%a.%a" print_exp r print_static_exp f + | Efield_update -> + let r,e = assert_2 args in + let f = assert_1 app.a_params in + fprintf ff "@[<2>{%a with .%a =@ %a}@]" + print_exp r print_static_exp f print_exp e + | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args + | Earray_fill -> + let e = assert_1 args in + let n = assert_1 app.a_params in + fprintf ff "%a^%a" print_exp e print_static_exp n + | Eselect -> + let e = assert_1 args in + fprintf ff "%a%a" print_exp e print_index app.a_params + | Eselect_slice -> + let e = assert_1 args in + let idx1, idx2 = assert_2 app.a_params in + fprintf ff "%a[%a..%a]" + print_exp e print_static_exp idx1 print_static_exp idx2 + | Eselect_dyn -> + let r, d, e = assert_2min args in + fprintf ff "%a%a default %a" + print_exp r print_dyn_index e print_exp d + | Eupdate -> + let e1, e2, idx = assert_2min args in + fprintf ff "@[<2>(%a with %a =@ %a)@]" + print_exp e1 print_dyn_index idx print_exp e2 + | Econcat -> + let e1, e2 = assert_2 args in + fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2 and print_handler ff c = fprintf ff "@[<2>%a@]" (print_couple print_qualname print_exp "("" -> "")") c @@ -174,7 +176,7 @@ and print_eqs ff = function | [] -> () | l -> fprintf ff "@[let@ %a@]@\ntel" (print_list_r print_eq """;""") l -let print_open_module ff name = fprintf ff "open %a@." print_name name +let print_open_module ff name = fprintf ff "open %s@." (modul_to_string name) let rec print_type_dec ff { t_name = name; t_desc = tdesc } = let print_type_desc ff = function diff --git a/compiler/minils/mls_utils.ml b/compiler/minils/mls_utils.ml index 39a0fb0..c58a57b 100644 --- a/compiler/minils/mls_utils.ml +++ b/compiler/minils/mls_utils.ml @@ -53,7 +53,7 @@ let is_record_type ty = match ty with | _ -> false let is_op = function - | { qual = "Pervasives"; name = _ } -> true | _ -> false + | { qual = Pervasives; name = _ } -> true | _ -> false let exp_list_of_static_exp_list se_list = let mk_one_const se = @@ -80,7 +80,7 @@ struct (* special cases *) let acc = match e.e_desc with | Evar x | Emerge(x,_) | Ewhen(_, _, x) - | Eapp(_, _, Some x) | Eiterator (_, _, _, _, Some x) -> + | Eapp(_, _, Some x) | Eiterator (_, _, _, _, _, Some x) -> add x acc | Efby(_, e) -> if is_left then @@ -135,10 +135,15 @@ struct | _ -> [] end +(* Assumes normal form, all fby are solo rhs *) let node_memory_vars n = let eq _ acc ({ eq_lhs = pat; eq_rhs = e } as eq) = match e.e_desc with - | Efby(_, _) -> eq, Vars.vars_pat acc pat + | Efby(_, _) -> + let v_l = Vars.vars_pat [] pat in + let t_l = Types.unprod e.e_ty in + let acc = (List.combine v_l t_l) @ acc in + eq, acc | _ -> eq, acc in let funs = { Mls_mapfold.defaults with eq = eq } in diff --git a/compiler/minils/transformations/callgraph.ml b/compiler/minils/transformations/callgraph.ml index 61fddf6..f340590 100644 --- a/compiler/minils/transformations/callgraph.ml +++ b/compiler/minils/transformations/callgraph.ml @@ -14,7 +14,7 @@ module Error = struct type error = | Enode_unbound of qualname - | Epartial_instanciation of static_exp + | Epartial_evaluation of static_exp list let message loc kind = begin match kind with @@ -22,10 +22,10 @@ struct Format.eprintf "%aUnknown node '%s'@." print_location loc (fullname ln) - | Epartial_instanciation se -> - Format.eprintf "%aUnable to fully instanciate the static exp '%a'@." - print_location se.se_loc - print_static_exp se + | Epartial_evaluation se_l -> + Format.eprintf "%aUnable to fully instanciate the static exps '%a'@." + print_location loc + print_static_exp_tuple se_l end; raise Errors.Error end @@ -77,10 +77,10 @@ struct let nodes_instances = ref QualEnv.empty (** create a params instance *) - let instantiate m se = - try List.map (eval m) se - with Partial_instanciation se -> - Error.message no_location (Error.Epartial_instanciation se) + let instantiate m se_l = + try List.map (eval m) se_l + with Errors.Error -> + Error.message no_location (Error.Epartial_evaluation se_l) (** @return the name of the node corresponding to the instance of [ln] with the static parameters [params]. *) @@ -137,13 +137,11 @@ struct let se, _ = Global_mapfold.static_exp funs m se in let se = match se.se_desc with | Svar q -> - if q.qual = local_qualname - then (* This var is a static parameter, it has to be instanciated *) - (try QualEnv.find q m - with Not_found -> - Format.eprintf "local param not local"; - assert false;) - else se + (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) + | _ -> se) | _ -> se in se, m @@ -158,13 +156,15 @@ struct let op = Enode (node_for_params_call ln (instantiate m params)) in Eapp ({ app with a_op = op; a_params = [] }, e_list, r) | Eiterator(it, ({ a_op = Efun ln; a_params = params } as app), - n, e_list, r) -> + n, pe_list, e_list, r) -> let op = Efun (node_for_params_call ln (instantiate m params)) in - Eiterator(it, {app with a_op = op; a_params = [] }, n, e_list, r) + Eiterator(it, {app with a_op = op; a_params = [] }, + n, pe_list, e_list, r) | Eiterator(it, ({ a_op = Enode ln; a_params = params } as app), - n, e_list, r) -> + n, pe_list, e_list, r) -> let op = Enode (node_for_params_call ln (instantiate m params)) in - Eiterator(it,{app with a_op = op; a_params = [] }, n, e_list, r) + Eiterator(it,{app with a_op = op; a_params = [] }, + n, pe_list, e_list, r) | _ -> ed in ed, m @@ -201,18 +201,24 @@ end open Param_instances type info = - { mutable opened : program NamesEnv.t; + { mutable opened : program ModulEnv.t; mutable called_nodes : ((qualname * static_exp list) list) QualEnv.t; } let info = { (** opened programs*) - opened = NamesEnv.empty; + opened = ModulEnv.empty; (** Maps a node to the list of (node name, params) it calls *) called_nodes = QualEnv.empty } (** Loads the modname.epo file. *) -let load_object_file modname = - Modules.open_module modname; +let load_object_file modul = + Modules.open_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 + in let name = String.uncapitalize modname in try let filename = Compiler_utils.findfile (name ^ ".epo") in @@ -226,7 +232,7 @@ let load_object_file modname = raise Errors.Error ); close_in ic; - info.opened <- NamesEnv.add p.p_modname p info.opened + info.opened <- ModulEnv.add p.p_modname p info.opened with | End_of_file | Failure _ -> close_in ic; @@ -242,10 +248,10 @@ let load_object_file modname = (** @return the node with name [ln], loading the corresponding object file if necessary. *) let node_by_longname node = - if not (NamesEnv.mem node.qual info.opened) + if not (ModulEnv.mem node.qual info.opened) then load_object_file node.qual; try - let p = NamesEnv.find node.qual info.opened in + let p = ModulEnv.find node.qual info.opened in List.find (fun n -> n.n_name = node) p.p_nodes with Not_found -> Error.message no_location (Error.Enode_unbound node) @@ -258,14 +264,14 @@ let collect_node_calls ln = | [] -> acc | _ -> (match ln with - | { qual = "Pervasives" } -> acc + | { qual = Pervasives } -> acc | _ -> (ln, params)::acc) in let edesc _ acc ed = match ed with | Eapp ({ a_op = (Enode ln | Efun ln); a_params = params }, _, _) -> ed, add_called_node ln params acc | Eiterator(_, { a_op = (Enode ln | Efun ln); a_params = params }, - _, _, _) -> + _, _, _, _) -> ed, add_called_node ln params acc | _ -> raise Errors.Fallback in @@ -303,9 +309,9 @@ let program p = (* Find the nodes without static parameters *) let main_nodes = List.filter (fun n -> is_empty n.n_params) p.p_nodes in let main_nodes = List.map (fun n -> n.n_name, []) main_nodes in - info.opened <- NamesEnv.add p.p_modname p NamesEnv.empty; + 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; - let p_list = NamesEnv.fold (fun _ p l -> p::l) info.opened [] in + let p_list = ModulEnv.fold (fun _ p l -> p::l) info.opened [] in (* Generate all the needed instances *) List.map Param_instances.Instantiate.program p_list diff --git a/compiler/minils/transformations/checkpass.ml b/compiler/minils/transformations/checkpass.ml index 0c850b7..2a023a2 100644 --- a/compiler/minils/transformations/checkpass.ml +++ b/compiler/minils/transformations/checkpass.ml @@ -46,7 +46,7 @@ let add_check prefix pass nd nd_list = Modules.add_value nd_check.n_name { node_inputs = []; node_outputs = [{ a_name = None; a_type = Tid Initial.pbool; }]; - node_statefull = true; + node_stateful = true; node_params = []; node_params_constraints = [] }; diff --git a/compiler/minils/transformations/introvars.ml b/compiler/minils/transformations/introvars.ml index f0c910b..e06f815 100644 --- a/compiler/minils/transformations/introvars.ml +++ b/compiler/minils/transformations/introvars.ml @@ -76,10 +76,12 @@ let rec exp e (eq_list, var_list) = match e.e_desc with intro_vars e_list (eq_list, var_list) in let fnel = List.combine (List.map fst fnel) e_list in Estruct fnel, eq_list, var_list - | Eiterator (it, app, se, e_list, vio) -> + | Eiterator (it, app, se, pe_list, e_list, vio) -> let (e_list, eq_list, var_list) = intro_vars e_list (eq_list, var_list) in - Eiterator (it, app, se, e_list, vio), eq_list, var_list in + let (pe_list, eq_list, var_list) = + intro_vars pe_list (eq_list, var_list) in + Eiterator (it, app, se, pe_list, e_list, vio), eq_list, var_list in ({ e with e_desc = e_desc; }, eq_list, var_list) and intro_vars e_list (eq_list, var_list) = diff --git a/compiler/minils/transformations/itfusion.ml b/compiler/minils/transformations/itfusion.ml index 6e7c0e3..4e4bcc7 100644 --- a/compiler/minils/transformations/itfusion.ml +++ b/compiler/minils/transformations/itfusion.ml @@ -9,13 +9,13 @@ open Minils (* Functions to temporarily store anonymous nodes*) let mk_fresh_node_name () = Modules.fresh_value "itfusion" "temp" -let fresh_vd_of_arg = +let fresh_vd_of_arg a = Idents.gen_fresh "itfusion" (fun a -> match a.a_name with | None -> "v" - | Some n -> n) + | Some n -> n) a -let fresh_var = Idents.gen_fresh "itfusion" (fun () -> "x") +let fresh_var () = Idents.gen_var "itfusion" "x" let anon_nodes = ref QualEnv.empty @@ -89,7 +89,7 @@ let mk_call app acc_eq_list = let edesc funs acc ed = let ed, acc = Mls_mapfold.edesc funs acc ed in match ed with - | Eiterator(Imap, f, n, e_list, r) -> + | Eiterator(Imap, f, n, [], e_list, r) -> (** @return the list of inputs of the anonymous function, a list of created equations (the body of the function), the args for the call of f in the lambda, @@ -102,7 +102,7 @@ let edesc funs acc ed = o1, o2 = f (_v1, _v2, z') *) let mk_arg e (inp, acc_eq_list, largs, args, b) = match e.e_desc with - | Eiterator(Imap, g, m, local_args, _) when are_equal n m -> + | Eiterator(Imap, g, m, [], local_args, _) when are_equal n m -> let new_inp, e, acc_eq_list = mk_call g acc_eq_list in new_inp @ inp, acc_eq_list, e::largs, local_args @ args, true | _ -> @@ -122,7 +122,7 @@ let edesc funs acc ed = let eq = mk_equation (pat_of_vd_list outp) call in (* create the lambda *) let anon = mk_app (Enode (add_anon_node inp outp [] (eq::acc_eq_list))) in - Eiterator(Imap, anon, n, args, r), acc) + Eiterator(Imap, anon, n, [], args, r), acc) else ed, acc diff --git a/compiler/minils/transformations/normalize.ml b/compiler/minils/transformations/normalize.ml index a15d639..e07cf94 100644 --- a/compiler/minils/transformations/normalize.ml +++ b/compiler/minils/transformations/normalize.ml @@ -132,7 +132,7 @@ let const e c = (* normal form for expressions and equations: *) (* - e ::= op(e,...,e) | x | C | e when C(x) *) (* - act ::= e | merge x (C1 -> act) ... (Cn -> act) | (act,...,act) *) -(* - eq ::= [x = v fby e] | [pat = act ] | [pat = f(e1,...,en) every n *) +(* - eq ::= [x = v fby e] | [pat = act] | [pat = f(e1,...,en) every n *) (* - A-normal form: (e1,...,en) when c(x) = (e1 when c(x),...,en when c(x) *) type kind = VRef | Exp | Act | Any @@ -199,7 +199,7 @@ let rec translate kind context e = | Eapp(app, e_list, r) -> let context, e_list = translate_app kind context app.a_op e_list in context, { e with e_desc = Eapp(app, e_list, r) } - | Eiterator (it, app, n, e_list, reset) -> + | Eiterator (it, app, n, pe_list, e_list, reset) -> (* normalize anonymous nodes *) (match app.a_op with | Enode f when Itfusion.is_anon_node f -> @@ -218,9 +218,11 @@ let rec translate kind context e = translate kind context e in Misc.mapfold_right add e_list context in + let context, pe_list = + translate_list function_args_kind context pe_list in let context, e_list = translate_iterator_arg_list context e_list in - context, { e with e_desc = Eiterator(it, app, n, + context, { e with e_desc = Eiterator(it, app, n, flatten_e_list pe_list, flatten_e_list e_list, reset) } in add context kind e diff --git a/compiler/minils/transformations/schedule.ml b/compiler/minils/transformations/schedule.ml index 10a4c94..6ccfc27 100644 --- a/compiler/minils/transformations/schedule.ml +++ b/compiler/minils/transformations/schedule.ml @@ -79,11 +79,11 @@ let eqs funs () eq_list = let edesc _ () = function | Eiterator(it, ({ a_op = Enode f } as app), - n, e_list, r) when Itfusion.is_anon_node f -> + n, [], e_list, r) when Itfusion.is_anon_node f -> let nd = Itfusion.find_anon_node f in let nd = { nd with n_equs = schedule nd.n_equs } in Itfusion.replace_anon_node f nd; - Eiterator(it, app, n, e_list, r), () + Eiterator(it, app, n, [], e_list, r), () | _ -> raise Errors.Fallback let program p = diff --git a/compiler/minils/transformations/singletonvars.ml b/compiler/minils/transformations/singletonvars.ml index 9e86558..0759da7 100644 --- a/compiler/minils/transformations/singletonvars.ml +++ b/compiler/minils/transformations/singletonvars.ml @@ -52,7 +52,7 @@ struct | Evar vi -> add_var_use vi use_counts | Emerge (vi, _) -> add_clock_use vi use_counts | Ewhen (_, _, vi) -> add_clock_use vi use_counts - | Eapp (_, _, Some vi) | Eiterator (_, _, _, _, Some vi) -> + | Eapp (_, _, Some vi) | Eiterator (_, _, _, _, _, Some vi) -> add_reset_use vi use_counts | _ -> use_counts in (edesc, use_counts) diff --git a/compiler/minils/transformations/tomato.ml b/compiler/minils/transformations/tomato.ml index dce1cfd..6ddf5ec 100644 --- a/compiler/minils/transformations/tomato.ml +++ b/compiler/minils/transformations/tomato.ml @@ -67,6 +67,10 @@ module PatEnv = type penv_t = (int * exp * ident list) P.t + + (* An environment used for automata minimization: holds both a pattern environment mapping patterns to equivalence + classes, and a [(pat * int list) Env.t] that maps variable [x] to a [(pat, pth)] tuple where [pat] is the pattern + holding [x] at path [pth] *) type t = penv_t * (pat * int list) Env.t let empty = (P.empty, Env.empty) @@ -202,9 +206,12 @@ let behead e = List.split (List.map (fun (ln, e) -> ((ln, dummy_exp), e)) lne_list) in (Estruct lne_list, e_list) - | Eiterator (it, op, s, e_list, rst) -> + | Eiterator (it, op, s, pe_list, e_list, rst) -> let (rst, l) = encode_reset rst in - (Eiterator (it, op, s, [], rst), l @ e_list) in + (* count is the number of partial arguments *) + let count = mk_exp ~ty:Initial.tint + (Econst (Initial.mk_static_int (List.length pe_list))) in + (Eiterator (it, op, s, [], [], rst), count :: (pe_list @ l @ e_list)) in ({ e with e_desc = e_desc; }, children) let pat_name pat = @@ -398,7 +405,7 @@ let rec reconstruct input_type (env : PatEnv.t) = | Etuplepat pat_list, Tprod ty_list -> List.fold_right2 mk_var_decs pat_list ty_list var_list | Etuplepat [], Tunit -> var_list - | Etuplepat _, (Tarray _ | Tid _ | Tunit) -> assert false (* ill-typed *) in + | Etuplepat _, (Tarray _ | Tid _ | Tunit | Tmutable _) -> assert false (* ill-typed *) in let add_to_lists pat (_, head, children) (eq_list, var_list) = (* Remember the encoding of resets given above. *) @@ -421,11 +428,19 @@ let rec reconstruct input_type (env : PatEnv.t) = List.combine (List.map fst cnel) (List.tl e_list)) | Estruct fnel, e_list -> Estruct (List.combine (List.map fst fnel) e_list) - | Eiterator (it, app, se, [], rst), e_list -> + | Eiterator (it, app, se, [], [], rst), e_list -> + (* the first element is the number of partial arguments *) + let count, e_list = assert_1min e_list in + let c = (match count.e_desc with + | Econst { se_desc = Sint c } -> c + | _ -> assert false) + in + let pe_list, e_list = Misc.split_at c e_list in let rst, e_list = rst_of_e_list rst e_list in - Eiterator (it, app, se, e_list, rst) + Eiterator (it, app, se, pe_list, e_list, rst) - | (Eiterator (_, _, _, _ :: _, _) | Ewhen _ | Efby _ | Evar _ | Econst _) + | (Eiterator (_, _, _, _, _, _) | Ewhen _ + | Efby _ | Evar _ | Econst _) , _ -> assert false (* invariant *) in (mk_equation pat { head with e_desc = e_desc; } :: eq_list, mk_var_decs pat head.e_ty var_list) in diff --git a/compiler/obc/_tags b/compiler/obc/_tags index c1549be..387e977 100644 --- a/compiler/obc/_tags +++ b/compiler/obc/_tags @@ -1 +1 @@ - or :include \ No newline at end of file + or or :include diff --git a/compiler/obc/c/c.ml b/compiler/obc/c/c.ml index 7805387..716bb3c 100644 --- a/compiler/obc/c/c.ml +++ b/compiler/obc/c/c.ml @@ -12,14 +12,7 @@ open List open Modules open Names -let rec print_list ff print sep l = - match l with - | [] -> () - | [x] -> print ff x - | x :: l -> - print ff x; - fprintf ff "%s@ " sep; - print_list ff print sep l +let print_list ff print sep l = Pp_tools.print_list_r print "" sep "" ff l (** [cname_of_name name] translates the string [name] to a valid C identifier. Copied verbatim from the old C backend. *) @@ -81,19 +74,19 @@ and cexpr = | Clhs of clhs (** Left-hand-side expressions are obviously expressions! *) | Caddrof of clhs (** Take the address of a left-hand-side expression. *) | Cstructlit of string * cexpr list (** Structure literal "{ f1, f2, ... }".*) - | Carraylit of cexpr list (** Array literal [e1, e2, ...]. *) + | Carraylit of cexpr list (** Array literal [\[e1, e2, ...\]]. *) and cconst = | Ccint of int (** Integer constant. *) | Ccfloat of float (** Floating-point number constant. *) | Ctag of string (** Tag, member of a previously declared enumeration. *) | Cstrlit of string (** String literal, enclosed in double-quotes. *) - (** C left-hand-side (ie. affectable) expressions. *) +(** C left-hand-side (ie. affectable) expressions. *) and clhs = | Cvar of string (** A local variable. *) | Cderef of clhs (** Pointer dereference, *ptr. *) | Cfield of clhs * qualname (** Field access to left-hand-side. *) | Carray of clhs * cexpr (** Array access clhs[cexpr] *) - (** C statements. *) +(** C statements. *) and cstm = | Csexpr of cexpr (** Expression evaluation, may cause side-effects! *) | Csblock of cblock (** A local sub-block, can have its own private decls. **) @@ -162,11 +155,14 @@ let rec pp_list f sep fmt l = match l with let pp_string fmt s = fprintf fmt "%s" (cname_of_name s) -let cname_of_qn q = - if q.qual = "Pervasives" or q.qual = Names.local_qualname then - q.name - else - (q.qual ^ "__" ^ q.name) +let rec modul_to_cname q = match q with + | Pervasives | LocalModule -> "" + | Module m -> m ^ "__" + | QualModule { qual = q; name = n } -> + (modul_to_cname q)^n^"__" + +let cname_of_qn qn = + (modul_to_cname qn.qual) ^ qn.name let pp_qualname fmt q = pp_string fmt (cname_of_qn q) @@ -248,8 +244,9 @@ and pp_cexpr fmt ce = match ce with | Caddrof lhs -> fprintf fmt "&%a" pp_clhs lhs | Cstructlit (s, el) -> fprintf fmt "(%a){@[%a@]}" pp_string s (pp_list1 pp_cexpr ",") el - | Carraylit el -> - fprintf fmt "((int []){@[%a@]})" (pp_list1 pp_cexpr ",") el (* WRONG *) + | Carraylit el -> (* TODO master : WRONG *) + fprintf fmt "((int []){@[%a@]})" (pp_list1 pp_cexpr ",") el + and pp_clhs fmt lhs = match lhs with | Cvar s -> pp_string fmt s | Cderef lhs' -> fprintf fmt "*%a" pp_clhs lhs' @@ -314,11 +311,10 @@ let pp_cfile_desc fmt filen cfile = let output_cfile dir (filen, cfile_desc) = if !Compiler_options.verbose then Format.printf "C-NG generating %s/%s@." dir filen; - let buf = Buffer.create 20000 in let oc = open_out (Filename.concat dir filen) in - let fmt = Format.formatter_of_buffer buf in + let fmt = Format.formatter_of_out_channel oc in pp_cfile_desc fmt filen cfile_desc; - Buffer.output_buffer oc buf; + pp_print_flush fmt (); close_out oc let output dir cprog = diff --git a/compiler/obc/c/c.mli b/compiler/obc/c/c.mli index cee66f0..ca3d97c 100644 --- a/compiler/obc/c/c.mli +++ b/compiler/obc/c/c.mli @@ -45,9 +45,8 @@ and cexpr = | Cconst of cconst (** Constants. *) | Clhs of clhs (** Left-hand-side expressions are obviously expressions! *) | Caddrof of clhs (** Take the address of a left-hand-side expression. *) - | Cstructlit of string * cexpr list (** Structure literal - " \{f1, f2, ... \}". *) - | Carraylit of cexpr list (** Array literal [e1, e2, ...]. *) + | Cstructlit of string * cexpr list (** Structure literal [{f1, f2, ... }]. *) + | Carraylit of cexpr list (** Array literal [\[e1, e2, ...\]]. *) and cconst = | Ccint of int (** Integer constant. *) | Ccfloat of float (** Floating-point number constant. *) diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 4f6728a..8870142 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -13,6 +13,7 @@ open Misc open Names open Idents open Obc +open Obc_utils open Types open Modules @@ -72,10 +73,10 @@ let output_names_list sig_info = in List.map remove_option sig_info.node_outputs -let is_statefull n = +let is_stateful n = try let sig_info = find_value n in - sig_info.node_statefull + sig_info.node_stateful with Not_found -> Error.message no_location (Error.Enode (fullname n)) @@ -99,8 +100,8 @@ let rec ctype_of_otype oty = | Types.Tid id when id = Initial.pfloat -> Cty_float | Types.Tid id when id = Initial.pbool -> Cty_int | Tid id -> Cty_id id - | Tarray(ty, n) -> Cty_arr(int_of_static_exp n, - ctype_of_otype ty) + | Tarray(ty, n) -> Cty_arr(int_of_static_exp n, ctype_of_otype ty) + | Tmutable t -> ctype_of_otype t | Tprod _ -> assert false | Tunit -> assert false @@ -254,7 +255,7 @@ let rec cexpr_of_static_exp se = List.map (fun (_, se) -> cexpr_of_static_exp se) fl) | Sarray_power(n,c) -> let cc = cexpr_of_static_exp c in - Carraylit (repeat_list cc (int_of_static_exp n)) + Carraylit (repeat_list cc (int_of_static_exp n)) (* TODO should be recursive *) | Svar ln -> (try let cd = find_const ln in @@ -273,7 +274,7 @@ let rec cexpr_of_static_exp se = let rec cexpr_of_exp var_env exp = match exp.e_desc with (** Obj expressions that form valid C lhs are translated via clhs_of_exp. *) - | Elhs _ -> + | Epattern _ -> Clhs (clhs_of_exp var_env exp) (** Constants, the easiest translation. *) | Econst lit -> @@ -293,7 +294,7 @@ and cexprs_of_exps var_env exps = List.map (cexpr_of_exp var_env) exps and cop_of_op_aux op_name cexps = match op_name with - | { qual = "Pervasives"; name = op } -> + | { qual = Pervasives; name = op } -> begin match op,cexps with | "~-", [e] -> Cuop ("-", e) | "not", [e] -> Cuop ("!", e) @@ -306,7 +307,7 @@ and cop_of_op_aux op_name cexps = match op_name with Cbop (copname op, el, er) | _ -> Cfun_call(op, cexps) end - | {qual = m; name = op} -> Cfun_call(op,cexps) (*TODO m should be used?*) + | {qual = m; name = op} -> Cfun_call(op,cexps) and cop_of_op var_env op_name exps = let cexps = cexprs_of_exps var_env exps in @@ -335,7 +336,7 @@ and clhss_of_lhss var_env lhss = List.map (clhs_of_lhs var_env) lhss and clhs_of_exp var_env exp = match exp.e_desc with - | Elhs l -> clhs_of_lhs var_env l + | Epattern l -> clhs_of_lhs var_env l (** We were passed an expression that is not translatable to a valid C lhs?!*) | _ -> invalid_arg "clhs_of_exp: argument not a Var, Mem or Field" @@ -343,7 +344,7 @@ let rec assoc_obj instance obj_env = match obj_env with | [] -> raise Not_found | od :: t -> - if od.o_name = instance + if od.o_ident = instance then od else assoc_obj instance t @@ -351,7 +352,7 @@ let assoc_cn instance obj_env = (assoc_obj (obj_ref_name instance) obj_env).o_class let is_op = function - | { qual = "Pervasives"; name = _ } -> true + | { qual = Pervasives; name = _ } -> true | _ -> false let out_var_name_of_objn o = @@ -361,13 +362,13 @@ let out_var_name_of_objn o = of the called node, [mem] represents the node context and [args] the argument list.*) let step_fun_call var_env sig_info objn out args = - if sig_info.node_statefull then ( + if sig_info.node_stateful then ( let mem = (match objn with - | Oobj o -> Cfield (Cderef (Cvar "self"), local_qn o) + | Oobj o -> Cfield (Cderef (Cvar "self"), local_qn (name o)) | Oarray (o, l) -> let l = clhs_of_lhs var_env l in - Carray (Cfield (Cderef (Cvar "self"), local_qn o), Clhs l) + Carray (Cfield (Cderef (Cvar "self"), local_qn (name o)), Clhs l) ) in args@[Caddrof out; Caddrof mem] ) else @@ -427,7 +428,7 @@ let rec create_affect_const var_env dest c = let dest = Carray (dest, Cconst (Ccint i)) in (i - 1, create_affect_const var_env dest c @ affl) in snd (List.fold_right create_affect_idx cl (List.length cl - 1, [])) - | _ -> [Caffect (dest, cexpr_of_exp var_env (mk_exp (Econst c)))] + | _ -> [Caffect (dest, cexpr_of_static_exp c)] (** [cstm_of_act obj_env mods act] translates the Obj action [act] to a list of C statements, using the association list [obj_env] to map object names to @@ -465,32 +466,15 @@ let rec cstm_of_act var_env obj_env act = cstm_of_act_list var_env obj_env act) cl in [Cswitch (cexpr_of_exp var_env e, ccl)] + | Ablock b -> + cstm_of_act_list var_env obj_env b + (** For composition of statements, just recursively apply our translation function on sub-statements. *) - | Afor (x, i1, i2, act) -> + | Afor ({ v_ident = x }, i1, i2, act) -> [Cfor(name x, int_of_static_exp i1, int_of_static_exp i2, cstm_of_act_list var_env obj_env act)] - (** Reinitialization of an object variable, extracting the reset - function's name from our environment [obj_env]. *) - | Acall (name_list, o, Mreset, args) -> - assert_empty name_list; - assert_empty args; - let on = obj_ref_name o in - let obj = assoc_obj on obj_env in - let classn = cname_of_qn obj.o_class in - (match obj.o_size with - | None -> - [Csexpr (Cfun_call (classn ^ "_reset", - [Caddrof (Cfield (Cderef (Cvar "self"), local_qn on))]))] - | Some size -> - let x = gen_symbol () in - let field = Cfield (Cderef (Cvar "self"), local_qn on) in - let elt = [Caddrof( Carray(field, Clhs (Cvar x)) )] in - [Cfor(x, 0, int_of_static_exp size, - [Csexpr (Cfun_call (classn ^ "_reset", elt ))] )] - ) - (** Special case for x = 0^n^n...*) | Aassgn (vn, { e_desc = Econst c }) -> let vn = clhs_of_lhs var_env vn in @@ -504,6 +488,26 @@ let rec cstm_of_act var_env obj_env act = let ce = cexpr_of_exp var_env e in create_affect_stm vn ce ty + (** Reinitialization of an object variable, extracting the reset + function's name from our environment [obj_env]. *) + | Acall (name_list, o, Mreset, args) -> + assert_empty name_list; + assert_empty args; + let on = obj_ref_name o in + let obj = assoc_obj on obj_env in + let classn = cname_of_qn obj.o_class in + (match obj.o_size with + | None -> + [Csexpr (Cfun_call (classn ^ "_reset", + [Caddrof (Cfield (Cderef (Cvar "self"), local_qn (name on)))]))] + | Some size -> + let x = gen_symbol () in + let field = Cfield (Cderef (Cvar "self"), local_qn (name on)) in + let elt = [Caddrof( Carray(field, Clhs (Cvar x)) )] in + [Cfor(x, 0, int_of_static_exp size, + [Csexpr (Cfun_call (classn ^ "_reset", elt ))] )] + ) + (** Step functions applications can return multiple values, so we use a local structure to hold the results, before allocating to our variables. *) @@ -537,7 +541,7 @@ let step_fun_args n md = let args = cvarlist_of_ovarlist md.m_inputs in let out_arg = [("out", Cty_ptr (Cty_id (qn_append n "_out")))] in let context_arg = - if is_statefull n then + if is_stateful n then [("self", Cty_ptr (Cty_id (qn_append n "_mem")))] else [] @@ -590,16 +594,16 @@ let mem_decl_of_class_def cd = (** This one just translates the class name to a struct name following the convention we described above. *) let struct_field_of_obj_dec l od = - if is_statefull od.o_class then + if is_stateful od.o_class then let ty = Cty_id (qn_append od.o_class "_mem") in let ty = match od.o_size with | Some se -> Cty_arr (int_of_static_exp se, ty) | None -> ty in - (od.o_name, ty)::l + (name od.o_ident, ty)::l else l in - if is_statefull cd.cd_name then ( + if is_stateful cd.cd_name then ( (** Fields corresponding to normal memory variables. *) let mem_fields = List.map cvar_of_vd cd.cd_mems in (** Fields corresponding to object variables. *) @@ -618,9 +622,13 @@ let out_decl_of_class_def cd = (** [reset_fun_def_of_class_def cd] returns the defintion of the C function tasked to reset the class [cd]. *) let reset_fun_def_of_class_def cd = - let var_env = List.map cvar_of_vd cd.cd_mems in - let reset = find_reset_method cd in - let body = cstm_of_act_list var_env cd.cd_objs reset.m_body in + let body = + try + let var_env = List.map cvar_of_vd cd.cd_mems in + let reset = find_reset_method cd in + cstm_of_act_list var_env cd.cd_objs reset.m_body + with Not_found -> [] (* TODO C : nicely deal with stateless objects *) + in Cfundef { f_name = (cname_of_qn cd.cd_name) ^ "_reset"; f_retty = Cty_void; @@ -631,6 +639,7 @@ let reset_fun_def_of_class_def cd = } } + (** [cdecl_and_cfun_of_class_def cd] translates the class definition [cd] to a C program. *) let cdefs_and_cdecls_of_class_def cd = @@ -647,7 +656,7 @@ let cdefs_and_cdecls_of_class_def cd = let res_fun_decl = cdecl_of_cfundef reset_fun_def in let step_fun_decl = cdecl_of_cfundef step_fun_def in let (decls, defs) = - if is_statefull cd.cd_name then + if is_stateful cd.cd_name then ([res_fun_decl; step_fun_decl], [reset_fun_def; step_fun_def]) else ([step_fun_decl], [step_fun_def]) in @@ -740,11 +749,11 @@ let cfile_list_of_oprog_ty_decls name oprog = filename_types, [types_h; types_c] let global_file_header name prog = - let dependencies = S.elements (Obc_utils.Deps.deps_program prog) in - let dependencies = List.map String.uncapitalize dependencies in + let dependencies = ModulSet.elements (Obc_utils.Deps.deps_program prog) in + let dependencies = List.map modul_to_string dependencies in let (decls, defs) = - List.split (List.map cdefs_and_cdecls_of_class_def prog.p_defs) in + List.split (List.map cdefs_and_cdecls_of_class_def prog.p_classes) in let decls = List.concat decls and defs = List.concat defs in diff --git a/compiler/obc/c/cmain.ml b/compiler/obc/c/cmain.ml index d295da5..e386f92 100644 --- a/compiler/obc/c/cmain.ml +++ b/compiler/obc/c/cmain.ml @@ -13,6 +13,7 @@ open Misc open Names open Idents open Obc +open Obc_utils open Types open Modules open Signature @@ -85,24 +86,24 @@ let assert_node_res cd = (** [main_def_of_class_def cd] returns a [(var_list, rst_i, step_i)] where [var_list] (resp. [rst_i] and [step_i]) is a list of variables (resp. of statements) needed for a main() function calling [cd]. *) -(* TODO: refactor into something more readable. *) let main_def_of_class_def cd = let format_for_type ty = match ty with - | Tarray _ | Tprod _ | Tunit -> assert false + | Tarray _ | Tprod _ | Tmutable _ | Tunit -> assert false | Types.Tid id when id = Initial.pfloat -> "%f" | Types.Tid id when id = Initial.pint -> "%d" | Types.Tid id when id = Initial.pbool -> "%d" - | Tid _ -> "%s" in + | Tid _ -> "%s" + in (** Does reading type [ty] need a buffer? When it is the case, [need_buf_for_ty] also returns the type's name. *) let need_buf_for_ty ty = match ty with - | Tarray _ | Tprod _ | Tunit -> assert false + | Tarray _ | Tprod _ | Tmutable _ | Tunit -> assert false | Types.Tid id when id = Initial.pfloat -> None | Types.Tid id when id = Initial.pint -> None | Types.Tid id when id = Initial.pbool -> None - | Tid { name = n } -> Some n in - + | Tid { name = n } -> Some n + in let cprint_string s = Csexpr (Cfun_call ("printf", [Cconst (Cstrlit s)])) in (** Generates scanf statements. *) @@ -258,11 +259,10 @@ let main_skel var_list prologue body = } let mk_main name p = - match (!Compiler_options.simulation_node, !Compiler_options.assert_nodes) with - | (None, []) -> [] - | (_, n_names) -> + if !Compiler_options.simulation then ( + let n_names = !Compiler_options.assert_nodes in let find_class n = - try List.find (fun cd -> cd.cd_name.name = n) p.p_defs + try List.find (fun cd -> cd.cd_name.name = n) p.p_classes with Not_found -> Format.eprintf "Unknown node %s.@." n; exit 1 in @@ -275,18 +275,16 @@ let mk_main name p = (var @ var_l, res :: res_l, step :: step_l) in List.fold_right add a_classes ([], [], []) in - let (_, var_l, res_l, step_l) = - (match !Compiler_options.simulation_node with - | None -> (n_names, var_l, res_l, step_l) - | Some n -> - let (nvar_l, res, nstep_l) = - main_def_of_class_def (find_class n) in - (n :: n_names, nvar_l @ var_l, - res :: res_l, nstep_l @ step_l)) in + let n = !Compiler_options.simulation_node in + let (nvar_l, res, nstep_l) = main_def_of_class_def (find_class n) in + let (var_l, res_l, step_l) = + (nvar_l @ var_l, res :: res_l, nstep_l @ step_l) in [("_main.c", Csource [main_skel var_l res_l step_l]); ("_main.h", Cheader ([name], []))]; -;; + ) else + [] + (******************************) @@ -297,7 +295,8 @@ let translate name prog = (global_file_header modname prog) @ (mk_main name prog) let program p = - let filename = filename_of_name (cname_of_name p.p_modname) in + let filename = + filename_of_name (cname_of_name (modul_to_string p.p_modname)) in let dirname = build_path (filename ^ "_c") in let dir = clean_dir dirname in let c_ast = translate filename p in diff --git a/compiler/obc/control.ml b/compiler/obc/control.ml index c0a86df..28319a6 100644 --- a/compiler/obc/control.ml +++ b/compiler/obc/control.ml @@ -14,6 +14,7 @@ open Minils open Idents open Misc open Obc +open Obc_utils open Clocks let var_from_name map x = @@ -38,12 +39,12 @@ let rec control map ck s = | Cvar { contents = Clink ck } -> control map ck s | Con(ck, c, n) -> let x = var_from_name map n in - control map ck (Acase(mk_exp (Elhs x), [(c, mk_block [s])])) + control map ck (Acase(mk_exp x.pat_ty (Epattern x), [(c, mk_block [s])])) let is_deadcode = function | Aassgn (lhs, e) -> (match e.e_desc with - | Elhs l -> l = lhs + | Epattern l -> l = lhs | _ -> false ) | Acase (_, []) -> true diff --git a/compiler/obc/java/java.ml b/compiler/obc/java/java.ml index 1e6b895..f2b5d2b 100644 --- a/compiler/obc/java/java.ml +++ b/compiler/obc/java/java.ml @@ -7,582 +7,146 @@ (* *) (**************************************************************************) +type class_name = Names.qualname (** [qual] is the package name, [Name] is the class name *) +type obj_ident = Idents.var_ident +type constructor_name = Names.qualname (** [Qual] is the enum class name (type), [NAME] is the constructor name *) +type const_name = Names.qualname +type method_name = Names.name +type field_name = Names.name +type field_ident = Idents.var_ident +type op_name = Names.qualname +type var_ident = Idents.var_ident -open Signature -open Modules -open Format -open Obc -open Misc -open Names -open Idents -open Pp_tools +type ty = Tclass of class_name + | Tgeneric of class_name * ty list + | Tbool + | Tint + | Tfloat + | Tarray of ty * exp + | Tref of ty + | Tunit -let jname_of_name name = - let b = Buffer.create (String.length name) in - let rec convert c = - match c with - | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> - Buffer.add_char b c - | '\'' -> Buffer.add_string b "_prime" - | _ -> - Buffer.add_string b "lex"; - Buffer.add_string b (string_of_int (Char.code c)); - Buffer.add_string b "_" in +and classe = { c_protection : protection; + c_static : bool; + c_name : class_name; + c_imports : class_name list; + c_implements : class_name list; + c_kind : class_kind } - String.iter convert name; - Buffer.contents b +and class_kind = Cenum of constructor_name list + | Cgeneric of class_desc -let print_name ff name = - fprintf ff "%s" (jname_of_name name) +and class_desc = { cd_fields : field list; + cd_classs : classe list; + cd_constructors : methode list; + cd_methodes : methode list; } -let print_shortname ff longname = - print_name ff (shortname longname) +and var_dec = { vd_type : ty; + vd_ident : var_ident } -let o_types : type_dec list ref = ref [] +and protection = Ppublic | Pprotected | Pprivate | Ppackage -let java_type_default_value = function - | Tint -> "int", "0" - | Tfloat -> "float", "0.0" - | Tid (Name("bool")) - | Tid (Modname({ id = "bool" })) -> - "boolean", "false" - | Tid t when ((shortname t) = "int") -> "int", "0" - | Tid t when ((shortname t) = "float") -> "float", "0.0" - | Tid t -> - begin try - let { info = ty_desc } = find_type (t) in - begin match ty_desc with - | Tenum _ -> - "int", "0" - | _ -> - let t = shortname t in - if t = "bool" - then ("boolean", "false") - else (t, "null") - end - with Not_found -> - begin try - let { t_desc = tdesc } = - List.find (fun {t_name = tn} -> tn = (shortname t)) !o_types in - begin match tdesc with - | Type_enum _ -> - "int", "0" - | _ -> - let t = shortname t in - if t = "bool" - then ("boolean", "false") - else (t, "null") - end - with Not_found -> - let t = shortname t in - if t = "bool" - then ("boolean", "false") - else (t, "null") - end - end +and field = { f_protection : protection; + f_static : bool; + f_final : bool; + f_type : ty; + f_ident : field_ident; + f_value : exp option } -let print_type ff ty = - let jty,_ = java_type_default_value ty in - print_name ff jty - -let print_field ff (name,ty) = - fprintf ff "%a %a;" - print_type ty - print_name name - -let print_const_field ff (name,ty) = - fprintf ff "%a@ %a" - print_type ty - print_name name - -let print_assgt_field ff (name,_) = - fprintf ff "this.%a = %a;" - print_name name - print_name name - -(* assumes tn is already translated with jname_of_name *) -let print_struct_type ff tn fields = - fprintf ff "@[@[public class %s {@ " tn; - (* fields *) - print_list print_field "" "" "" ff fields; - (* constructor *) - let sorted_fields = - List.sort - (fun (n1,_) (n2,_) -> String.compare n1 n2) - fields in - fprintf ff "@ @[public %s(@[" tn; - print_list print_const_field "" "," "" ff sorted_fields; - fprintf ff "@]) {@ "; - (* constructor assignments *) - print_list print_assgt_field "" "" "" ff fields; - (* constructor end *) - fprintf ff "@]@ }"; - (* class end *) - fprintf ff "@]@ }@]" +and methode = { m_protection : protection; + m_static : bool; + m_name : method_name; + m_args : var_dec list; + m_returns : ty; + m_throws : class_name list; + m_body : block; } -let rec print_tags ff n = function - | [] -> () - | tg :: tgs' -> - fprintf ff "@ public static final int %a = %d;" - print_name tg - n; - print_tags ff (n+1) tgs' +and block = { b_locals : var_dec list; + b_body : act list; } -(* assumes tn is already translated with jname_of_name *) -let print_enum_type ff tn tgs = - fprintf ff "@[@[public class %s {" tn; - print_tags ff 1 tgs; - fprintf ff "@]@ }@]" +and act = Anewvar of var_dec * exp + | Aassgn of pattern * exp + | Amethod_call of exp * method_name * exp list + | Aswitch of exp * (constructor_name * block) list + | Aif of exp * block + | Aifelse of exp * block * block + | Ablock of block + | Afor of var_dec * exp * exp * block + | Areturn of exp -let print_type_to_file java_dir headers { t_name = tn; t_desc = td} = - let tn = jname_of_name tn in - match td with - | Type_abs -> () - | Type_enum tgs -> - let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in - let ff = formatter_of_out_channel out_ch in - Misc.print_header_info ff "/*" "*/"; - List.iter (fprintf ff "%s") headers; - (* fprintf ff "@[package %s;@\n@\n" headers; *) - print_enum_type ff tn tgs; - fprintf ff "@."; - close_out out_ch - | Type_struct fields -> - let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in - let ff = formatter_of_out_channel out_ch in - Misc.print_header_info ff "/*" "*/"; - List.iter (fprintf ff "%s") headers; - (* fprintf ff "@[package %s;@\n@\n" headers; *) - print_struct_type ff tn fields; - fprintf ff "@."; - close_out out_ch - -let print_types java_dir headers tps = - List.iter (print_type_to_file java_dir headers) tps - -(******************************) - -type answer = - | Sing of var_ident - | Mult of var_ident list - -let print_const ff c ts = - match c with - | Cint i -> fprintf ff "%d" i - | Cfloat f -> fprintf ff "%f" f - | Cconstr t -> - let s = - match t with - | Name("true") - | Modname({id = "true"}) -> "true" - | Name("false") - | Modname({id = "false"}) -> "false" - | Name(tg) - | Modname({id = tg}) -> - (fst - (List.find - (fun (tn, tgs) -> - List.exists (fun tg' -> tg = tg') tgs) - ts)) - ^ "." ^ (jname_of_name tg) - in - fprintf ff "%s" s - -let position a xs = - let rec walk i = function - | [] -> None - | x :: xs' -> if x = a then Some i else walk (i + 1) xs' - in walk 1 xs - -let print_ident ff id = - print_name ff (name id) - -let print_var ff x avs single = - match (position x avs) with - | None -> print_ident ff x - | Some n -> - if single then print_ident ff (List.hd avs) - else fprintf ff "step_ans.c_%d" n - -let javaop_of_op = function - | "=" -> "==" - | "<>" -> "!=" - | "or" -> "||" - | "&" -> "&&" - | "*." -> "*" - | "/." -> "/" - | "+." -> "+" - | "-." -> "-" - | op -> op - -let priority = function - | "*" | "/" | "*." | "/." -> 5 - | "+" | "-" | "+." | "-." -> 4 - | "=" | "<>" | "<=" | "=>" -> 3 - | "&" -> 2 - | "|" -> 1 - | _ -> 0 - -let rec print_lhs ff e avs single = - match e with - | Var x -> - print_var ff x avs single - | Mem x -> print_ident ff x - | Field(e, field) -> - print_lhs ff e avs single; - fprintf ff ".%s" (jname_of_name (shortname field)) - -let rec print_exp ff e p avs ts single = - match e with - | Lhs l -> print_lhs ff l avs single - | Const c -> print_const ff c ts - | Op (op, es) -> print_op ff op es p avs ts single - | Struct_lit(type_name,fields) -> - let fields = - List.sort - (fun (ln1,_) (ln2,_) -> - String.compare (shortname ln1) (shortname ln2)) - fields in - let exps = List.map (fun (_,e) -> e) fields in - fprintf ff "new %a(@[" - print_shortname type_name; - print_exps ff exps 0 avs ts single; - fprintf ff "@])" - -and print_exps ff es p avs ts single = - match es with - | [] -> () - | [e] -> print_exp ff e p avs ts single - | e :: es' -> - print_exp ff e p avs ts single; - fprintf ff ",@ "; - print_exps ff es' p avs ts single - -and print_op ff op es p avs ts single = - match (shortname op), es with - | (("+" | "-" | "*" | "/" - |"+." | "-." | "*." | "/." - | "=" | "<>" | "<" | "<=" - | ">" | ">=" | "&" | "or") as op_name, [e1;e2]) -> - let p' = priority op_name in - if p' < p then fprintf ff "(" else (); - print_exp ff e1 p' avs ts single; - fprintf ff " %s " (javaop_of_op op_name); - print_exp ff e2 p' avs ts single; - if p' < p then fprintf ff ")" else () - | "not", [e] -> - fprintf ff "!"; - print_exp ff e 6 avs ts single; - | "~-", [e] -> - fprintf ff "-"; - print_exp ff e 6 avs ts single; - | _ -> - begin - begin - match op with - | Name(op_name) -> - print_name ff op_name; - | Modname({ qual = mod_name; id = op_name }) -> - fprintf ff "%a.%a" - print_name (String.uncapitalize mod_name) - print_name op_name - end; - fprintf ff "@[("; - print_exps ff es 0 avs ts single; - fprintf ff ")@]" - end - -let rec print_proj ff xs ao avs single = - let rec walk ind = function - | [] -> () - | x :: xs' -> - print_lhs ff x avs single; - fprintf ff " = %s.c_%d;@ " ao ind; - walk (ind + 1) xs' - in walk 1 xs +and exp = Eval of pattern + | Ethis + | Efun of op_name * exp list + | Emethod_call of exp * method_name * exp list + | Enew of ty * exp list + | Enew_array of ty * exp list (** [ty] is the array base type *) + | Evoid (*printed as nothing*) + | Ecast of ty * exp + | Svar of const_name + | Sint of int + | Sfloat of float + | Sbool of bool + | Sconstructor of constructor_name + | Sstring of string + | Snull -let bool_case = function - | [] -> assert false - | ("true", _) :: _ - | ("false", _) :: _ -> true - | _ -> false +and pattern = Pfield of pattern * field_name + | Pclass of class_name + | Pvar of var_ident + | Parray_elem of pattern * exp + | Pthis of field_ident -let obj_call_to_string = function - | Context o - | Array_context (o,_) -> o +type program = classe list -let rec print_act ff a objs avs ts single = - match a with - | Assgn (x, e) -> - fprintf ff "@["; - print_asgn ff x e avs ts single; - fprintf ff ";@]" - | Step_ap (xs, o, es) -> - let o = obj_call_to_string o in - (match xs with - | [x] -> - print_lhs ff x avs single; - fprintf ff " = %s.step(" o; - fprintf ff "@["; - print_exps ff es 0 avs ts single; - fprintf ff "@]"; - fprintf ff ");@ " - | xs -> - let cn = (List.find (fun od -> od.obj = o) objs).cls in - let at = (jname_of_name (shortname cn)) ^ "Answer" in - let ao = o ^ "_ans" in - fprintf ff "%s %s = new %s();@ " at ao at; - fprintf ff "%s = %s.step(" ao o; - fprintf ff "@["; - print_exps ff es 0 avs ts single; - fprintf ff "@]"; - fprintf ff ");@ "; - print_proj ff xs ao avs single) - | Comp (a1, a2) -> - print_act ff a1 objs avs ts single; - (match a2 with - | Nothing -> () - | _ -> fprintf ff "@ "); - print_act ff a2 objs avs ts single - | Case (e, grds) -> - let grds = - List.map - (fun (ln,act) -> (shortname ln),act) grds in - if bool_case grds - then print_if ff e grds objs avs ts single - else (fprintf ff "@[@[switch (%a) {@ " - (fun ff e -> print_exp ff e 0 avs ts single) e; - print_grds ff grds objs avs ts single; - fprintf ff "@]@ }@]"); - | Reinit o -> fprintf ff "%s.reset();" o - | Nothing -> () -and print_grds ff grds objs avs ts single = - match grds with - | [] -> () - | [(tg, act)] -> - (* retrieve class name *) - let cn = (fst - (List.find - (fun (tn, tgs) -> - List.exists (fun tg' -> tg = tg') tgs) - ts)) in - fprintf ff "@[case %a.%a:@ " - print_name cn - print_name tg; - print_act ff act objs avs ts single; - fprintf ff "@ break;@]"; - | (tg, act) :: grds' -> - (* retrieve class name *) - let cn = (fst - (List.find - (fun (tn, tgs) -> - List.exists (fun tg' -> tg = tg') tgs) - ts)) in - fprintf ff "@[case %a.%a:@ " - print_name cn - print_name tg; - print_act ff act objs avs ts single; - fprintf ff "@ break;@ @]@ "; - print_grds ff grds' objs avs ts single +let rec default_value ty = match ty with + | Tclass _ -> Snull + | Tgeneric _ -> Snull + | Tbool -> Sbool true + | Tint -> Sint 0 + | Tfloat -> Sfloat 0.0 + | Tunit -> Evoid + | Tref t -> default_value t + | Tarray _ -> Enew_array (ty,[]) -and print_if ff e grds objs avs ts single = - match grds with - | [("true", a)] -> - fprintf ff "@[@[if (%a) {@ " - (fun ff e -> print_exp ff e 0 avs ts single) e; - print_act ff a objs avs ts single; - fprintf ff "@]@ }@]" - | [("false", a)] -> - fprintf ff "@[@[if (!%a) {@ " - (fun ff e -> print_exp ff e 6 avs ts single) e; - print_act ff a objs avs ts single; - fprintf ff "@]@ }@]" - | [("true", a1); ("false", a2)] -> - fprintf ff "@[@[if (%a) {@ " - (fun ff e -> print_exp ff e 0 avs ts single) e; - print_act ff a1 objs avs ts single; - fprintf ff "@]@ @[} else {@ "; - print_act ff a2 objs avs ts single; - fprintf ff "@]@ }@]" - | [("false", a2); ("true", a1)] -> - fprintf ff "@[@[if (%a) {@ " - (fun ff e -> print_exp ff e 0 avs ts single) e; - print_act ff a1 objs avs ts single; - fprintf ff "@]@ @[} else {@ "; - print_act ff a2 objs avs ts single; - fprintf ff "@]@ }@]" - | _ -> assert false -and print_asgn ff x e avs ts single = - fprintf ff "@["; - print_lhs ff x avs single; - fprintf ff " = "; - print_exp ff e 0 avs ts single; - fprintf ff "@]" +let java_pervasive_class c = Names.qualname_of_string ("jeptagon.Pervasives."^c) +let the_java_pervasives = Names.qualname_of_string "jeptagon.Pervasives" -let print_vd ff vd = - let jty,jdv = java_type_default_value vd.v_type in - fprintf ff "@["; - print_name ff jty; - fprintf ff " %s = %s;" - (jname_of_name (name vd.v_ident)) - jdv; - fprintf ff "@]" -let print_obj ff od = - fprintf ff "@["; - fprintf ff "%a %a = new %a();" - print_shortname od.cls - print_name od.obj - print_shortname od.cls; - fprintf ff "@]" +let mk_var x = Eval (Pvar x) -let rec print_objs ff ods = - match ods with - | [] -> () - | od :: ods' -> - print_obj ff od; - fprintf ff "@ "; - print_objs ff ods' +let mk_var_dec x ty = + { vd_type = ty; vd_ident = x } -let print_comps ff fds= - let rec walk n = function - | [] -> () - | fd :: fds' -> - fprintf ff "@ "; - fprintf ff "public "; - print_type ff fd.v_type; - fprintf ff " c_%s;" (string_of_int n); - walk (n + 1) fds' - in walk 1 fds +let mk_block ?(locals=[]) b = + { b_locals = locals; b_body = b; } -let print_ans_struct ff name fields = - fprintf ff "@[@[public class %s {" name; - print_comps ff fields; - fprintf ff "@]@ }@]@ " -let print_vd' ff vd = - fprintf ff "@["; - print_type ff vd.v_type; - fprintf ff "@ %s" (jname_of_name (name vd.v_ident)); - fprintf ff "@]" +let mk_methode ?(protection=Ppublic) ?(static=false) ?(args=[]) ?(returns=Tunit) ?(throws=[]) + body name = + { m_protection = protection; m_static = static; m_name = name; m_args = args; + m_throws = throws; m_returns = returns; m_body = body; } -let rec print_in ff = function - | [] -> () - | [vd] -> print_vd' ff vd - | vd :: vds' -> - print_vd' ff vd; - fprintf ff ",@ "; - print_in ff vds' +let mk_classe ?(imports=[]) ?(protection=Ppublic) ?(static=false) ?(fields=[]) + ?(classes=[]) ?(constrs=[]) ?(methodes=[]) ?(implements=[]) + class_name = + { c_protection = protection; c_static = static; c_name = class_name; c_imports = imports; c_implements = implements; + c_kind = Cgeneric { cd_fields = fields; cd_classs = classes; cd_constructors = constrs; cd_methodes = methodes; } } -let rec print_mem ff = function - | [] -> () - | vd :: m' -> - print_vd ff vd; - fprintf ff "@ "; - print_mem ff m' +let mk_enum ?(protection=Ppublic) ?(static=false) ?(imports=[]) ?(implements=[]) + constructor_names class_name = + { c_protection = protection; c_static = static; c_name = class_name; c_imports = imports; c_implements = implements; + c_kind = Cenum(constructor_names) } -let print_loc ff vds = print_mem ff vds -let print_step ff n s objs ts single = - let name = jname_of_name n in - fprintf ff "@[@ @[public "; - if single then print_type ff (List.hd s.out).v_type - else fprintf ff "%s" (n ^ "Answer"); - fprintf ff " step(@["; - print_in ff s.inp; - fprintf ff "@]) {@ "; - let loc = if single then (List.hd s.out) :: s.local else s.local in - if loc = [] then () else (print_loc ff loc; fprintf ff "@ "); - if single then fprintf ff "@ " - else fprintf ff "%sAnswer step_ans = new %sAnswer();@ @ " n n; - print_act ff s.bd objs - (List.map (fun vd -> vd.v_ident) s.out) ts single; - fprintf ff "@ @ return "; - if single - then fprintf ff "%s" (jname_of_name (Idents.name (List.hd s.out).v_ident)) - else fprintf ff "step_ans"; - fprintf ff ";@]@ }@ @]" +let mk_field ?(protection = Ppublic) ?(static = false) ?(final = false) ?(value = None) + ty ident = + { f_protection = protection; f_static = static; f_final = final; f_type = ty; f_ident = ident; f_value = value } -let print_reset ff r ts = - fprintf ff "@[@ @[public void reset() {@ "; - print_act ff r [] [] ts false; - fprintf ff "@]@ }@ @]" +let vds_to_exps vd_l = List.map (fun { vd_ident = x } -> mk_var x) vd_l -let print_class ff headers ts single opened_mod cl = - let clid = jname_of_name cl.cl_id in - List.iter (fprintf ff "%s") headers; - (* fprintf ff "@[package %s;@\n@\n" headers; *) - (* import opened modules *) - List.iter - (fun m -> - fprintf ff "import %s.*;@\n" (String.uncapitalize m)) - opened_mod; - - fprintf ff "@\n@[public class %s {@ " clid; - if cl.mem = [] then () - else fprintf ff "@[@ "; print_mem ff cl.mem; fprintf ff "@]"; - if cl.objs = [] then () - else fprintf ff "@[@ "; print_objs ff cl.objs; fprintf ff "@]"; - print_reset ff cl.reset ts; - print_step ff clid cl.step cl.objs ts single; - fprintf ff "@]@ }@]" - -let print_class_and_answer_to_file java_dir headers ts opened_mod cl = - let clid = jname_of_name cl.cl_id in - let print_class_to_file single = - let out_ch = open_out (java_dir ^ "/" ^ clid ^ ".java") in - let ff = formatter_of_out_channel out_ch in - Misc.print_header_info ff "/*" "*/"; - print_class ff headers ts single opened_mod cl; - fprintf ff "@."; - close_out out_ch - in - match cl.step.out with - | [_] -> print_class_to_file true - | _ -> - let out_ch = open_out (java_dir ^ "/" ^ clid ^ "Answer.java") in - let ff = formatter_of_out_channel out_ch in - Misc.print_header_info ff "/*" "*/"; - List.iter (fprintf ff "%s") headers; - (* fprintf ff "@[package %s;@\n@\n" headers; *) - List.iter - (fun m -> - fprintf ff "import %s.*;@\n" (String.uncapitalize m)) - opened_mod; - print_ans_struct ff (clid ^ "Answer") cl.step.out; - fprintf ff "@."; - close_out out_ch; - print_class_to_file false - -let print_classes java_dir headers ts opened_mod cls = - List.iter - (print_class_and_answer_to_file java_dir headers ts opened_mod) - cls - -(******************************) -let print java_dir p = - let headers = - List.map snd - (List.filter - (fun (tag,_) -> tag = "java") - p.o_pragmas) in - print_types java_dir headers p.o_types; - o_types := p.o_types; - print_classes - java_dir headers - (List.flatten - (List.map - (function - | { t_desc = Type_abs } -> [] - | { t_name = tn; t_desc = Type_enum tgs } -> [tn, tgs] - | { t_name = tn; t_desc = Type_struct fields } -> - [tn, (List.map fst fields)]) - p.o_types)) - p.o_opened - p.o_defs - -(******************************) +let vds_to_fields ?(protection=Ppublic) vd_l = + List.map (fun { vd_ident = x; vd_type = t } -> mk_field ~protection:protection t x) vd_l diff --git a/compiler/obc/java/java_main.ml b/compiler/obc/java/java_main.ml new file mode 100644 index 0000000..6dc8851 --- /dev/null +++ b/compiler/obc/java/java_main.ml @@ -0,0 +1,69 @@ +open Misc +open Java +open Java_printer + +(** returns the vd and the pat of a fresh ident from [name] *) +let mk_var ty name = + let id = Idents.gen_var "java_main" name in + mk_var_dec id ty, Pvar id + +let program p = + let p_java = Obc2java.program p in + let dir = Compiler_utils.build_path "java" in + Compiler_utils.ensure_dir dir; + + (* Compile and output the nodes *) + output_program dir p_java; + + (* Create a runnable main simulation *) + if !Compiler_options.simulation + then ( + let class_name = Obc2java.fresh_classe (!Compiler_options.simulation_node ^ "_sim") in + Idents.enter_node class_name; + let field_step_dnb, id_step_dnb = + let id = Idents.gen_var "java_main" "default_step_nb" in + mk_field ~static:true ~final:true ~value:(Some (Sint 30000)) Tint id, id + in + let main_methode = + let vd_step, pat_step = mk_var Tint "step" in + let vd_args, pat_args = mk_var (Tarray (Tclass (Names.pervasives_qn "String"), (Sint 0))) "args" in + let body = + let vd_main, e_main, q_main = + let q_main = !Compiler_options.simulation_node |> Modules.qualify_value |> Obc2java.qualname_to_package_classe + in let id = Idents.gen_var "java_main" "main" in + mk_var_dec id (Tclass q_main), Eval (Pvar id), q_main + in + let acts = + let integer = Eval(Pclass(Names.pervasives_qn "Integer")) in + let args1 = Eval(Parray_elem(pat_args, Sint 1)) in + let out = Eval(Pclass(Names.qualname_of_string "java.lang.System.out")) in + let vd_r, pat_r = mk_var Tint "r" in + let step_call = Anewvar(vd_r, Emethod_call(e_main, "step", [])) in + [ Anewvar(vd_main, Enew (Tclass q_main, [])); + Aifelse( Efun(Names.pervasives_qn ">", [Eval (Pfield (pat_args, "length")); Sint 1]) + , mk_block [Aassgn(pat_step, Emethod_call(integer, "parseInt", [args1]))] + , mk_block [Aassgn(pat_step, Eval (Pvar id_step_dnb))]); + Obc2java.fresh_for (Eval pat_step) + (fun i -> + let printing = + if !Compiler_options.verbose + then [Amethod_call(out, "printf", [Sstring "%d => %d\\n"; Eval (Pvar i); Eval pat_r])] + else [] + in step_call::printing ) + ] + in + mk_block ~locals:[vd_step] acts + in + mk_methode ~static:true ~args:[vd_args] body "main" + in + let c = mk_classe ~fields:[field_step_dnb] ~methodes:[main_methode] class_name in + output_program dir [c] + ) + + + + + + + + diff --git a/compiler/obc/java/java_printer.ml b/compiler/obc/java/java_printer.ml new file mode 100644 index 0000000..173388e --- /dev/null +++ b/compiler/obc/java/java_printer.ml @@ -0,0 +1,233 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* Java printer *) + +open Java +open Pp_tools +open Format +open Misc + +let class_name = Global_printer.print_qualname +let bare_class_name = Global_printer.print_shortname +let obj_ident = Global_printer.print_ident +let constructor_name = Global_printer.print_qualname +let bare_constructor_name = Global_printer.print_shortname +let method_name = pp_print_string +let field_name = pp_print_string +let field_ident = Global_printer.print_ident +let var_ident = Global_printer.print_ident +let const_name = Global_printer.print_qualname + +let protection ff = function + | Ppublic -> fprintf ff "public " + | Pprotected -> fprintf ff "protected " + | Pprivate -> fprintf ff "private " + | Ppackage -> () + +let static ff s = if s then fprintf ff "static " else () + +let final ff f = if f then fprintf ff "final " else () + +let rec _ty size ff t = match t with + | Tbool -> fprintf ff "boolean" + | Tint -> fprintf ff "int" + | Tfloat -> fprintf ff "float" + | Tclass n -> class_name ff n + | Tgeneric (n, ty_l) -> fprintf ff "%a<@[%a@]>" class_name n (print_list_r ty """,""") ty_l + | Tarray (t,s) -> if size then fprintf ff "%a[%a]" full_ty t exp s else fprintf ff "%a[]" ty t + | Tref t -> ty ff t + | Tunit -> pp_print_string ff "void" + +and full_ty ff t = _ty true ff t + +and ty ff t = _ty false ff t + +and var_dec init ff vd = + if init then + fprintf ff "%a %a = %a" ty vd.vd_type var_ident vd.vd_ident exp (Java.default_value vd.vd_type) + else + fprintf ff "%a %a" ty vd.vd_type var_ident vd.vd_ident + +and vd_list s1 s2 s3 ff vd_l = match vd_l with + | [] -> () + | _ -> fprintf ff "@[%a@]@\n" (print_list_r (var_dec true) s1 s2 s3) vd_l + +and field ff f = + fprintf ff "@[<2>%a%a%a%a %a%a@]" + protection f.f_protection + static f.f_static + final f.f_final + ty f.f_type + field_ident f.f_ident + (print_opt2 exp " = ") f.f_value + +and exp ff = function + | Ethis -> fprintf ff "this" + | Eval p -> pattern ff p + | Efun (f,e_l) -> op ff (f, e_l) + | Emethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" exp o method_name m args e_l + | Enew (c,e_l) -> fprintf ff "new %a%a" full_ty c args e_l + | Enew_array (t,e_l) -> + (match e_l with + | [] -> fprintf ff "new %a" full_ty t + | _ -> fprintf ff "new %a@[<2>%a@]" ty t (print_list_r exp "{"",""}") e_l ) + | Evoid -> () + | Ecast (t,e) -> fprintf ff "(%a)(%a)" ty t exp e + | Svar c -> const_name ff c + | Sint i -> pp_print_int ff i + | Sfloat f -> pp_print_float ff f + | Sbool b -> pp_print_bool ff b + | Sconstructor c -> constructor_name ff c + | Sstring s -> fprintf ff "\"%s\"" s + | Snull -> fprintf ff "null" + +and op ff (f, e_l) = + let javaop = function + | "=" -> "==" + | "<>" -> "!=" + | "or" -> "||" + | "&" -> "&&" + | "*." -> "*" + | "/." -> "/" + | "+." -> "+" + | "-." -> "-" + | op -> op + in + match Names.modul f with + | Names.Pervasives -> + (match Names.shortname f with + |("+" | "-" | "*" | "/" + |"+." | "-." | "*." | "/." + | "=" | "<>" | "<" | "<=" + | ">" | ">=" | "&" | "or") as n -> + let e1,e2 = Misc.assert_2 e_l in + fprintf ff "(@[%a@ %s %a@])" exp e1 (javaop n) exp e2 + | "not" -> + let e = Misc.assert_1 e_l in + fprintf ff "!%a" exp e + | "~-" -> + let e = Misc.assert_1 e_l in + fprintf ff "-%a" exp e + | s -> fprintf ff "jeptagon.Pervasives.%s%a" s args e_l) (* TODO java deal with this correctly + bug when using Pervasives.ggg in the code but works when using ggg directly *) + | _ -> fprintf ff "%a%a" Global_printer.print_qualname f args e_l + +and args ff e_l = fprintf ff "@[(%a)@]" (print_list_r exp """,""") e_l + +and pattern ff = function + | Pfield (p,f) -> fprintf ff "%a.%a" pattern p field_name f + | Pvar v -> var_ident ff v + | Pclass c -> class_name ff c + | Parray_elem (p,e) -> fprintf ff "%a[%a]" pattern p exp e + | Pthis f -> fprintf ff "this.%a" field_ident f + +let rec block ff b = + fprintf ff "%a%a" + (vd_list """;"";") b.b_locals + (print_list_r act """""") b.b_body + +(* +and switch_hack ff c_b_l = + fprintf ff "@[ default :\\Dead code. Hack to prevent \"may not be initialized\" java error.@ %a@ break;@]" + block (c_b_l |> List.hd |> snd) +*) + +and act ff = function + | Anewvar (vd,e) -> fprintf ff "@[<4>%a =@ %a;@]" (var_dec false) vd exp e + | Aassgn (p,e) -> fprintf ff "@[<4>%a =@ %a;@]" pattern p exp e + | Amethod_call (o,m,e_l) -> fprintf ff "@[%a.%a%a;@]" exp o method_name m args e_l + | Aswitch (e, c_b_l) -> + let pcb ff (c,b) = fprintf ff "@[case %a:@ %a@ break;@]" bare_constructor_name c block b in + (* let switch_hack ff c_b_l = (* TODO java : better thing to do ? *) + fprintf ff "@[<2>default ://Dead code. Hack to prevent \ + \"may not be initialized\" java error.@ %a@ break;@]" block (c_b_l |> List.hd |> snd) + in*) + fprintf ff "@[switch (%a) {@ %a@]@\n}" + exp e + (print_list_r pcb """""") c_b_l + | Aif (e,bt) -> + fprintf ff "@[if (%a) {@ %a }@]" exp e block bt + | Aifelse (e,bt,bf) -> + fprintf ff "@[@[if (%a) {@ %a@]@ @[} else {@ %a@]@ }@]" + exp e + block bt + block bf + | Ablock b -> if (List.length b.b_body > 0) then fprintf ff "@[@[{@ %a@]@ }@]" block b + | Afor (x, i1, i2, b) -> + fprintf ff "@[@[for (%a = %a; %a<%a; %a++) {@ %a@]@ }@]" + (var_dec false) x + exp i1 + var_ident x.vd_ident + exp i2 + var_ident x.vd_ident + block b + | Areturn e -> fprintf ff "return %a;" exp e + +let methode ff m = + fprintf ff "@[%a%a%a %a @[<4>(%a)@] @[%a@]{@ %a@]@\n}" + protection m.m_protection + static m.m_static + ty m.m_returns + method_name m.m_name + (print_list_r (var_dec false) """,""") m.m_args + (print_list_r class_name "throws "","" ") m.m_throws + block m.m_body + +let constructor ff m = + fprintf ff "@[%a%a @[<4>(%a)@] {@\n%a@]@\n}" + protection m.m_protection + method_name m.m_name + (print_list_r (var_dec false) """,""") m.m_args + block m.m_body + +let rec class_desc ff cd = + fprintf ff "@[%a@ %a@ %a@ %a@]" + (print_list_r field """;"";") cd.cd_fields + (print_list_r classe """""") cd.cd_classs + (print_list constructor """""") cd.cd_constructors + (print_list methode """""") cd.cd_methodes + +and classe ff c = match c.c_kind with + | Cenum c_l -> + fprintf ff "@\n@[<4>%a%aenum %a {@\n%a@]@\n}" + protection c.c_protection + static c.c_static + bare_class_name c.c_name + (print_list_r bare_constructor_name """,""") c_l + | Cgeneric cd -> + fprintf ff "@\n@[<4>%a%aclass %a @[%a@]{@\n%a@]@\n}" + protection c.c_protection + static c.c_static + bare_class_name c.c_name + (print_list_r class_name "implements "",""") c.c_implements + class_desc cd + +let output_classe base_dir c = + let { Names.name = file_name; Names.qual = package } = c.c_name in + let file_name = file_name ^ ".java" in + let package_dirs = Misc.split_string (Names.modul_to_string package) "." in + let create_dir base_dir dir = + let dir = Filename.concat base_dir dir in + Compiler_utils.ensure_dir dir; + dir + in + let dir = List.fold_left create_dir base_dir package_dirs in + let oc = open_out (Filename.concat dir file_name) in + let ff = Format.formatter_of_out_channel oc in + pp_set_margin ff 120; + fprintf ff "package %a;@\n@[%a@]@\n%a@." + Global_printer.print_full_modul package + (print_list_r (fun ff n -> fprintf ff "import %a" class_name n) """;"";") c.c_imports + classe c; + close_out oc + +let output_program dir (p:Java.program) = + List.iter (output_classe dir) p + diff --git a/compiler/obc/java/javamain.ml b/compiler/obc/java/javamain.ml deleted file mode 100644 index e83e6c5..0000000 --- a/compiler/obc/java/javamain.ml +++ /dev/null @@ -1,6 +0,0 @@ - -let program p = - let filename = filename_of_module p in - let dirname = build_path filename in - let dir = clean_dir dirname in - Java.print dir o diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml new file mode 100644 index 0000000..195e7db --- /dev/null +++ b/compiler/obc/java/obc2java.ml @@ -0,0 +1,407 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(** An Obc.program is a Java.package, + Obc.type_dec, Obc.class_def are Java.classs + Obc.const_dec is defined in the special class CONSTANTES + Obc.Lvar are Pvar + Obc.Lmem are this.Pvar (Pfield) + Obc.Oobj and Oarray are simply Pvar and Parray_elem + Obc.Types_alias are dereferenced since no simple type alias is possible in Java *) + +(** Requires scalar Obc : [p = e] when [e] is an array is understand as a copy of the reference, + not a copy of the array. *) + +open Format +open Misc +open Names +open Modules +open Signature +open Obc +open Obc_utils +open Java + + +(** Additional classes created during the translation *) +let add_classe, get_classes = + let extra_classes = ref [] in + (fun c -> extra_classes := c :: !extra_classes) + ,(fun () -> !extra_classes) + +(** fresh Afor from 0 to [size] with [body] a function from [var_ident] (the iterator) to [act] list *) +let fresh_for size body = + let i = Idents.gen_var "obc2java" "i" in + let id = mk_var_dec i Tint in + Afor (id, Sint 0, size, mk_block (body i)) + + (* current module is not translated to keep track, there is no issue since printed without the qualifier *) +let rec translate_modul m = match m with + | Pervasives + | LocalModule -> m + | _ when m = g_env.current_mod -> m + | Module n -> Module (String.lowercase n) + | QualModule { qual = q; name = n} -> QualModule { qual = translate_modul q; name = String.lowercase n } + +(** a [Module.const] becomes a [module.CONSTANTES.CONST] *) +let translate_const_name { qual = m; name = n } = + { qual = QualModule { qual = translate_modul m; name = "CONSTANTES"}; name = String.uppercase n } + +(** a [Module.fun] becomes a [module.FUNS.fun] *) +let translate_fun_name { qual = m; name = n } = + { qual = QualModule { qual = translate_modul m; name = "FUNS"}; name = n } + +(** a [Module.name] becomes a [module.Name] + used for type_names, class_names, fun_names *) +let qualname_to_class_name q = + { qual = translate_modul q.qual; name = String.capitalize q.name } + +(** a [Module.name] becomes a [module.Name] even on current_mod *) +let qualname_to_package_classe q = + { qual = translate_modul q.qual; name = String.capitalize q.name } + +(** Create a fresh class qual from a name *) +let fresh_classe n = Modules.fresh_value "obc2java" n |> qualname_to_package_classe + +(** a [Module.Constr] of an [Module.enum] type becomes a [module.Enum.CONSTR] of the [module.Enum] class *) +let translate_constructor_name_2 q q_ty = + let classe = qualname_to_class_name q_ty in + { qual = QualModule classe; name = String.uppercase q.name } + +let translate_constructor_name q = + match Modules.find_constrs q with + | Types.Tid q_ty when q_ty = Initial.pbool -> q |> shortname |> local_qn + | Types.Tid q_ty -> translate_constructor_name_2 q q_ty + | _ -> assert false + +let translate_field_name f = f |> Names.shortname |> String.lowercase + +(** a [name] becomes a [package.Name] *) +let name_to_classe_name n = n |> Modules.current_qual |> qualname_to_package_classe + +(** translate an ostatic_exp into an jexp *) +let rec static_exp param_env se = match se.Types.se_desc with + | Types.Svar c -> + (match c.qual with + | LocalModule -> + let n = NamesEnv.find (shortname c) param_env in + Svar (n |> Idents.name |> local_qn) + | _ -> Svar (translate_const_name c)) + | Types.Sint i -> Sint i + | Types.Sfloat f -> Sfloat f + | Types.Sbool b -> Sbool b + | Types.Sconstructor c -> let c = translate_constructor_name c in Sconstructor c + | Types.Sfield f -> eprintf "ojSfield @."; assert false; + | Types.Stuple se_l -> tuple param_env se_l + | Types.Sarray_power (see,pow) -> + 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) + in + let se_l = Misc.repeat_list (static_exp param_env see) pow in + Enew_array (ty param_env se.Types.se_ty, se_l) + | Types.Sarray se_l -> Enew_array (ty param_env se.Types.se_ty, List.map (static_exp param_env) se_l) + | Types.Srecord _ -> eprintf "ojSrecord@."; assert false; (* TODO java *) + | Types.Sop (f, se_l) -> Efun (qualname_to_class_name f, List.map (static_exp param_env) se_l) + +and boxed_ty param_env t = match t with + | Types.Tprod ty_l -> tuple_ty param_env ty_l + | Types.Tid t when t = Initial.pbool -> Tclass (Names.local_qn "Boolean") + | Types.Tid t when t = Initial.pint -> Tclass (Names.local_qn "Integer") + | 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 (boxed_ty param_env t, static_exp param_env size) + | Types.Tmutable t -> Tref (boxed_ty param_env t) + | Types.Tunit -> Tunit + +and tuple_ty param_env ty_l = + let ln = ty_l |> List.length |> Pervasives.string_of_int in + Tclass (java_pervasive_class ("Tuple"^ln)) + +and ty param_env t :Java.ty = match t with + | Types.Tprod ty_l -> tuple_ty param_env ty_l + | Types.Tid t when t = Initial.pbool -> Tbool + | Types.Tid t when t = Initial.pint -> Tint + | 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.Tmutable t -> Tref (ty param_env t) + | Types.Tunit -> Tunit + +and var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident } + +and var_dec_list param_env vd_l = List.map (var_dec param_env) vd_l + +and exp param_env e = match e.e_desc with + | Obc.Epattern p -> Eval (pattern param_env p) + | Obc.Econst se -> static_exp param_env se + | Obc.Eop (op,e_l) -> Efun (op, exp_list param_env e_l) + | Obc.Estruct _ -> eprintf "ojEstruct@."; assert false (* TODO java *) + | Obc.Earray e_l -> Enew_array (ty param_env e.e_ty, exp_list param_env e_l) + +and exp_list param_env e_l = List.map (exp param_env) e_l + +and tuple param_env se_l = + let t = tuple_ty param_env (List.map (fun e -> e.Types.se_ty) se_l) in + Enew (t, List.map (static_exp param_env) se_l) + + +and pattern param_env p = match p.pat_desc with + | Obc.Lvar v -> Pvar v + | Obc.Lmem v -> Pthis v + | Obc.Lfield (p,f) -> Pfield (pattern param_env p, translate_field_name f) + | Obc.Larray (p,e) -> Parray_elem (pattern param_env p, exp param_env e) + +let obj_ref param_env o = match o with + | Oobj id -> Eval (Pvar id) + | Oarray (id,p) -> Eval (Parray_elem (Pvar id, Eval (pattern param_env p))) + +let rec act_list param_env act_l acts = + let _act act acts = match act with + | Obc.Aassgn (p,e) -> (Aassgn (pattern param_env p, exp param_env e))::acts + | Obc.Acall ([], obj, Mstep, e_l) -> + let acall = Amethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in + acall::acts + | Obc.Acall ([p], obj, Mstep, e_l) -> + let ecall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in + let assgn = Aassgn (pattern param_env p, ecall) in + assgn::acts + | Obc.Acall (p_l, obj, Mstep, e_l) -> + let return_ty = p_l |> pattern_list_to_type |> (ty param_env) in + let return_id = Idents.gen_var "obc2java" "out" in + let return_vd = { vd_type = return_ty; vd_ident = return_id } in + let ecall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in + let assgn = Anewvar (return_vd, ecall) in + let copy_return_to_var i p = + let t = ty param_env p.pat_ty in + let cast t e = match t with + | Tbool -> Ecast(Tbool, Ecast(boxed_ty param_env p.pat_ty, e)) + | Tint -> Ecast(Tint, Ecast(boxed_ty param_env p.pat_ty, e)) + | Tfloat -> Ecast(Tfloat, Ecast(boxed_ty param_env p.pat_ty, e)) + | _ -> Ecast(t, e) + in + let p = pattern param_env p in + Aassgn (p, cast t (Eval (Pfield (Pvar return_id, "c"^(string_of_int i))))) + in + let copies = Misc.mapi copy_return_to_var p_l in + assgn::(copies@acts) + | Obc.Acall (_, obj, Mreset, _) -> + let acall = Amethod_call (obj_ref param_env obj, "reset", []) in + acall::acts + | Obc.Acase (e, c_b_l) when e.e_ty = Types.Tid Initial.pbool -> + (match c_b_l with + | [] -> acts + | [(c,b)] when c = Initial.ptrue -> + (Aif (exp param_env e, block param_env b)):: acts + | [(c,b)] when c = Initial.pfalse -> + (Aifelse (exp param_env e, {b_locals = []; b_body = []}, block param_env b)) :: acts + | _ -> + let _, _then = List.find (fun (c,_) -> c = Initial.ptrue) c_b_l in + let _, _else = List.find (fun (c,_) -> c = Initial.pfalse) c_b_l in + (Aifelse (exp param_env e, block param_env _then, block param_env _else)) :: acts) + | Obc.Acase (e, c_b_l) -> + let _c_b (c,b) = translate_constructor_name c, block param_env b in + let acase = Aswitch (exp param_env e, List.map _c_b c_b_l) in + acase::acts + | Obc.Afor (v, se, se', b) -> + let afor = Afor (var_dec param_env v, static_exp param_env se, static_exp param_env se', block param_env b) in + afor::acts + | Obc.Ablock b -> + let ablock = Ablock (block param_env b) in + ablock::acts + in + List.fold_right _act act_l acts + +and block param_env ?(locals=[]) ?(end_acts=[]) ob = + let blocals = var_dec_list param_env ob.Obc.b_locals in + let locals = locals @ blocals in + let acts = act_list param_env ob.Obc.b_body end_acts in + { b_locals = locals; b_body = acts } + + + + + +(** Create the [param_env] and translate [Signature.param]s to [var_dec]s + @return [vds, param_env] *) +let sig_params_to_vds p_l = + let param_to_arg param_env p = + let p_ident = Idents.gen_var "obc2java" (String.uppercase p.Signature.p_name) in + let p_vd = { vd_ident = p_ident; vd_type = ty param_env p.Signature.p_type } in + let param_env = NamesEnv.add p.Signature.p_name p_ident param_env in + p_vd, param_env + in Misc.mapfold param_to_arg NamesEnv.empty p_l + +(** Translate [Signature.arg]s to [var_dec]s *) +let sig_args_to_vds param_env a_l = + let arg_to_vd { a_name = n; a_type = t } = + let n = match n with None -> "v" | Some s -> s in + let id = Idents.gen_var "obc2java" n in + mk_var_dec id (ty param_env t) + in List.map arg_to_vd a_l + +(** [copy_to_this vd_l] creates [this.x = x] for all [x] in [vd_l] *) +let copy_to_this vd_l = + let _vd vd = Aassgn (Pthis vd.vd_ident, Eval (Pvar vd.vd_ident)) in + List.map _vd vd_l + + +let class_def_list classes cd_l = + let class_def classes cd = + Idents.enter_node cd.cd_name; + let class_name = qualname_to_package_classe cd.cd_name in + (* [param_env] is an env mapping local param name to ident *) + (* [params] : fields to stock the static parameters, arguments of the constructors *) + let fields_params, vds_params, exps_params, param_env = + let v, env = sig_params_to_vds cd.cd_params in + let f = vds_to_fields ~protection:Pprotected v in + let e = vds_to_exps v in + f, v, e, env + in + (* [reset] is the reset method of the class, + [reset_mems] is the block to reset the members of the class + without call to the reset method of inner instances, it retains [this.x = 0] but not [this.I.reset()] *) + let reset, reset_mems = + try (* When there exist a reset method *) + let oreset = find_reset_method cd in + let body = block param_env oreset.Obc.m_body in + let reset_mems = block param_env (remove_resets oreset.Obc.m_body) in + mk_methode body "reset", reset_mems + with Not_found -> (* stub reset method *) + mk_methode (mk_block []) "reset", mk_block [] + in + (* [obj_env] gives the type of an [obj_ident], needed in async because we change the classe for async obj *) + let constructeur, obj_env = + let obj_env = (* Mapping between Obc class and Java class, useful at least with asyncs *) + let aux obj_env od = + let t = Tclass (qualname_to_class_name od.o_class) + in Idents.Env.add od.o_ident t obj_env + in List.fold_left aux Idents.Env.empty cd.cd_objs + in + let body = + (* Function to initialize the objects *) + let obj_init_act acts od = + let params = List.map (static_exp param_env) od.o_params in + match od.o_size with + | None -> + let t = Idents.Env.find od.o_ident obj_env in + (Aassgn (Pthis od.o_ident, Enew (t, params)))::acts + | Some size -> + let size = static_exp param_env size in + let t = Idents.Env.find od.o_ident obj_env in + let assgn_elem i = [ Aassgn (Parray_elem (Pthis od.o_ident, mk_var i), Enew (t, params)) ] in + (Aassgn (Pthis od.o_ident, Enew_array (Tarray (t,size), []))) + :: (fresh_for size assgn_elem) + :: acts + in + (* function to allocate the arrays *) + let allocate acts vd = match vd.v_type with + | Types.Tarray (t, size) -> + let t = ty param_env vd.v_type in + ( Aassgn (Pthis vd.v_ident, Enew_array (t,[])) ):: acts + | _ -> acts + in + (* init actions [acts] in reverse order : *) + (* init member variables *) + let acts = [Ablock reset_mems] in + (* init member objects *) + let acts = List.fold_left obj_init_act acts cd.cd_objs in + (* allocate member arrays *) + let acts = List.fold_left allocate acts cd.cd_mems in + (* init static params *) + let acts = (copy_to_this vds_params)@acts in + { b_locals = []; b_body = List.rev acts } + in mk_methode ~args:vds_params body (shortname class_name), obj_env + in + let fields = + let mem_to_field fields vd = (mk_field ~protection:Pprotected (ty param_env vd.v_type) vd.v_ident) :: fields in + let obj_to_field fields od = + let jty = match od.o_size with + | None -> Idents.Env.find od.o_ident obj_env + | Some size -> Tarray (Idents.Env.find od.o_ident obj_env, static_exp param_env size) + in + (mk_field ~protection:Pprotected jty od.o_ident) :: fields + in + let fields = fields_params in + let fields = List.fold_left mem_to_field fields cd.cd_mems in + List.fold_left obj_to_field fields cd.cd_objs + in + let step = + let ostep = find_step_method cd in + let vd_output = var_dec_list param_env ostep.m_outputs in + let return_ty = ostep.m_outputs |> vd_list_to_type |> (ty param_env) in + let return_act = Areturn (match vd_output with + | [] -> Evoid + | [vd] -> Eval (Pvar vd.vd_ident) + | vd_l -> Enew (return_ty, List.map (fun vd -> Eval (Pvar vd.vd_ident)) vd_l)) + in + let body = block param_env ~locals:vd_output ~end_acts:[return_act] ostep.Obc.m_body in + mk_methode ~args:(var_dec_list param_env ostep.Obc.m_inputs) ~returns:return_ty body "step" + in + let classe = mk_classe ~fields:fields + ~constrs:[constructeur] ~methodes:[step;reset] class_name in + classe::classes + in + List.fold_left class_def classes cd_l + + +let type_dec_list classes td_l = + let param_env = NamesEnv.empty in + let _td classes td = + 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_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 + | Type_struct f_l -> + let mk_field_jfield { Signature.f_name = oname; Signature.f_type = oty } = + let jty = ty param_env oty in + let field = Idents.ident_of_name (translate_field_name oname) in + (* [translate_field_name] will give the right result anywhere it is used, + since the [ident_of_name] will keep it as it is unique in the class, see [Idents.enter_node classe_name] *) + mk_field jty field + in + (mk_classe ~fields:(List.map mk_field_jfield f_l) classe_name) :: classes + in + List.fold_left _td classes td_l + + +let const_dec_list cd_l = match cd_l with + | [] -> [] + | _ -> + let classe_name = "CONSTANTES" |> name_to_classe_name in + Idents.enter_node classe_name; + let param_env = NamesEnv.empty in + let mk_const_field { Obc.c_name = oname ; Obc.c_value = ovalue; Obc.c_type = otype } = + let name = oname |> translate_const_name |> shortname |> Idents.ident_of_name in + (* name should always keep the shortname unchanged since we enter a special node free of existing variables *) + (* thus [translate_const_name] will gives the right result anywhere it is used. *) + let value = Some (static_exp param_env ovalue) in + let t = ty param_env otype in + mk_field ~static: true ~final: true ~value: value t name + in + let fields = List.map mk_const_field cd_l in + [mk_classe ~fields: fields classe_name] + + + +let program p = + let classes = const_dec_list p.p_consts in + let classes = type_dec_list classes p.p_types in + let p = class_def_list classes p.p_classes in + get_classes()@p + + + diff --git a/compiler/obc/java/old_java.ml b/compiler/obc/java/old_java.ml new file mode 100644 index 0000000..d42022e --- /dev/null +++ b/compiler/obc/java/old_java.ml @@ -0,0 +1,543 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + + +open Signature +open Modules +open Format +open Obc +open Misc +open Types +open Names +open Idents +open Pp_tools + +let jname_of_name name = + let b = Buffer.create (String.length name) in + let rec convert c = + match c with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> + Buffer.add_char b c + | '\'' -> Buffer.add_string b "_prime" + | _ -> + Buffer.add_string b "lex"; + Buffer.add_string b (string_of_int (Char.code c)); + Buffer.add_string b "_" in + + String.iter convert name; + Buffer.contents b + +let print_name ff name = + fprintf ff "%s" (jname_of_name name) + +let print_shortname ff longname = + print_name ff (shortname longname) + +let rec java_type_default_value = function + | Tid id when id = Initial.pint -> "int", "0" + | Tid id when id = Initial.pfloat -> "float", "0.0" + | Tid id when id = Initial.pbool -> "boolean", "false" + | Tid t -> + (match find_type t with + | Tabstract -> assert false + | Talias t -> java_type_default_value t + | Tenum _ -> "int", "0" (* TODO java *) + | Tstruct _ -> shortname t, "null" ) + | Tarray _ -> assert false (* TODO array *) + | Tprod _ -> assert false (* TODO java *) + | Tunit -> "void", "null" + +let print_type ff ty = + let jty,_ = java_type_default_value ty in + print_name ff jty + +let print_field ff (name,ty) = + fprintf ff "%a %a;" + print_type ty + print_name name + +let print_const_field ff (name,ty) = + fprintf ff "%a@ %a" + print_type ty + print_name name + +let print_assgt_field ff (name,_) = + fprintf ff "this.%a = %a;" + print_name name + print_name name + +(* assumes tn is already translated with jname_of_name *) +let print_struct_type ff tn fields = + fprintf ff "@[@[public class %s {@ " tn; + (* fields *) + print_list print_field "" "" "" ff fields; + (* constructor *) + let sorted_fields = + List.sort + (fun (n1,_) (n2,_) -> String.compare n1 n2) + fields in + fprintf ff "@ @[public %s(@[" tn; + print_list print_const_field "" "," "" ff sorted_fields; + fprintf ff "@]) {@ "; + (* constructor assignments *) + print_list print_assgt_field "" "" "" ff fields; + (* constructor end *) + fprintf ff "@]@ }"; + (* class end *) + fprintf ff "@]@ }@]" + + +let rec print_tags ff n = function + | [] -> () + | tg :: tgs' -> + fprintf ff "@ public static final int %a = %d;" + print_name ( shortname tg ) (* TODO java deal with modules *) + n; + print_tags ff (n+1) tgs' + +(* assumes tn is already translated with jname_of_name *) +let print_enum_type ff tn tgs = + fprintf ff "@[@[public class %s {" tn; + print_tags ff 1 tgs; + fprintf ff "@]@ }@]" + +let rec print_type_to_file java_dir headers { t_name = tn; t_desc = td} = + let tn = jname_of_name (shortname tn) in (* TODO java deal with modules *) + match td with + | Type_abs -> () + | Type_enum tgs -> + let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in + let ff = formatter_of_out_channel out_ch in + (*Misc.print_header_info ff "/*" "*/"; *) + List.iter (fprintf ff "%s") headers; + (* fprintf ff "@[package %s;@\n@\n" headers; *) (* TODO java deal with modules *) + print_enum_type ff tn tgs; + fprintf ff "@."; + close_out out_ch + | Type_struct fields -> + let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in + let ff = formatter_of_out_channel out_ch in + (* Misc.print_header_info ff "/*" "*/"; *)(* TODO java deal with modules *) + List.iter (fprintf ff "%s") headers; + (* fprintf ff "@[package %s;@\n@\n" headers; *) + print_struct_type ff tn + (List.map (fun {f_name = n;f_type = t} -> (shortname n,t)) fields); (* TODO java deal with modules *) + fprintf ff "@."; + close_out out_ch + | Type_alias t -> assert false (* TODO java *) + +let print_types java_dir headers tps = + List.iter (print_type_to_file java_dir headers) tps + +(******************************) + +type answer = + | Sing of var_ident + | Mult of var_ident list + +let print_const ff c ts = + match c.se_desc with + | Sint i -> fprintf ff "%d" i + | Sfloat f -> fprintf ff "%f" f + | Sbool true -> fprintf ff "true" + | Sbool false -> fprintf ff "false" + | Sconstructor c -> + let tg = shortname c in (* TODO java gérer les modules *) + let s = (fst (List.find (fun (tn, tgs) -> List.exists (fun tg' -> tg = tg') tgs) ts)) + ^ "." ^ (jname_of_name tg) in + fprintf ff "%s" s + | _ -> assert false (* TODO java *) + +let position a xs = + let rec walk i = function + | [] -> None + | x :: xs' -> if x = a then Some i else walk (i + 1) xs' + in walk 1 xs + +let print_ident ff id = + print_name ff (name id) + +let print_var ff x avs single = + match (position x avs) with + | None -> print_ident ff x + | Some n -> + if single then print_ident ff (List.hd avs) + else fprintf ff "step_ans.c_%d" n + +let javaop_of_op = function + | "=" -> "==" + | "<>" -> "!=" + | "or" -> "||" + | "&" -> "&&" + | "*." -> "*" + | "/." -> "/" + | "+." -> "+" + | "-." -> "-" + | op -> op + +let priority = function + | "*" | "/" | "*." | "/." -> 5 + | "+" | "-" | "+." | "-." -> 4 + | "=" | "<>" | "<=" | "=>" -> 3 + | "&" -> 2 + | "|" -> 1 + | _ -> 0 + +let rec print_lhs ff e avs single = + match e.pat_desc with + | Lvar x -> + print_var ff x avs single + | Lmem x -> print_ident ff x + | Lfield(e, field) -> + print_lhs ff e avs single; + fprintf ff ".%s" (jname_of_name (shortname field)) + | Larray _ -> assert false (* TODO java array *) + +let rec print_exp ff e p avs ts single = + match e.e_desc with + | Epattern l -> print_lhs ff l avs single + | Econst c -> print_const ff c ts + | Eop (op, es) -> print_op ff op es p avs ts single + | Estruct (type_name,fields) -> + let fields = + List.sort + (fun (ln1,_) (ln2,_) -> + String.compare (shortname ln1) (shortname ln2)) + fields in + let exps = List.map (fun (_,e) -> e) fields in + fprintf ff "new %a(@[" + print_shortname type_name; + print_exps ff exps 0 avs ts single; + fprintf ff "@])" + | Earray _ -> assert false (* TODO array *) + +and print_exps ff es p avs ts single = + match es with + | [] -> () + | [e] -> print_exp ff e p avs ts single + | e :: es' -> + print_exp ff e p avs ts single; + fprintf ff ",@ "; + print_exps ff es' p avs ts single + +and print_op ff op es p avs ts single = + match (shortname op), es with + | (("+" | "-" | "*" | "/" + |"+." | "-." | "*." | "/." + | "=" | "<>" | "<" | "<=" + | ">" | ">=" | "&" | "or") as op_name, [e1;e2]) -> + let p' = priority op_name in + if p' < p then fprintf ff "(" else (); + print_exp ff e1 p' avs ts single; + fprintf ff " %s " (javaop_of_op op_name); + print_exp ff e2 p' avs ts single; + if p' < p then fprintf ff ")" else () + | "not", [e] -> + fprintf ff "!"; + print_exp ff e 6 avs ts single; + | "~-", [e] -> + fprintf ff "-"; + print_exp ff e 6 avs ts single; + | _ ->(* + begin + begin + match op with + | Name(op_name) -> + print_name ff op_name; + | Modname({ qual = mod_name; id = op_name }) -> + fprintf ff "%a.%a" + print_name (String.uncapitalize mod_name) + print_name op_name + end; + fprintf ff "@[("; + print_exps ff es 0 avs ts single; + fprintf ff ")@]" + end *) + assert false (* TODO java *) + +let rec print_proj ff xs ao avs single = + let rec walk ind = function + | [] -> () + | x :: xs' -> + print_lhs ff x avs single; + fprintf ff " = %s.c_%d;@ " ao ind; + walk (ind + 1) xs' + in walk 1 xs + + +let bool_case = function + | [] -> assert false + | ("true", _) :: _ + | ("false", _) :: _ -> true + | _ -> false + +let obj_ref_to_string = function + | Oobj o -> o + | Oarray (o,p) -> o (* TODO java array *) + +let rec print_act ff a objs avs ts single = + match a with + | Aassgn (x, e) -> + fprintf ff "@["; + print_asgn ff x e avs ts single; + fprintf ff ";@]" + | Acall (xs,oref,Mstep,es) -> + let o = obj_ref_to_string oref in + (match xs with + | [x] -> + print_lhs ff x avs single; + fprintf ff " = %s.step(" o; + fprintf ff "@["; + print_exps ff es 0 avs ts single; + fprintf ff "@]"; + fprintf ff ");@ " + | xs -> + let cn = (List.find (fun od -> od.o_name = o) objs).o_class in + let at = (jname_of_name (shortname cn)) ^ "Answer" in + let ao = o ^ "_ans" in + fprintf ff "%s %s = new %s();@ " at ao at; + fprintf ff "%s = %s.step(" ao o; + fprintf ff "@["; + print_exps ff es 0 avs ts single; + fprintf ff "@]"; + fprintf ff ");@ "; + print_proj ff xs ao avs single) + | Acase (e, grds) -> + let grds = + List.map + (fun (ln,act) -> (shortname ln),act) grds in + if bool_case grds + then print_if ff e grds objs avs ts single + else (fprintf ff "@[@[switch (%a) {@ " + (fun ff e -> print_exp ff e 0 avs ts single) e; + print_grds ff grds objs avs ts single; + fprintf ff "@]@ }@]"); + | Acall (_,oref,Mreset,_) -> + let o = obj_ref_to_string oref in + fprintf ff "%s.reset();" o + | Afor _ -> assert false (* TODO java array *) + + +and print_grds ff grds objs avs ts single = + match grds with + | [] -> () + | (tg, b) :: grds' -> + (* retrieve class name *) + let cn = (fst + (List.find + (fun (tn, tgs) -> + List.exists (fun tg' -> tg = tg') tgs) + ts)) in + fprintf ff "@[case %a.%a:@ " + print_name cn + print_name tg; + print_block ff b objs avs ts single; + fprintf ff "@ break;@ @]@ "; + print_grds ff grds' objs avs ts single + +and print_if ff e grds objs avs ts single = + match grds with + | [("true", a)] -> + fprintf ff "@[@[if (%a) {@ " + (fun ff e -> print_exp ff e 0 avs ts single) e; + print_block ff a objs avs ts single; + fprintf ff "@]@ }@]" + | [("false", a)] -> + fprintf ff "@[@[if (!%a) {@ " + (fun ff e -> print_exp ff e 6 avs ts single) e; + print_block ff a objs avs ts single; + fprintf ff "@]@ }@]" + | [("true", a1); ("false", a2)] -> + fprintf ff "@[@[if (%a) {@ " + (fun ff e -> print_exp ff e 0 avs ts single) e; + print_block ff a1 objs avs ts single; + fprintf ff "@]@ @[} else {@ "; + print_block ff a2 objs avs ts single; + fprintf ff "@]@ }@]" + | [("false", a2); ("true", a1)] -> + fprintf ff "@[@[if (%a) {@ " + (fun ff e -> print_exp ff e 0 avs ts single) e; + print_block ff a1 objs avs ts single; + fprintf ff "@]@ @[} else {@ "; + print_block ff a2 objs avs ts single; + fprintf ff "@]@ }@]" + | _ -> assert false + +and print_asgn ff x e avs ts single = + fprintf ff "@["; + print_lhs ff x avs single; + fprintf ff " = "; + print_exp ff e 0 avs ts single; + fprintf ff "@]" + +and print_block ff b objs avs ts single = () (* TODO urgent java *) + +let print_vd ff vd = + let jty,jdv = java_type_default_value vd.v_type in + fprintf ff "@["; + print_name ff jty; + fprintf ff " %s = %s;" + (jname_of_name (name vd.v_ident)) + jdv; + fprintf ff "@]" + +let print_obj ff od = + fprintf ff "@["; + fprintf ff "%a %a = new %a();" + print_shortname od.o_class + print_name od.o_name + print_shortname od.o_class; + fprintf ff "@]" + +let rec print_objs ff ods = + match ods with + | [] -> () + | od :: ods' -> + print_obj ff od; + fprintf ff "@ "; + print_objs ff ods' + +let print_comps ff fds= + let rec walk n = function + | [] -> () + | fd :: fds' -> + fprintf ff "@ "; + fprintf ff "public "; + print_type ff fd.v_type; + fprintf ff " c_%s;" (string_of_int n); + walk (n + 1) fds' + in walk 1 fds + +let print_ans_struct ff name fields = + fprintf ff "@[@[public class %s {" name; + print_comps ff fields; + fprintf ff "@]@ }@]@ " + +let print_vd' ff vd = + fprintf ff "@["; + print_type ff vd.v_type; + fprintf ff "@ %s" (jname_of_name (name vd.v_ident)); + fprintf ff "@]" + +let rec print_in ff = function + | [] -> () + | [vd] -> print_vd' ff vd + | vd :: vds' -> + print_vd' ff vd; + fprintf ff ",@ "; + print_in ff vds' + +let rec print_mem ff = function + | [] -> () + | vd :: m' -> + print_vd ff vd; + fprintf ff "@ "; + print_mem ff m' + +let print_loc ff vds = print_mem ff vds + +let print_step ff n s objs ts single = + let n = jname_of_name n in + fprintf ff "@[@ @[public "; + if single then print_type ff (List.hd s.m_outputs).v_type + else fprintf ff "%s" (n ^ "Answer"); + fprintf ff " step(@["; + print_in ff s.m_inputs; + fprintf ff "@]) {@ "; + let loc = if single then (List.hd s.m_outputs) :: s.m_body.b_locals else s.m_body.b_locals in + if loc = [] then () else (print_loc ff loc; fprintf ff "@ "); + if single then fprintf ff "@ " + else fprintf ff "%sAnswer step_ans = new %sAnswer();@ @ " n n; + print_act ff s.bd objs + (List.map (fun vd -> vd.v_ident) s.out) ts single; + fprintf ff "@ @ return "; + if single + then fprintf ff "%s" (jname_of_name (Idents.name (List.hd s.out).v_ident)) + else fprintf ff "step_ans"; + fprintf ff ";@]@ }@ @]" + +let print_reset ff r ts = + fprintf ff "@[@ @[public void reset() {@ "; + print_act ff r [] [] ts false; + fprintf ff "@]@ }@ @]" + +let print_class ff headers ts single opened_mod cl = + let clid = jname_of_name cl.cl_id in + List.iter (fprintf ff "%s") headers; + (* fprintf ff "@[package %s;@\n@\n" headers; *) + (* import opened modules *) + List.iter + (fun m -> + fprintf ff "import %s.*;@\n" (String.uncapitalize m)) + opened_mod; + + fprintf ff "@\n@[public class %s {@ " clid; + if cl.mem = [] then () + else fprintf ff "@[@ "; print_mem ff cl.mem; fprintf ff "@]"; + if cl.objs = [] then () + else fprintf ff "@[@ "; print_objs ff cl.objs; fprintf ff "@]"; + print_reset ff cl.reset ts; + print_step ff clid cl.step cl.objs ts single; + fprintf ff "@]@ }@]" + +let print_class_and_answer_to_file java_dir headers ts opened_mod cl = + let clid = jname_of_name cl.cl_id in + let print_class_to_file single = + let out_ch = open_out (java_dir ^ "/" ^ clid ^ ".java") in + let ff = formatter_of_out_channel out_ch in + Misc.print_header_info ff "/*" "*/"; + print_class ff headers ts single opened_mod cl; + fprintf ff "@."; + close_out out_ch + in + match cl.step.out with + | [_] -> print_class_to_file true + | _ -> + let out_ch = open_out (java_dir ^ "/" ^ clid ^ "Answer.java") in + let ff = formatter_of_out_channel out_ch in + Misc.print_header_info ff "/*" "*/"; + List.iter (fprintf ff "%s") headers; + (* fprintf ff "@[package %s;@\n@\n" headers; *) + List.iter + (fun m -> + fprintf ff "import %s.*;@\n" (String.uncapitalize m)) + opened_mod; + print_ans_struct ff (clid ^ "Answer") cl.step.out; + fprintf ff "@."; + close_out out_ch; + print_class_to_file false + +let print_classes java_dir headers ts opened_mod cls = + List.iter + (print_class_and_answer_to_file java_dir headers ts opened_mod) + cls + +(******************************) +let print java_dir p = + let headers = + List.map snd + (List.filter + (fun (tag,_) -> tag = "java") + p.o_pragmas) in + print_types java_dir headers p.o_types; + o_types := p.o_types; + print_classes + java_dir headers + (List.flatten + (List.map + (function + | { t_desc = Type_abs } -> [] + | { t_name = tn; t_desc = Type_enum tgs } -> [tn, tgs] + | { t_name = tn; t_desc = Type_struct fields } -> + [tn, (List.map fst fields)]) + p.o_types)) + p.o_opened + p.o_defs + +(******************************) diff --git a/compiler/obc/ml/caml.ml b/compiler/obc/ml/caml.ml new file mode 100644 index 0000000..99b7420 --- /dev/null +++ b/compiler/obc/ml/caml.ml @@ -0,0 +1,98 @@ +(**************************************************************************) +(* *) +(* 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 new file mode 100644 index 0000000..48da556 --- /dev/null +++ b/compiler/obc/ml/caml_aux.ml @@ -0,0 +1,131 @@ +(**************************************************************************) +(* *) +(* 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 new file mode 100644 index 0000000..536a407 --- /dev/null +++ b/compiler/obc/ml/caml_printer.ml @@ -0,0 +1,404 @@ +(**************************************************************************) +(* *) +(* 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 new file mode 100644 index 0000000..d410adb --- /dev/null +++ b/compiler/obc/ml/cenvironment.ml @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* 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 new file mode 100644 index 0000000..712d1cb --- /dev/null +++ b/compiler/obc/ml/coiteration.ml @@ -0,0 +1,848 @@ +(**************************************************************************) +(* *) +(* 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 new file mode 100644 index 0000000..ae6db9e --- /dev/null +++ b/compiler/obc/ml/declarative.ml @@ -0,0 +1,295 @@ +(**************************************************************************) +(* *) +(* 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 new file mode 100644 index 0000000..6c93d2c --- /dev/null +++ b/compiler/obc/ml/declarative_printer.ml @@ -0,0 +1,699 @@ +(**************************************************************************) +(* *) +(* 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 new file mode 100644 index 0000000..ff2800a --- /dev/null +++ b/compiler/obc/ml/default_value.ml @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* 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 new file mode 100644 index 0000000..3b0b07d --- /dev/null +++ b/compiler/obc/ml/misc.ml @@ -0,0 +1,295 @@ +(**************************************************************************) +(* *) +(* 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 new file mode 100644 index 0000000..139597f --- /dev/null +++ b/compiler/obc/ml/ml.ml @@ -0,0 +1,2 @@ + + diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index 9dd83de..ea9adca 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -8,6 +8,21 @@ (**************************************************************************) (* Object code internal representation *) +(** { 3 Semantics } + Any variable is a reference to a constant memory. + Thus [p = e] is not the change of the reference, + but a recursive copy of what is referenced (deep copy). + As an example, [x = 3] but also [x = \[3; 4; 5\]] + and [t1 = t2] with the content of the array [t2] copied into the array [t1]. + Obc is also "SSA" in the sens that a variable is assigned a value only once per call of [step] etc. + Thus arguments are passed as constant references to a constant memory. + + One exception to the SSA rule is through the [mutable] variables. + Theses variables can be assigned multiple times. + Thus a [mutable] argument is passed as a reference to a constant memory. +*) + + open Misc open Names open Idents @@ -16,12 +31,12 @@ open Signature open Location type class_name = qualname -type instance_name = qualname -type obj_name = name type op_name = qualname +type obj_ident = var_ident + type type_dec = - { t_name : qualname; + { t_name : type_name; t_desc : tdesc; t_loc : location } @@ -48,15 +63,15 @@ and pat_desc = and exp = { e_desc : exp_desc; e_ty : ty; e_loc : location } and exp_desc = - | Elhs of pattern + | Epattern of pattern | Econst of static_exp | Eop of op_name * exp list | Estruct of type_name * (field_name * exp) list | Earray of exp list type obj_ref = - | Oobj of obj_name - | Oarray of obj_name * pattern + | Oobj of obj_ident + | Oarray of obj_ident * pattern type method_name = | Mreset @@ -66,7 +81,8 @@ type act = | Aassgn of pattern * exp | Acall of pattern list * obj_ref * method_name * exp list | Acase of exp * (constructor_name * block) list - | Afor of var_ident * static_exp * static_exp * block + | Afor of var_dec * static_exp * static_exp * block + | Ablock of block and block = { b_locals : var_dec list; @@ -74,14 +90,14 @@ and block = and var_dec = { v_ident : var_ident; - v_type : ty; (* TODO GD should be here, v_controllable : bool *) + v_type : ty; v_loc : location } type obj_dec = - { o_name : obj_name; - o_class : instance_name; + { o_ident : obj_ident; + o_class : class_name; o_params : static_exp list; - o_size : static_exp option; + o_size : static_exp option; (** size of the array if the declaration is an array of obj *) o_loc : location } type method_def = @@ -92,70 +108,19 @@ type method_def = type class_def = { cd_name : class_name; + cd_stateful : bool; (** when false, the class is a function with static parameters + calling other functions with parameters *) cd_mems : var_dec list; cd_objs : obj_dec list; cd_params : param list; cd_methods: method_def list; cd_loc : location } + type program = - { p_modname : name; - p_opened : name list; + { p_modname : modul; + p_opened : modul list; p_types : type_dec list; p_consts : const_dec list; - p_defs : class_def list } - -let mk_var_dec ?(loc=no_location) name ty = - { v_ident = name; v_type = ty; v_loc = loc } - -let mk_exp ?(ty=invalid_type) ?(loc=no_location) desc = (* TODO master : remove the invalid_type *) - { e_desc = desc; e_ty = ty; e_loc = loc } - -let mk_lhs ?(ty=invalid_type) ?(loc=no_location) desc = (* TODO master : remove the invalid_type *) - { pat_desc = desc; pat_ty = ty; pat_loc = loc } - -let mk_lhs_exp ?(ty=invalid_type) desc = (* TODO master : remove the invalid_type *) - let lhs = mk_lhs ~ty:ty desc in - mk_exp ~ty:ty (Elhs lhs) - -let mk_evar id = - mk_exp (Elhs (mk_lhs (Lvar id))) - -let mk_block ?(locals=[]) eq_list = - { b_locals = locals; - b_body = eq_list } - -let rec var_name x = - match x.pat_desc with - | Lvar x -> x - | Lmem x -> x - | Lfield(x,_) -> var_name x - | Larray(l, _) -> var_name l - -(** Returns whether an object of name n belongs to - a list of var_dec. *) -let rec vd_mem n = function - | [] -> false - | vd::l -> vd.v_ident = n or (vd_mem n l) - -(** Returns the var_dec object corresponding to the name n - in a list of var_dec. *) -let rec vd_find n = function - | [] -> Format.eprintf "Not found var %s@." (name n); raise Not_found - | vd::l -> - if vd.v_ident = n then vd else vd_find n l - -let lhs_of_exp e = match e.e_desc with - | Elhs l -> l - | _ -> assert false - -let find_step_method cd = - List.find (fun m -> m.m_name = Mstep) cd.cd_methods -let find_reset_method cd = - List.find (fun m -> m.m_name = Mreset) cd.cd_methods - -let obj_ref_name o = - match o with - | Oobj obj - | Oarray (obj, _) -> obj + p_classes : class_def list; } diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml index 32cdde3..462712f 100644 --- a/compiler/obc/obc_mapfold.ml +++ b/compiler/obc/obc_mapfold.ml @@ -44,9 +44,9 @@ and edesc_it funs acc ed = try funs.edesc funs acc ed with Fallback -> edesc funs acc ed and edesc funs acc ed = match ed with - | Elhs l -> + | Epattern l -> let l, acc = lhs_it funs acc l in - Elhs l, acc + Epattern l, acc | Econst se -> let se, acc = static_exp_it funs.global_funs acc se in Econst se, acc @@ -108,6 +108,9 @@ and act funs acc a = match a with let idx2, acc = static_exp_it funs.global_funs acc idx2 in let b, acc = block_it funs acc b in Afor(x, idx1, idx2, b), acc + | Ablock b -> + let b, acc = block_it funs acc b in + Ablock b, acc and block_it funs acc b = funs.block funs acc b and block funs acc b = @@ -144,7 +147,9 @@ and method_def funs acc md = , acc -and class_def_it funs acc cd = funs.class_def funs acc cd +and class_def_it funs acc cd = + Idents.enter_node cd.cd_name; + funs.class_def funs acc cd and class_def funs acc cd = let cd_mems, acc = var_decs_it funs acc cd.cd_mems in let cd_objs, acc = obj_decs_it funs acc cd.cd_objs in @@ -183,8 +188,8 @@ and program_it funs acc p = funs.program funs acc p and program funs acc p = let td_list, acc = mapfold (type_dec_it funs) acc p.p_types in let cd_list, acc = mapfold (const_dec_it funs) acc p.p_consts in - let nd_list, acc = mapfold (class_def_it funs) acc p.p_defs in - { p with p_types = td_list; p_consts = cd_list; p_defs = nd_list }, acc + let nd_list, acc = mapfold (class_def_it funs) acc p.p_classes in + { p with p_types = td_list; p_consts = cd_list; p_classes = nd_list }, acc let defaults = { diff --git a/compiler/obc/obc_printer.ml b/compiler/obc/obc_printer.ml index 8738572..7a17401 100644 --- a/compiler/obc/obc_printer.ml +++ b/compiler/obc/obc_printer.ml @@ -14,7 +14,7 @@ let print_vd ff vd = fprintf ff "@]" let print_obj ff o = - fprintf ff "@["; print_name ff o.o_name; + fprintf ff "@["; print_ident ff o.o_ident; fprintf ff " : "; print_qualname ff o.o_class; fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "<<"","">>") o.o_params; (match o.o_size with @@ -37,7 +37,7 @@ and print_exps ff e_list = print_list_r print_exp "" "," "" ff e_list and print_exp ff e = match e.e_desc with - | Elhs lhs -> print_lhs ff lhs + | Epattern lhs -> print_lhs ff lhs | Econst c -> print_static_exp ff c | Eop(op, e_list) -> print_op ff op e_list | Estruct(_,f_e_list) -> @@ -65,16 +65,17 @@ let print_asgn ff pref x e = fprintf ff "@]" let print_obj_call ff = function - | Oobj o -> print_name ff o + | Oobj o -> print_ident ff o | Oarray (o, i) -> fprintf ff "%a[%a]" - print_name o + print_ident o print_lhs i let print_method_name ff = function | Mstep -> fprintf ff "step" | Mreset -> fprintf ff "reset" + let rec print_act ff a = let print_lhs_tuple ff var_list = match var_list with | [] -> () @@ -87,8 +88,8 @@ let rec print_act ff a = print_tag_act_list ff tag_act_list; fprintf ff "@]@,}@]" | Afor(x, i1, i2, act_list) -> - fprintf ff "@[@[for %s = %a to %a {@, %a @]@,}@]" - (name x) + fprintf ff "@[@[for %a = %a to %a {@ %a @]@,}@]" + print_vd x print_static_exp i1 print_static_exp i2 print_block act_list @@ -98,6 +99,8 @@ let rec print_act ff a = print_obj_call o print_method_name meth print_exps es + | Ablock b -> + fprintf ff "do@\n %a@\ndone" print_block b and print_var_dec_list ff var_dec_list = match var_dec_list with | [] -> () @@ -149,6 +152,7 @@ let print_class_def ff print_list_r print_method "" "\n" "" ff m_list; fprintf ff "@]" + let print_type_def ff { t_name = name; t_desc = tdesc } = match tdesc with | Type_abs -> fprintf ff "@[type %a@\n@]" print_qualname name @@ -169,21 +173,19 @@ let print_type_def ff { t_name = name; t_desc = tdesc } = fprintf ff "@]@.@]" let print_open_module ff name = - fprintf ff "@[open "; - print_name ff name; - fprintf ff "@.@]" + fprintf ff "open %s@." (modul_to_string name) let print_const_dec ff c = fprintf ff "const %a = %a@." print_qualname c.c_name print_static_exp c.c_value let print_prog ff { p_opened = modules; p_types = types; - p_consts = consts; p_defs = defs } = + p_consts = consts; p_classes = classes; } = List.iter (print_open_module ff) modules; List.iter (print_type_def ff) types; List.iter (print_const_dec ff) consts; fprintf ff "@\n"; - List.iter (fun def -> (print_class_def ff def; fprintf ff "@\n@\n")) defs + List.iter (fun cdef -> (print_class_def ff cdef; fprintf ff "@\n@\n")) classes let print oc p = let ff = formatter_of_out_channel oc in diff --git a/compiler/obc/obc_utils.ml b/compiler/obc/obc_utils.ml index d9c767f..b701605 100644 --- a/compiler/obc/obc_utils.ml +++ b/compiler/obc/obc_utils.ml @@ -8,16 +8,113 @@ (**************************************************************************) open Names +open Idents +open Location open Misc open Types open Obc open Obc_mapfold open Global_mapfold +let mk_var_dec ?(loc=no_location) ident ty = + { v_ident = ident; v_type = ty; v_loc = loc } + +let mk_exp ?(loc=no_location) ty desc = + { e_desc = desc; e_ty = ty; e_loc = loc } + +let mk_exp_int ?(loc=no_location) desc = + { e_desc = desc; e_ty = Initial.tint; e_loc = loc } + +let mk_exp_bool ?(loc=no_location) desc = + { e_desc = desc; e_ty = Initial.tbool; e_loc = loc } + +let mk_pattern ?(loc=no_location) ty desc = + { pat_desc = desc; pat_ty = ty; pat_loc = loc } + +let mk_pattern_int ?(loc=no_location) desc = + { pat_desc = desc; pat_ty = Initial.tint; pat_loc = loc } + +let mk_pattern_exp ty desc = + let pat = mk_pattern ty desc in + mk_exp ty (Epattern pat) + +let mk_evar ty id = + mk_exp ty (Epattern (mk_pattern ty (Lvar id))) + +let mk_evar_int id = + mk_exp Initial.tint (Epattern (mk_pattern Initial.tint (Lvar id))) + +let mk_block ?(locals=[]) eq_list = + { b_locals = locals; + b_body = eq_list } + +let rec var_name x = + match x.pat_desc with + | Lvar x -> x + | Lmem x -> x + | Lfield(x,_) -> var_name x + | Larray(l, _) -> var_name l + +(** Returns whether an object of name n belongs to + a list of var_dec. *) +let rec vd_mem n = function + | [] -> false + | vd::l -> vd.v_ident = n or (vd_mem n l) + +(** Returns the var_dec object corresponding to the name n + in a list of var_dec. *) +let rec vd_find n = function + | [] -> Format.eprintf "Not found var %s@." (name n); raise Not_found + | vd::l -> + if vd.v_ident = n then vd else vd_find n l + +(** Returns the type of a [var_dec list] *) +let vd_list_to_type vd_l = match vd_l with + | [] -> Types.Tunit + | [vd] -> vd.v_type + | _ -> Tprod (List.map (fun vd -> vd.v_type) vd_l) + +let pattern_list_to_type p_l = match p_l with + | [] -> Types.Tunit + | [p] -> p.pat_ty + | _ -> Tprod (List.map (fun p -> p.pat_ty) p_l) + +let pattern_of_exp e = match e.e_desc with + | Epattern l -> l + | _ -> assert false + +let find_step_method cd = + List.find (fun m -> m.m_name = Mstep) cd.cd_methods +let find_reset_method cd = + List.find (fun m -> m.m_name = Mreset) cd.cd_methods + +let obj_ref_name o = + match o with + | Oobj obj + | Oarray (obj, _) -> obj + +(** Input a block [b] and remove all calls to [Reset] method from it *) +let remove_resets b = + let block funs _ b = + let b,_ = Obc_mapfold.block funs () b in + let is_not_reset a = match a with + | Acall( _,_,Mreset,_) -> false + | _ -> true + in + let b = { b with b_body = List.filter is_not_reset b.b_body } in + b, () + in + let funs = { Obc_mapfold.defaults with block = block } in + let b,_ = block_it funs () b in + b + + module Deps = struct - let deps_longname deps { qual = modn; } = S.add modn deps + let deps_longname deps qn = match qn.qual with + | Module _ | QualModule _ -> ModulSet.add qn.qual deps + | _ -> deps let deps_static_exp_desc funs deps sedesc = let (sedesc, deps) = Global_mapfold.static_exp_desc funs deps sedesc in @@ -66,6 +163,6 @@ struct act = deps_act; obj_dec = deps_obj_dec; } in - let (_, deps) = Obc_mapfold.program funs S.empty p in - S.remove p.p_modname (S.remove "Pervasives" deps) + let (_, deps) = Obc_mapfold.program funs ModulSet.empty p in + ModulSet.remove p.p_modname deps end diff --git a/compiler/obc/transformations/scalarize.ml b/compiler/obc/transformations/scalarize.ml new file mode 100644 index 0000000..38b1110 --- /dev/null +++ b/compiler/obc/transformations/scalarize.ml @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(** Remove implicit array's deep copy. If ever some p = e with p of type array still exist, + they are only used as reference to the array, no copy is implied : + array assignation after [scalarize] is pointer wise assignation *) + + +open Misc +open Obc +open Obc_utils +open Obc_mapfold + + +(** fresh Afor from 0 to [size] with [body] a function from [var_ident] (the iterator) to [act] list *) +let fresh_for size body = + let i = Idents.gen_var "scalarize" "i" in + let id = mk_var_dec i Initial.tint in + let ei = mk_evar_int i in + Afor (id, Initial.mk_static_int 0, size, mk_block (body ei)) + + +let act funs () a = match a with + | Aassgn (p,e) -> + (match e.e_ty with + | Types.Tarray (t, size) -> + (* a reference (alias) to the array, since we could have a full expression *) + let array_ref = Idents.gen_var "scalarize" "a_ref" in + let vd_array_ref = mk_var_dec array_ref (Types.Tmutable p.pat_ty) in + (* reference initialization *) + let pat_array_ref = mk_pattern ~loc:e.e_loc p.pat_ty (Lvar array_ref) in + let init_array_ref = Aassgn (pat_array_ref, e) in + (* the copy loop *) + let array_ref_i i = mk_pattern_exp t (Larray (pat_array_ref, i)) in + let p_i i = mk_pattern t (Larray (p, i)) in + let copy_i i = + (* recursive call to deal with multidimensional arrays (go deeper) *) + let a = Aassgn (p_i i, array_ref_i i) in + let a, _ = act_it funs () a in + [a] + in + let copy_array = fresh_for size copy_i in + (* resulting block *) + let block = mk_block ~locals:[vd_array_ref] [init_array_ref; copy_array] in + Ablock block, () + | _ -> raise Errors.Fallback + ) + | _ -> raise Errors.Fallback + + +let program p = + let p, _ = program_it { defaults with act = act } () p in + p + + diff --git a/compiler/utilities/global/compiler_options.ml b/compiler/utilities/global/compiler_options.ml index 78b5f29..adcd62b 100644 --- a/compiler/utilities/global/compiler_options.ml +++ b/compiler/utilities/global/compiler_options.ml @@ -15,7 +15,7 @@ let version = "0.4" let date = "DATE" (* standard module *) -let pervasives_module = "Pervasives" +let pervasives_module = Pervasives let standard_lib = "STDLIB" let standard_lib = try Sys.getenv "HEPTLIB" with Not_found -> standard_lib @@ -54,10 +54,10 @@ let assert_nodes : name list ref = ref [] let add_assert nd = assert_nodes := nd :: !assert_nodes let simulation = ref false -let simulation_node : name option ref = ref None +let simulation_node : name ref = ref "" let set_simulation_node s = simulation := true; - simulation_node := Some s + simulation_node := s let create_object_file = ref false diff --git a/compiler/utilities/global/compiler_utils.ml b/compiler/utilities/global/compiler_utils.ml index fc0f567..e496733 100644 --- a/compiler/utilities/global/compiler_utils.ml +++ b/compiler/utilities/global/compiler_utils.ml @@ -58,14 +58,14 @@ let silent_pass d enabled f p = then do_silent_pass d f p else p +let filename_of_name n = + String.uncapitalize n + let build_path suf = match !target_path with | None -> suf | Some path -> Filename.concat path suf -let filename_of_name n = - String.uncapitalize n - let clean_dir dir = if Sys.file_exists dir && Sys.is_directory dir then begin @@ -74,6 +74,12 @@ let clean_dir dir = end else Unix.mkdir dir 0o740; dir +let ensure_dir dir = + if not (Sys.file_exists dir && Sys.is_directory dir) + then Unix.mkdir dir 0o740 + + + exception Cannot_find_file of string let findfile filename = diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index 553a28c..5c2d88c 100644 --- a/compiler/utilities/misc.ml +++ b/compiler/utilities/misc.ml @@ -64,6 +64,16 @@ let rec split_last = function let l, a = split_last l in v::l, a +exception List_too_short +(** [split_at n l] splits [l] in two after the [n]th value. + Raises List_too_short exception if the list is too short. *) +let rec split_at n l = match n, l with + | 0, l -> [], l + | _, [] -> raise List_too_short + | n, x::l -> + let l1, l2 = split_at (n-1) l in + x::l1, l2 + let remove x l = List.filter (fun y -> x <> y) l @@ -112,7 +122,7 @@ let rec assocd value = function (** { 3 Compiler iterators } *) -(** Mapfold *) +(** Mapfold *) (* TODO optim : lot's of place we don't need the List.rev *) let mapfold f acc l = let l,acc = List.fold_left (fun (l,acc) e -> let e,acc = f acc e in e::l, acc) @@ -158,16 +168,26 @@ let fold_righti f l acc = | h :: l -> f i h (aux (i + 1) l acc) in aux 0 l acc +exception Assert_false +let internal_error passe code = + Format.eprintf "@.---------\nInternal compiler error\nPasse : %s, Code : %d\n----------@." passe code; + raise Assert_false + +exception Unsupported +let unsupported passe code = + Format.eprintf "@.---------\nUnsupported feature, please report it\nPasse : %s, Code : %d\n----------@." passe code; + raise Unsupported + (* Functions to decompose a list into a tuple *) let _arity_error i l = - Format.eprintf "Internal compiler error: \ - wrong list size (found %d, expected %d).@." (List.length l) i; - assert false + Format.eprintf "@.---------\nInternal compiler error: \ + wrong list size (found %d, expected %d).\n----------@." (List.length l) i; + raise Assert_false let _arity_min_error i l = - Format.eprintf "Internal compiler error: \ - wrong list size (found %d, expected %d at least).@." (List.length l) i; - assert false + Format.eprintf "@.---------\nInternal compiler error: \ + wrong list size (found %d, expected %d at least).\n----------@." (List.length l) i; + raise Assert_false let assert_empty = function | [] -> () @@ -199,3 +219,4 @@ let split_string s separator = Str.split (separator |> Str.quote |> Str.regexp) let file_extension s = split_string s "." |> last_element + diff --git a/compiler/utilities/misc.mli b/compiler/utilities/misc.mli index c9aba5a..2daf31f 100644 --- a/compiler/utilities/misc.mli +++ b/compiler/utilities/misc.mli @@ -36,6 +36,11 @@ val last_element : 'a list -> 'a and the last element of the list .*) val split_last : 'a list -> ('a list * 'a) +exception List_too_short +(** [split_at n l] splits [l] in two after the [n]th value. + Raises List_too_short exception if the list is too short. *) +val split_at : int -> 'a list -> 'a list * 'a list + (** [remove x l] removes all occurrences of x from list l.*) val remove : 'a -> 'a list -> 'a list @@ -90,3 +95,9 @@ val (|>) : 'a -> ('a -> 'b) -> 'b (** Return the extension of a filename string *) val file_extension : string -> string + +(** Internal error : Is used when an assertion wrong *) +val internal_error : string -> int -> 'a + +(** Unsupported : Is used when something should work but is not currently supported *) +val unsupported : string -> int -> 'a diff --git a/heptc b/heptc index 92b231b..94c9a58 100755 --- a/heptc +++ b/heptc @@ -9,17 +9,25 @@ SCRIPT_DIR=$RUN_DIR/`dirname $0` COMPILER_DIR=$SCRIPT_DIR/compiler COMPILER=heptc.byte +COMPILER_DEBUG=heptc.d.byte LIB_DIR=$SCRIPT_DIR/lib #the symlink HEPTC=$COMPILER_DIR/$COMPILER +HEPTC_DEBUG=$COMPILER_DIR/$COMPILER_DEBUG #compile the compiler if [ ! -x $HEPTC ] then - cd $COMPILER_DIR - ocamlbuild -j 0 $COMPILER - cd - + if [ -x $HEPTC_DEBUG ] + then + #use the debug + HEPTC=$HEPTC_DEBUG + else + cd $COMPILER_DIR + ocamlbuild -j 0 $COMPILER + cd - + fi fi #compile the stdlib diff --git a/lib/java/jeptagon/Pervasives.java b/lib/java/jeptagon/Pervasives.java new file mode 100644 index 0000000..6508a64 --- /dev/null +++ b/lib/java/jeptagon/Pervasives.java @@ -0,0 +1,128 @@ +package jeptagon; + +import java.util.concurrent.Executors; +import java.util.concurrent.ExecutorService; +import java.util.concurrent.Future; +import java.util.concurrent.TimeUnit; + +public class Pervasives { + + public static final ExecutorService executor_cached = Executors.newCachedThreadPool(); + + public static class StaticFuture implements Future { + V v; + + public StaticFuture(V v) { this.v = v; } + + public boolean cancel(boolean mayInterruptIfRunning) { return false; } + + public boolean isCancelled() { return false; } + + public boolean isDone() { return true; } + + public V get() { return v; } + + public V get(long timeout, TimeUnit unit) { return v; } + } + + public static class Tuple1 { + public final Object c0; + public Tuple1(Object v) { + c0 = v; + } + } + + public static class Tuple2 { + public final Object c0; + public final Object c1; + public Tuple2(Object v0, Object v1) { + c0 = v0; + c1 = v1; + } + } + + public static class Tuple3 { + public final Object c0; + public final Object c1; + public final Object c2; + public Tuple3(Object v0, Object v1, Object v2) { + c0 = v0; + c1 = v1; + c2 = v2; + } + } + + public static class Tuple4 { + public final Object c0; + public final Object c1; + public final Object c2; + public final Object c3; + public Tuple4(Object v0, Object v1, Object v2, Object v3) { + c0 = v0; + c1 = v1; + c2 = v2; + c3 = v3; + } + } + + public static class Tuple5 { + public final Object c0; + public final Object c1; + public final Object c2; + public final Object c3; + public final Object c4; + public Tuple5(Object v0, Object v1, Object v2, Object v3, Object v4) { + c0 = v0; + c1 = v1; + c2 = v2; + c3 = v3; + c4 = v4; + } + } + + public static class Tuple6 { + public final Object c0; + public final Object c1; + public final Object c2; + public final Object c3; + public final Object c4; + public final Object c5; + public Tuple6(Object v0, Object v1, Object v2, Object v3, Object v4, Object v5) { + c0 = v0; + c1 = v1; + c2 = v2; + c3 = v3; + c4 = v4; + c5 = v5; + } + } + + public static class Tuple7 { + public final Object c0; + public final Object c1; + public final Object c2; + public final Object c3; + public final Object c4; + public final Object c5; + public final Object c6; + public Tuple7(Object v0, Object v1, Object v2, Object v3, Object v4, Object v5, Object v6) { + c0 = v0; + c1 = v1; + c2 = v2; + c3 = v3; + c4 = v4; + c5 = v5; + c6 = v6; + } + } + + public static int do_stuff(int coeff) { + int x = 13; + for (int i = 0; i < coeff; i++) { + for (int j = 0; j < 1000000; j++) { + x = (x + j) % (x + j/x) + 13; + } + } + return x; + } +} diff --git a/lib/pervasives.epi b/lib/pervasives.epi index 2e76e49..0b66f7c 100644 --- a/lib/pervasives.epi +++ b/lib/pervasives.epi @@ -27,4 +27,4 @@ val fun (or)(bool;bool) returns (bool) val fun (xor)(bool;bool) returns (bool) val fun (~-)(int) returns (int) val fun (~-.)(float) returns (float) - +val fun do_stuff(int) returns (int) diff --git a/test/bad/t11-initialization.ept b/test/bad/t11-initialization.ept index 76ece05..ac66d36 100644 --- a/test/bad/t11-initialization.ept +++ b/test/bad/t11-initialization.ept @@ -1,4 +1,4 @@ -node mmm(x: int) returns (o': int) +node mmm(x: int) returns (o2: int) var last m: int; o: int; let automaton @@ -7,5 +7,5 @@ node mmm(x: int) returns (o': int) state J do m = last m + 1; o = 0 end; - o' = 1 -> pre o + o2 = 1 -> pre o tel diff --git a/test/check b/test/check index 341a867..37bbf3c 100755 --- a/test/check +++ b/test/check @@ -91,7 +91,7 @@ launch_check () { score=`expr $score + 1`; fi done - + echo echo "Tests goods" for f in ../good/*.ept; do echec=0 @@ -114,18 +114,18 @@ launch_check () { fi fi # Compil. java ? - if [[ ($echec == 0) && ($java == 1) ]]; then - pushd "${base_f}" > /dev/null - for java_file in *.java ; do - if $JAVAC -warn:-unused -sourcepath .:..:../t1 ${java_file} > /dev/null - then - echec=0 - else - echec=3 - fi - done - popd > /dev/null - fi + #if [[ ($echec == 0) && ($java == 1) ]]; then + # pushd "${base_f}_java" > /dev/null + # for java_file in *.java ; do + # if $JAVAC -warn:-unused -sourcepath .:..:../t1 ${java_file} > /dev/null + # then + # echec=0 + # else + # echec=3 + # fi + # done + # popd > /dev/null + #fi # Compil. c ? if [[ ($echec == 0) && ($c == 1) ]]; then pushd ${base_f}_c >/dev/null @@ -235,6 +235,7 @@ while [ $# -gt 0 ]; do "-h" ) echo "usage : $0 " echo "options : " + echo "-clean : clean build dir" echo "-java : test of code generation (java code)" echo "-c : test of code generation (c code)" echo "-all : test all" diff --git a/test/good/array1.ept b/test/good/array1.ept index 143ba5d..526ec44 100644 --- a/test/good/array1.ept +++ b/test/good/array1.ept @@ -1,5 +1,5 @@ -const n:int = 42 -const m:int = 52 +const n:int = 10 +const m:int = 10 node concatenate(a:int^n; b:int^m) returns (o1, o2: int^(n+m)) let @@ -41,3 +41,13 @@ node constant(a,b:int) returns (o:int^4) let o = [a,b,a,b]; tel + + +node test1() returns (r1,r2: int^3) +var x,y : int^10; z,t : int^20; +let + x = ten(3); + y = ten(4); + (z,t) = concatenate(x,y); + (r1,r2) = slicing(x); +tel diff --git a/test/good/array_fill.ept b/test/good/array_fill.ept index 3cac5b9..4078a15 100644 --- a/test/good/array_fill.ept +++ b/test/good/array_fill.ept @@ -1,9 +1,10 @@ const n : int = 33 node stopbb(shiftenable : bool) returns (dataout : bool^n) -var last dataint : bool^n = false^n; +var last dataint : bool^n; f : bool; let - dataout = (false^n) fby dataint; + f = false; + dataout = (f^n) fby dataint; switch shiftenable | true do dataint = [true] @ dataout[0 .. n - 2]; | false do diff --git a/test/good/bad_updown.ept b/test/good/bad_updown.ept index 771ed38..30ee967 100644 --- a/test/good/bad_updown.ept +++ b/test/good/bad_updown.ept @@ -1,12 +1,12 @@ node updown(b : bool) returns (o : bool) -var o',on_off:bool; +var o2,on_off:bool; let on_off = true; automaton state Down - do o' = false until on_off then Up + do o2 = false until on_off then Up state Up - do o' = true until on_off then Down + do o2 = true until on_off then Down end; - o = merge b (true-> o') (false -> false) + o = merge b (true-> o2) (false -> false) tel diff --git a/test/good/flatten.ept b/test/good/flatten.ept index e9c656f..d78765e 100644 --- a/test/good/flatten.ept +++ b/test/good/flatten.ept @@ -3,12 +3,12 @@ node f(x,y : int; b : bool) returns (z : int) var t : int; let do - var t2,t2' : int; in - t2 = if b then 0 else t2'; + var t2,t22 : int; in + t2 = if b then 0 else t22; do var t3 : int; in t3 = y + t; - t2' = t3; + t22 = t3; done; t = x + t2; done; diff --git a/test/good/statics2.ept b/test/good/statics2.ept index 22b5768..fd13fb9 100644 --- a/test/good/statics2.ept +++ b/test/good/statics2.ept @@ -24,9 +24,9 @@ let o = f<>(); tel -fun h() returns (y,y':int) +fun h() returns (y,y2:int) let y = c2 + g<>() + i<>(); - y' = c2 + Statics.g<>() + Statics.i<>(); + y2 = c2 + Statics.g<>() + Statics.i<>(); tel diff --git a/test/good/t1.ept b/test/good/t1.ept index d078cf8..a5aec34 100644 --- a/test/good/t1.ept +++ b/test/good/t1.ept @@ -17,7 +17,7 @@ node mm(x: int) returns (o: int) end tel -node mmm(x: int) returns (o': int) +node mmm(x: int) returns (o2: int) var last m: int = 1; o: int; let automaton @@ -26,21 +26,21 @@ node mmm(x: int) returns (o': int) state J do m = last m + 1; o = 0 end; - o' = 1 -> pre o + o2 = 1 -> pre o tel node m(x: int) returns (o: int) - var last o' : int = 1; + var last o2 : int = 1; let automaton state I - do o' = 1 - unless (last o' = 2) then J + do o2 = 1 + unless (last o2 = 2) then J state J - do o' = 3 - unless (last o' = 1) then I + do o2 = 3 + unless (last o2 = 1) then I end; - o = o'; + o = o2; tel node h(z: int; x, y: int) returns (o2: int) diff --git a/test/good/t13.ept b/test/good/t13.ept index 499cffb..375db60 100644 --- a/test/good/t13.ept +++ b/test/good/t13.ept @@ -1,7 +1,6 @@ node count(c : int; r : bool) returns (res : int) let -(* res = c fby (if r then 0 else res + c);*) - res = 0; + res = c fby (if r then 0 else res + c); tel node fourth() returns (res : bool) diff --git a/test/good/t2.ept b/test/good/t2.ept index c4a695e..d770bb8 100644 --- a/test/good/t2.ept +++ b/test/good/t2.ept @@ -32,13 +32,13 @@ node g(x: bool) returns (o: bool) tel node hhh() returns () - var last o' : int = 0; + var last o2 : int = 0; let automaton state S1 var r: int; - do o' = 1; r = 2 - unless last o' = 0 then S1 + do o2 = 1; r = 2 + unless last o2 = 0 then S1 end tel diff --git a/test/good/t5.ept b/test/good/t5.ept index 53688b4..460e007 100644 --- a/test/good/t5.ept +++ b/test/good/t5.ept @@ -1,6 +1,5 @@ (* pour debugger set arguments -v test/good/t1.mls *) -type t node f(x,z:int) returns (o1:int) var o: int; diff --git a/test/good/t9.ept b/test/good/t9.ept index ea95ed0..b2902f7 100644 --- a/test/good/t9.ept +++ b/test/good/t9.ept @@ -4,8 +4,8 @@ node f(x,z:int) returns (o1,o2:int) let switch (x = z) - | true var o'1: int; o'2: int; - do (o'1, o'2) = (1, 2); o1 = o'1; o2 = o'2; + | true var o12: int; o22: int; + do (o12, o22) = (1, 2); o1 = o12; o2 = o22; | false do (o2, o1) = (3, 3); end tel diff --git a/test/good/test.ept b/test/good/test.ept index 1fd9d38..5e04bc2 100644 --- a/test/good/test.ept +++ b/test/good/test.ept @@ -11,12 +11,12 @@ let tel -node updown'() returns (y:int) +node updown2() returns (y:int) let y = (0 fby y) + 1 tel node main() returns (y:int) let - y = updown'(); + y = updown2(); tel diff --git a/test/good/when_merge1.ept b/test/good/when_merge1.ept index eeedb0c..2449542 100644 --- a/test/good/when_merge1.ept +++ b/test/good/when_merge1.ept @@ -25,7 +25,7 @@ node mm(x: int) returns (o: int) end tel -node mmm(x: int) returns (o': int) +node mmm(x: int) returns (o2: int) var last m: int = 1; o: int; let automaton @@ -34,21 +34,21 @@ node mmm(x: int) returns (o': int) state J do m = last m + 1; o = 0 end; - o' = 1 -> pre o + o2 = 1 -> pre o tel node m(x: int) returns (o: int) - var last o' : int = 1; + var last o2 : int = 1; let automaton state I - do o' = 1 - unless (last o' = 2) then J + do o2 = 1 + unless (last o2 = 2) then J state J - do o' = 3 - unless (last o' = 1) then I + do o2 = 3 + unless (last o2 = 1) then I end; - o = o'; + o = o2; tel node h(z: int; x, y: int) returns (o2: int) diff --git a/todo.txt b/todo.txt index ba66f3b..b83963b 100644 --- a/todo.txt +++ b/todo.txt @@ -1,6 +1,12 @@ 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. + +*- Les types des patterns dans les boucles crées par concatenate ( entre autres ) sont faux. + +*- 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. diff --git a/tools/debugger_script b/tools/debugger_script index d6911ff..b55afc3 100644 --- a/tools/debugger_script +++ b/tools/debugger_script @@ -1,31 +1,31 @@ load_printer "/sw/lib/ocaml/menhirLib/menhirLib.cmo" load_printer "/sw/lib/ocaml/str.cma" -load_printer "_build/global/names.d.cmo" -load_printer "_build/global/location.d.cmo" +load_printer "_build/menhirLib.cmo" load_printer "_build/utilities/misc.d.cmo" -load_printer "_build/global/types.d.cmo" -load_printer "_build/global/signature.d.cmo" +load_printer "_build/global/names.d.cmo" load_printer "_build/utilities/global/compiler_options.d.cmo" +load_printer "_build/global/idents.d.cmo" +load_printer "_build/global/location.d.cmo" +load_printer "_build/global/types.d.cmo" +load_printer "_build/global/clocks.d.cmo" +load_printer "_build/global/signature.d.cmo" load_printer "_build/utilities/global/errors.d.cmo" load_printer "_build/utilities/global/compiler_utils.d.cmo" load_printer "_build/global/modules.d.cmo" -load_printer "_build/global/initial.d.cmo" -load_printer "_build/global/idents.d.cmo" -load_printer "_build/global/clocks.d.cmo" load_printer "_build/utilities/pp_tools.d.cmo" load_printer "_build/global/global_printer.d.cmo" +load_printer "_build/global/initial.d.cmo" load_printer "_build/global/static.d.cmo" load_printer "_build/heptagon/heptagon.d.cmo" +load_printer "_build/utilities/graph.d.cmo" +load_printer "_build/heptagon/analysis/causal.d.cmo" +load_printer "_build/heptagon/analysis/causality.d.cmo" load_printer "_build/heptagon/analysis/initialization.d.cmo" load_printer "_build/global/global_mapfold.d.cmo" load_printer "_build/heptagon/hept_mapfold.d.cmo" load_printer "_build/heptagon/analysis/statefull.d.cmo" load_printer "_build/heptagon/analysis/typing.d.cmo" load_printer "_build/heptagon/hept_printer.d.cmo" -load_printer "_build/heptagon/parsing/hept_parsetree.d.cmo" -load_printer "_build/heptagon/parsing/hept_parser.d.cmo" -load_printer "_build/heptagon/parsing/hept_lexer.d.cmo" -load_printer "_build/heptagon/parsing/hept_scoping.d.cmo" load_printer "_build/heptagon/transformations/automata.d.cmo" load_printer "_build/heptagon/transformations/block.d.cmo" load_printer "_build/heptagon/transformations/completion.d.cmo" @@ -33,28 +33,34 @@ load_printer "_build/heptagon/transformations/reset.d.cmo" load_printer "_build/heptagon/transformations/every.d.cmo" load_printer "_build/heptagon/transformations/last.d.cmo" load_printer "_build/heptagon/transformations/present.d.cmo" +load_printer "_build/heptagon/transformations/switch.d.cmo" load_printer "_build/heptagon/main/hept_compiler.d.cmo" +load_printer "_build/heptagon/parsing/hept_parsetree.d.cmo" +load_printer "_build/heptagon/parsing/hept_parser.d.cmo" +load_printer "_build/heptagon/parsing/hept_lexer.d.cmo" +load_printer "_build/heptagon/parsing/hept_scoping.d.cmo" load_printer "_build/heptagon/parsing/hept_parsetree_mapfold.d.cmo" load_printer "_build/heptagon/parsing/hept_static_scoping.d.cmo" +load_printer "_build/heptagon/main/hept_parser_scoper.d.cmo" load_printer "_build/minils/minils.d.cmo" load_printer "_build/minils/mls_mapfold.d.cmo" load_printer "_build/minils/mls_printer.d.cmo" -load_printer "_build/utilities/graph.d.cmo" load_printer "_build/utilities/global/dep.d.cmo" load_printer "_build/minils/mls_utils.d.cmo" load_printer "_build/main/hept2mls.d.cmo" load_printer "_build/minils/transformations/itfusion.d.cmo" load_printer "_build/obc/obc.d.cmo" -load_printer "_build/obc/control.d.cmo" load_printer "_build/obc/obc_mapfold.d.cmo" +load_printer "_build/obc/obc_utils.d.cmo" +load_printer "_build/obc/control.d.cmo" load_printer "_build/main/mls2obc.d.cmo" load_printer "_build/minils/transformations/callgraph.d.cmo" -load_printer "_build/obc/c/c.d.cmo" -load_printer "_build/obc/c/csubst.d.cmo" -load_printer "_build/obc/obc_utils.d.cmo" -load_printer "_build/obc/c/cgen.d.cmo" -load_printer "_build/obc/c/cmain.d.cmo" +load_printer "_build/obc/java/java.d.cmo" +load_printer "_build/obc/java/java_printer.d.cmo" +load_printer "_build/obc/java/obc2java.d.cmo" +load_printer "_build/obc/java/java_main.d.cmo" load_printer "_build/obc/obc_printer.d.cmo" +load_printer "_build/obc/transformations/scalarize.d.cmo" load_printer "_build/minils/main/mls2seq.d.cmo" load_printer "_build/minils/analysis/clocking.d.cmo" load_printer "_build/minils/transformations/normalize.d.cmo" @@ -66,5 +72,5 @@ load_printer "_build/minils/transformations/introvars.d.cmo" load_printer "_build/minils/transformations/singletonvars.d.cmo" load_printer "_build/minils/transformations/tomato.d.cmo" load_printer "_build/minils/main/mls_compiler.d.cmo" -load_printer "_build/main/heptc.d.cmo" +load_printer "_build/main/heptc.d.cmo