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

Merge branch 'java'

Browse source 
Conflicts:
	.gitignore
	compiler/global/global_printer.ml
	compiler/main/mls2obc.ml
This commit is contained in:
Léonard Gérard 2011-03-21 22:21:00 +01:00
commit 6b720e6c23
101 changed files with 5795 additions and 1553 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -27,3 +27,4 @@ _build
*.dot
test/*.ml
test/_check_builds
lib/java/.classpath

6
compiler/TODO.txt Executable file
View file

@ -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

4
compiler/global/clocks.ml
View file

@ -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 *)

12
compiler/global/global_compare.ml
View file

@ -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

27
compiler/global/global_mapfold.ml
View file

@ -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

41
compiler/global/global_printer.ml
View file

@ -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 "@[<hov2>%a@]" (print_list_r print_type "(" " *" ")") ty_list
| Tid id -> print_qualname ff id
| Tarray (ty, n) ->
fprintf ff "@[<hov2>%a^%a@]" print_type ty print_static_exp n
| Tmutable ty ->
fprintf ff "@[<hov2>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

6
compiler/global/idents.mli
View file

@ -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

28
compiler/global/initial.ml
View file

@ -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

60
compiler/global/modules.ml
View file

@ -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

62
compiler/global/names.ml
View file

@ -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)

6
compiler/global/signature.ml
View file

@ -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 }

139
compiler/global/static.ml
View file

@ -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)

14
compiler/global/types.ml
View file

@ -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 =

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

@ -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

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

@ -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) ->

67
compiler/heptagon/analysis/statefull.ml
View file

@ -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

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

@ -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

68
compiler/heptagon/hept_mapfold.ml
View file

@ -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

104
compiler/heptagon/hept_printer.ml
View file

@ -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 "@[<hv>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 "@[<hv>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

46
compiler/heptagon/heptagon.ml
View file

@ -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 }

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

@ -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 *)

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

@ -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"

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

@ -121,7 +121,9 @@ rule token = parse
| [' ' '\t'] + { token lexbuf }
| "." {DOT}
| "(" {LPAREN}
| "((" {LPARENLPAREN}
| ")" {RPAREN}
| "))" {RPARENRPAREN}
| "*" { STAR }
| "{" {LBRACE}
| "}" {RBRACE}

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

@ -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 <string> Constructor
%token <string> 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)) }) }

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

@ -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 }

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

@ -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

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

@ -172,8 +172,8 @@ let translate_iterator_type = function
op<a1,a2> (a3) == op <a1> (a2,a3) == op (a1,a2,a3) *)
let static_app_from_app app args=
match app.a_op with
| Efun (Q ({ qual = "Pervasives" } as q))
| Enode (Q ({ qual = "Pervasives" } as q)) ->
| 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

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

@ -17,8 +17,8 @@ let assert_se e = match e.e_desc with
op<a1,a2> (a3) == op <a1> (a2,a3) == op (a1,a2,a3) *)
let static_app_from_app app args =
match app.a_op with
| Efun ((Q { 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

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

@ -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 =

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

@ -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

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

@ -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

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

@ -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

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

@ -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}

11
compiler/main/hept2mls.ml
View file

@ -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 ;

4
compiler/main/heptc.ml
View file

@ -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

442
compiler/main/mls2obc.ml
View file

@ -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; }

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

@ -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)

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

@ -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 =

19
compiler/minils/minils.ml
View file

@ -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 <<n>> (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))

10
compiler/minils/mls_compare.ml
View file

@ -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

5
compiler/minils/mls_mapfold.ml
View file

@ -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

98
compiler/minils/mls_printer.ml
View file

@ -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 "@[<hv>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 "@[<hv>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 "@[<v2>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

11
compiler/minils/mls_utils.ml
View file

@ -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

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

@ -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

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

@ -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 = [] };

6
compiler/minils/transformations/introvars.ml
View file

@ -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) =

12
compiler/minils/transformations/itfusion.ml
View file

@ -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

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

@ -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

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

@ -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 =

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

@ -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)

27
compiler/minils/transformations/tomato.ml
View file

@ -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

2
compiler/obc/_tags
View file

@ -1 +1 @@
<c> or <java>:include
<transformations> or <c> or <java>:include

38
compiler/obc/c/c.ml
View file

@ -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 =

5
compiler/obc/c/c.mli
View file

@ -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. *)

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

@ -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

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

@ -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

5
compiler/obc/control.ml
View file

@ -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

660
compiler/obc/java/java.ml
View file

@ -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 "@[<v>@[<v 2>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 "@ @[<v 2>public %s(@[<hov>" 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 "@[<v>@[<v 2>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 "@[<v>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 "@[<v>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(@[<hov>"
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 "@[<v>@[<v 2>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 "@[<v 2>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 "@[<v 2>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 "@[<v>@[<v 2>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 "@[<v>@[<v 2>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 "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e;
print_act ff a1 objs avs ts single;
fprintf ff "@]@ @[<v 2>} else {@ ";
print_act ff a2 objs avs ts single;
fprintf ff "@]@ }@]"
| [("false", a2); ("true", a1)] ->
fprintf ff "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e;
print_act ff a1 objs avs ts single;
fprintf ff "@]@ @[<v 2>} 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 "@[<v>";
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 "@[<v>";
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 "@[<v>@[<v 2>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 "@[<v>@ @[<v 2>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 "@[<v>@ @[<v 2>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 "@[<v>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@[<v 2>public class %s {@ " clid;
if cl.mem = [] then ()
else fprintf ff "@[<v>@ "; print_mem ff cl.mem; fprintf ff "@]";
if cl.objs = [] then ()
else fprintf ff "@[<v>@ "; 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 "@[<v>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

69
compiler/obc/java/java_main.ml Normal file
View file

@ -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]
)

233
compiler/obc/java/java_printer.ml Normal file
View file

@ -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 "@[<v>%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 "@[<hv 2> 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 "@[<v4>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 "@[<v4>switch (%a) {@ %a@]@\n}"
exp e
(print_list_r pcb """""") c_b_l
| Aif (e,bt) ->
fprintf ff "@[<v 4>if (%a) {@ %a }@]" exp e block bt
| Aifelse (e,bt,bf) ->
fprintf ff "@[<v>@[<v4>if (%a) {@ %a@]@ @[<v4>} else {@ %a@]@ }@]"
exp e
block bt
block bf
| Ablock b -> if (List.length b.b_body > 0) then fprintf ff "@[<v>@[<v4>{@ %a@]@ }@]" block b
| Afor (x, i1, i2, b) ->
fprintf ff "@[<hv>@[<hv 4>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 "@[<v4>%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 "@[<v4>%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 "@[<v>%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 @[<h>%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@[<v>%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

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

@ -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

407
compiler/obc/java/obc2java.ml Normal file
View file

@ -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

543
compiler/obc/java/old_java.ml Normal file
View file

@ -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 "@[<v>@[<v 2>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 "@ @[<v 2>public %s(@[<hov>" 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 "@[<v>@[<v 2>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 "@[<v>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 "@[<v>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(@[<hov>"
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 "@[<v>@[<v 2>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 "@[<v 2>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 "@[<v>@[<v 2>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 "@[<v>@[<v 2>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 "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e;
print_block ff a1 objs avs ts single;
fprintf ff "@]@ @[<v 2>} else {@ ";
print_block ff a2 objs avs ts single;
fprintf ff "@]@ }@]"
| [("false", a2); ("true", a1)] ->
fprintf ff "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e;
print_block ff a1 objs avs ts single;
fprintf ff "@]@ @[<v 2>} 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 "@[<v>";
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 "@[<v>";
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 "@[<v>@[<v 2>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 "@[<v>@ @[<v 2>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 "@[<v>@ @[<v 2>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 "@[<v>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@[<v 2>public class %s {@ " clid;
if cl.mem = [] then ()
else fprintf ff "@[<v>@ "; print_mem ff cl.mem; fprintf ff "@]";
if cl.objs = [] then ()
else fprintf ff "@[<v>@ "; 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 "@[<v>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
(******************************)

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

@ -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]

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

@ -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

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

@ -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 ()

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

@ -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

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

@ -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.<init, code, res> is translated into
(1) combinatorial function
\x1...xn.code;res
(2) \x1...xn.self.
let self = match !self with
Nil -> let v = { ... init ... } in
self := St(v);v
| St(self) -> self in
code;
res
r = f [...] x1...xn is translated into:
(1) combinatorial function
f = f [...] x1...xn
(2) state function
st = ref Nil initialisation part
r = f x1...xn st step part
Rmk: we can also write: "if reset then self := { ... }"
*)
let co_apply env is_state (init_write, init_mem) f subst e_list =
if is_state then
(* state function *)
let st = prefix_for_names ^ (string_of_int symbol#name) in
let prefix = selfstate env in
(init_write, (st, Cref(state_nil)) :: init_mem),
Capply(f,
(subst @ e_list @ [Crecord_access(Cvar(prefix), qualid st)]))
else
(init_write, init_mem), Capply(f, subst @ e_list)
(* prepare the initialization of memory variables *)
let cmatchstate self states =
let v = prefix_for_names ^ (string_of_int (symbol#name)) in
let st = prefix_state_constr ^ (string_of_int (symbol#name)) in
Cmatch(Cderef(Cvar(self)),
[Cconstructpat(qualid st,[Cvarpat(self)]), Cvar(self);
Cwildpat, Clet(false, [Cvarpat(v), states],
Cseq[Cset(self,
Cconstruct(qualid st, [Cvar(v)]));
Cvar(v)])])
(* prepare the initialization of write variables *)
let define_init_writes env init_write code =
List.fold_right
(fun (name, e) code -> Clet(false, [Cvarpat(name), Cref e], code))
init_write code
let co_fun env
is_state params p_list static (init_write, init_mem) code result =
if init_mem <> [] then intro_record_type init_mem;
let code = clet code result in
let code =
if init_write <> []
then define_init_writes env init_write code
else code in
let self = selfstate env in
if is_state
then
if init_mem = [] then Cfun(params @ p_list @ [Cvarpat(self)], code)
else Cfun(params @ p_list @ [Cvarpat(self)],
Clet(false, [Cvarpat(self),
cmatchstate self
(clet static (state_record init_mem))],
code))
else Cfun(params @ p_list, code)
(** Compilation of pattern matching *)
(*
match e with
P1 -> e1
| ...
| Pn -> en
(1) e is a static computation
- initialisation code
let memory = match e with
P1 -> St1 { ... }
| ...
| Pn -> Stn { ... }
- step code
match memory with
St1{...} -> step1
| ...
| Stn{...} -> stepn
(2) e may evolve at every instant
- init code
...i1...
...in...
- match e with
P1 -> step1
| ...
| Pn -> stepn
for the moment, we treat case (1) as case (2) *)
(*
let co_static_merge e (pat, init_code_fvars_list) =
(* introduces the type definitions for the representation of states *)
let n = List.length init_code_fvars_list in
let prefix_constructor = intro_enum_type n in
(* builds a constructor value *)
let constructor prefix number f_vars =
Cconstruct(qualid (prefix ^ (string_of_int number)),
List.map (fun name -> Cvar(name)) fvars) in
let constructor_pat prefix number f_vars =
Cconstructpat(qualid (prefix ^ (string_of_int number)),
List.map (fun name -> Cvarpat(name)) fvars) in
(* computes the initialisation part *)
let rec states number init_code_fvars_list =
match init_code_fvars_list with
[] -> []
| (pat, init, _, fvars) :: init_code_fvars_list ->
let pat_code = (pat, clet init (constructor prefix number fvars)) in
let pat_code_list = states (number + 1) init_code_fvars_list in
pat_code :: code_list in
(* computes the transition part *)
let rec steps number init_code_fvars_list =
match init_code_fvars_list with
[] -> []
| (_, _, code, fvars) :: init_code_fvars_list ->
let pat_code = (constructor_pat prefix number fvars, code) in
let pat_code_list = steps (number + 1) init_code_fvars_list in
pat_code :: pat_code_list in
(* make the final code *)
let memory = symbol#name in
let init_code = Cmatch(e, states 0 init_code_fvars_list) in
let step_code = Cmatch(Cvar memory, steps 0 init_code_fvars_list) in
Tlet(memory, init_code), step_code
*)
(** Compilation of clocks *)
let rec translate_clock env init ck =
match ck with
Dfalse -> init, cfalse
| Dtrue -> init, ctrue
| Dclockvar(n) -> init, access env n
| Don(is_on, ck, car) ->
let init, ck = translate_clock env init ck in
let init, car = translate_carrier env init car in
init, if is_on then cand car ck
else cand (cnot car) ck
and translate_carrier env init car =
match car with
Dcfalse -> init, cfalse
| Dctrue -> init, ctrue
| Dcvar(n) -> init, access env n
| Dcglobal(g, res, ck) ->
(* a global clock allocates memory *)
(* and is compiled as a function call *)
let res = match res with None -> cfalse | Some(n) -> access env n in
let init, c = translate_clock env init ck in
let init, new_ce =
co_apply env true init (Cglobal g) [c] [res] in
init, new_ce
(** Compiling immediate. *)
let translate_immediate i =
match i with
| Dbool(b) -> Cbool(b)
| Dint(i) -> Cint(i)
| Dfloat(f) -> Cfloat(f)
| Dchar(c) -> Cchar(c)
| Dstring(s) -> Cstring(s)
| Dvoid -> Cvoid
(** Compiling variables. *)
let translate_var env v =
match v with
Dglobal(g) -> Cglobal(g)
| Dlocal(n) -> access env n
(** Compiling a pattern. *)
let rec translate_pat env pat =
match pat with
| Dconstantpat(i) -> Cconstantpat(translate_immediate(i))
| Dvarpat(s) -> Cvarpat(string_of_name env s)
| Dtuplepat(l) -> Ctuplepat(List.map (translate_pat env) l)
| Dconstructpat(gl, pat_list) ->
Cconstructpat(gl, List.map (translate_pat env) pat_list)
| Dorpat(pat1, pat2) -> Corpat(translate_pat env pat1,
translate_pat env pat2)
| Drecordpat(gl_pat_list) ->
Crecordpat
(List.map (fun (gl, pat) -> (gl, translate_pat env pat))
gl_pat_list)
| Daliaspat(pat, i) -> Caliaspat(translate_pat env pat,
string_of_name env i)
| Dwildpat -> Cwildpat
(*
(* add accesses to write variables defined in patterns *)
let rec add_write_access env code pat =
match pat with
Dconstantpat(i) -> code
| Dvarpat(s) when is_a_write (find env s) ->
Tset(string_of_name env s, access env s) :: code
| Dvarpat _ -> code
| Dtuplepat(l) | Dconstructpat(_, l) ->
List.fold_left (add_write_access env) code l
| Dorpat(pat1, pat2) ->
add_write_access env (add_write_access env code pat1) pat2
| Drecordpat(gl_pat_list) ->
List.fold_left (fun code (_, pat) -> add_write_access env code pat)
code gl_pat_list
| Daliaspat(pat, i) ->
add_write_access env (add_write_access env code pat) (Dvarpat(i))
| Dwildpat -> code
*)
(** Compiling an expression *)
(* takes an environment giving information about variables *)
(* and an expression and returns the new code *)
let rec translate env init e =
match e.d_desc with
| Dconstant(i) ->
let i = translate_immediate i in
init, Cconstant(i)
| Dvar(v, subst) ->
let v = translate_var env v in
let init, s = translate_subst env init subst in
let v = match s with [] -> v | l -> Capply(v, l) in
init, v
| Dtuple l ->
let init, lc = translate_list env init l in
init, Ctuple(lc)
| Dfun(is_state, params, p_list, body, result) ->
(* state function *)
let env = push_block body env in
(* compiles types and clock abstractions *)
let params = translate_forall env params in
(* compiles parameters *)
let p_list = List.map (translate_pat env) p_list in
(* remove static computation from the body *)
(* and put it in the allocation place for stateful functions *)
let (static_code, init_code, body, result) =
if is_state
then
let static_code, body = static_block [] body in
let static_code, result = static static_code result in
let static_code = List.rev static_code in
(* translate the static code *)
let static_code, init_code =
translate_static_code env static_code in
(static_code, init_code, body, result)
else
([], ([], []), body, result) in
(* then translate the body *)
let init_code, body = translate_block env init_code body in
let init_code, result = translate env init_code result in
init,
co_fun env is_state params p_list static_code init_code body result
| Dprim(g, e_list) ->
(* pointwise application *)
let init, ce_list = translate_list env init e_list in
init, Capply(Cglobal(g), ce_list)
| Dconstruct(g, e_list) ->
let init, ce_list = translate_list env init e_list in
init, Cconstruct(g, ce_list)
| Drecord(gl_expr_list) ->
let translate_record (gl, expr) (init, gl_expr_list) =
let init, ce = translate env init expr in
init, (gl, ce) :: gl_expr_list in
let init, l =
List.fold_right translate_record gl_expr_list (init, []) in
init, Crecord(l)
| Drecord_access(expr, gl) ->
let init, ce = translate env init expr in
init, Crecord_access(ce, gl)
| Difthenelse(e0, e1, e2) ->
let init, c0 = translate env init e0 in
let init, c1 = translate env init e1 in
let init, c2 = translate env init e2 in
init, Cifthenelse(c0, c1, c2)
| Dlet(block, e_let) ->
let env = push block env in
let init, code = translate_block env init block in
let init, ce = translate env init e_let in
init, clet code ce
| Dapply(is_state, { d_desc = Dvar(f, subst) }, l) ->
let f = translate_var env f in
let init, l = translate_list env init l in
let init, subst = translate_subst env init subst in
co_apply env is_state init f subst l
| Dapply(is_state, f, l) ->
let init, f = translate env init f in
let init, l = translate_list env init l in
co_apply env is_state init f [] l
| Deseq(e1, e2) ->
let init, e1 = translate env init e1 in
let init, e2 = translate env init e2 in
init, Cseq [e1; e2]
| Dwhen(e1) ->
translate env init e1
| Dclock(ck) ->
translate_clock env init ck
| Dlast _ | Dinit _ | Dpre _ | Dtest _ ->
(* this case should not arrive *)
fatal_error "translate"
and translate_list env init l =
match l with
[] -> init, []
| ce :: l ->
let init, ce = translate env init ce in
let init, l = translate_list env init l in
init, ce :: l
and translate_block env init b =
(* allocate the memory in the initialisation part *)
let init = allocate_memory env init in
(* compiles the body *)
let init, code = translate_equation env init [] b.b_equations in
(* sets code in the correct order *)
let code = List.rev code in
(* returns the components of the block *)
init, code
(* the input equations must be already scheduled *)
and translate_equations env init code eq_list =
match eq_list with
[] -> init, code
| eq :: eq_list ->
let init, code = translate_equation env init code eq in
translate_equations env init code eq_list
and translate_equation_into_exp env init eq =
let init, code = translate_equation env init [] eq in
(* sets code in the correct order *)
let code = List.rev code in
init, cseq code
and translate_block_into_exp env init block =
let init, code = translate_block env init block in
init, cseq code
and translate_equation env init code eq =
match eq with
Dget(pat, v) ->
let cpat = translate_pat env pat in
let n = translate_var env v in
init, Tlet(cpat, n) :: code
| Dequation(Dvarpat(n), e) when is_a_write (find env n) ->
let name = string_of_name env n in
let init, ce = translate env init e in
init, (set name ce) :: code
| Dequation(pat, e) | Dstatic(pat, e) ->
let is_rec = is_recursive pat e in
let pat = translate_pat env pat in
let init, ce = translate env init e in
init, if is_rec then Tletrec([pat, ce]) :: code
else Tlet(pat, ce) :: code
| Dwheneq(eq, ck) ->
let init, ce = translate_equation_into_exp env init eq in
let init, ck_ce = translate_clock env init ck in
init, Texp(ifthen ck_ce ce) :: code
| Dmerge(is_static, e, p_block_list) ->
let init, ce = translate env init e in
let init, l = translate_pat_block_list env init p_block_list in
init, merge code ce l
| Dnext(n, e) ->
(* n is either a memo or an initialisation variable *)
let init, ce = translate env init e in
init, (next (selfstate env) (string_of_name env n) ce) :: code
| Dseq(eq_list) | Dpar(eq_list) ->
translate_equations env init code eq_list
| Dblock(block) ->
translate_block env init block
| Demit _ | Dlasteq _ | Dautomaton _ | Dreset _ | Dpresent _ ->
(* these cases should not arrive since control structures have *)
(* been translated into the basic kernel *)
fatal_error "translate_equation"
(* compilation of pattern matching *)
and translate_pat_block_list env init p_block_list =
(* compile one handler *)
let translate_pat_block init (pat, block) =
let env = push block env in
let cpat = translate_pat env pat in
let init, ce = translate_block_into_exp env init block in
init, (cpat, ce) in
match p_block_list with
[] -> init, []
| pat_block :: pat_block_list ->
let init, pat_ce = translate_pat_block init pat_block in
let init, pat_ce_list =
translate_pat_block_list env init pat_block_list in
init, pat_ce :: pat_ce_list
(* translate a pure (stateless) expression *)
and translate_pure env e =
let init, ce = translate env ([], []) e in
assert (init = ([], []));
ce
(* computes extra parameters for clock abstraction *)
and translate_forall env params =
let p_clocks =
List.map (fun n -> Cvarpat(string_of_name env n)) params.s_clock in
let p_carriers =
List.map (fun n -> Cvarpat(string_of_name env n)) params.s_carrier in
p_clocks @ p_carriers
(* generates an application for clock instanciation *)
and translate_subst env init subst =
let rec translate_clock_list init cl_list =
match cl_list with
[] -> init, []
| cl :: cl_list ->
let init, cl = translate_clock env init cl in
let init, cl_list = translate_clock_list init cl_list in
init, cl :: cl_list in
let rec translate_carrier_list init car_list =
match car_list with
[] -> init, []
| car :: car_list ->
let init, car = translate_carrier env init car in
let init, car_list = translate_carrier_list init car_list in
init, car :: car_list in
let init, cl_list = translate_clock_list init subst.s_clock in
let init, car_list = translate_carrier_list init subst.s_carrier in
init, cl_list @ car_list
(* Initialisation code *)
and allocate_memory env init =
let allocate _ ident (acc_write, acc_mem) =
match ident.id_kind with
Kmemo ->
(* we allocate only one cell *)
let default = default_value env ident in
acc_write, (memo ident.id_name, default) :: acc_mem
| Kinit ->
(* init variables are considered to be state variables *)
acc_write, (initial ident.id_name, Cconstant(Cbool(true))) :: acc_mem
| _ when is_a_write ident ->
(* local write variables are allocated too *)
(* but they will be stored in a stack allocated structure *)
let name = string_of_name env ident.id_name in
let default = default_value env ident in
(name, default) :: acc_write, acc_mem
| _ -> acc_write, acc_mem in
Hashtbl.fold allocate (cblock env).b_env init
(* add static code into the initialisation part *)
and translate_static_code env static_code =
(* add one equation *)
(* we compute the list of introduced names and compile the equation *)
let translate_eq acc (pat, e) =
let acc = fv_pat acc pat in
let pat = translate_pat env pat in
let ce = translate_pure env e in
acc, Tlet(pat, ce) in
let rec translate_static_code acc static_code =
match static_code with
[] -> acc, []
| pat_e :: static_code ->
let acc, cpat_ce = translate_eq acc pat_e in
let acc, static_code = translate_static_code acc static_code in
acc, cpat_ce :: static_code in
(* introduced names must be added to the memory *)
let intro acc_mem n =
let v = string_of_name env n in
(* modify the kind of [n] *)
set_static (find env n);
(string_of_name env n, Cvar(v)) :: acc_mem in
(* first compile the static code *)
let acc, static_code = translate_static_code [] static_code in
(* introduced names must be added to the memory initialisation *)
let acc_mem = List.fold_left intro [] acc in
static_code, ([], acc_mem)
(* default value *)
and default_value env ident =
(* find a value from a type *)
let rec value ty =
match ty with
Dproduct(ty_l) -> Ctuple(List.map value ty_l)
| Dbase(b) ->
let v = match b with
Dtyp_bool -> Cbool(false)
| Dtyp_int -> Cint(0)
| Dtyp_float -> Cfloat(0.0)
| Dtyp_unit -> Cvoid
| Dtyp_char -> Cchar(' ')
| Dtyp_string -> Cstring("") in
Cconstant(v)
| Dsignal(ty) -> Ctuple[value ty; cfalse]
| Dtypvar _ | Darrow _ -> cdummy
| Dconstr(qualid, _) ->
try
let desc = find_type qualid in
match desc.d_type_desc with
Dabstract_type -> cdummy
| Dabbrev(ty) ->
value ty
| Dvariant_type l ->
let case = List.hd l in
begin match case with
(qual, { arg = ty_l }) ->
Cconstruct(qual, List.map value ty_l)
end
| Drecord_type l ->
let field_of_type (qual, _, ty_ty) = (qual, value ty_ty.res) in
Crecord (List.map field_of_type l)
with
Not_found -> cdummy in
let value (Dtypforall(_, ty)) = value ty in
match ident.id_value with
None -> value ident.id_typ
| Some(e) -> translate_pure env e
(** Compilation of a table of declarative code *)
let translate table =
let translate (s, e) = (s, translate_pure empty_env e) in
(* introduce the type of states *)
(* intro_state_type (); *)
(* then translate *)
(* translate the code *)
{ c_types = table.d_types;
c_code = List.map translate table.d_code;
c_vars = table.d_vars;
}

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

@ -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

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

@ -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 ()

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

@ -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

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

@ -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 []

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

@ -0,0 +1,2 @@

101
compiler/obc/obc.ml
View file

@ -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; }

15
compiler/obc/obc_mapfold.ml
View file

@ -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 = {

24
compiler/obc/obc_printer.ml
View file

@ -14,7 +14,7 @@ let print_vd ff vd =
fprintf ff "@]"
let print_obj ff o =
fprintf ff "@[<v>"; print_name ff o.o_name;
fprintf ff "@[<v>"; 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 "@[<v>@[<v 2>for %s = %a to %a {@, %a @]@,}@]"
(name x)
fprintf ff "@[<v>@[<v 2>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

103
compiler/obc/obc_utils.ml
View file

@ -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

61
compiler/obc/transformations/scalarize.ml Normal file
View file

@ -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

6
compiler/utilities/global/compiler_options.ml
View file

@ -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

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

@ -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 =

35
compiler/utilities/misc.ml
View file

@ -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

11
compiler/utilities/misc.mli
View file

@ -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

14
heptc
View file

@ -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

128
lib/java/jeptagon/Pervasives.java Normal file
View file

@ -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<V> implements Future<V> {
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;
}
}

2
lib/pervasives.epi
View file

@ -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)

4
test/bad/t11-initialization.ept
View file

@ -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

27
test/check
View file

@ -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 <options> <compilo>"
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"

14
test/good/array1.ept
View file

@ -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

5
test/good/array_fill.ept
View file

@ -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

8
test/good/bad_updown.ept
View file

@ -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

6
test/good/flatten.ept
View file

@ -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;

4
test/good/statics2.ept
View file

@ -24,9 +24,9 @@ let
o = f<<m + k2>>();
tel
fun h() returns (y,y':int)
fun h() returns (y,y2:int)
let
y = c2 + g<<c2>>() + i<<k2>>();
y' = c2 + Statics.g<<k2>>() + Statics.i<<k2>>();
y2 = c2 + Statics.g<<k2>>() + Statics.i<<k2>>();
tel

16
test/good/t1.ept
View file

@ -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)

3
test/good/t13.ept
View file

@ -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)

6
test/good/t2.ept
View file

@ -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

1
test/good/t5.ept
View file

@ -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;

4
test/good/t9.ept
View file

@ -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

4
test/good/test.ept
View file

@ -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

16
test/good/when_merge1.ept
View file

@ -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)

6
todo.txt
View file

@ -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.

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