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

backport from async.

Browse source
This commit is contained in:
Léonard Gérard 2011-03-09 00:02:30 +01:00 committed by Léonard Gérard
parent 159bab2a55
commit cab8bb706e
39 changed files with 36 additions and 323 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
compiler/global/clocks.ml
View file

@ -94,7 +94,7 @@ let rec skeleton ck = function
Format.eprintf "Internal error, an exp with invalid type@.";
assert false;
| _ -> Cprod (List.map (skeleton ck) ty_list))
| Tarray (t, _) | Tasync (_, t) -> skeleton ck t
| Tarray (t, _) -> skeleton ck t
| Tid _ | Tunit -> Ck ck
(* TODO here it implicitely says that the base clock is Cbase

15
compiler/global/global_compare.ml
View file

@ -36,8 +36,6 @@ and link_compare li1 li2 = match li1, li2 with
| Clink _, _ -> -1
let async_t_compare a1 a2 = Pervasives.compare a1 a2
let rec static_exp_compare se1 se2 =
let cr = type_compare se1.se_ty se2.se_ty in
@ -83,9 +81,6 @@ let rec static_exp_compare se1 se2 =
| Sfield _, (Svar _ | Sint _ | Sfloat _ | Sbool _ | Sconstructor _) -> -1
| Sfield _, _ -> 1
| Sasync _, (Svar _ | Sint _ | Sfloat _ | Sbool _ | Sconstructor _ | Sfield _) -> -1
| Sasync _, _ -> 1
| Stuple _, (Srecord _ | Sop _ | Sarray _ | Sarray_power _ ) -> 1
| Stuple _, _ -> -1
@ -106,20 +101,10 @@ 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
| Tasync (a1, t1), Tasync (a2, t2) ->
let cr = type_compare t1 t2 in
if cr <> 0 then cr else async_t_compare a1 a2
| Tunit, Tunit -> 0
| Tprod _, _ -> 1
| Tid _, Tprod _ -> -1
| Tid _, _ -> 1
| Tarray _, (Tprod _ | Tid _) -> -1
| Tarray _, _ -> 1
| Tasync _, Tunit -> 1
| Tasync _, _ -> -1
| Tunit, _ -> -1

4
compiler/global/global_mapfold.ml
View file

@ -49,9 +49,6 @@ and static_exp_desc funs acc sd = match sd with
(f, se), acc in
let f_se_l, acc = mapfold aux acc f_se_l in
Srecord f_se_l, acc
| Sasync se ->
let se, acc = static_exp_it funs acc se in
Sasync se, acc
and ty_it funs acc t = try funs.ty funs acc t with Fallback -> ty funs acc t
@ -63,7 +60,6 @@ and ty funs acc t = match t with
let se, acc = static_exp_it funs acc se in
Tarray (t, se), acc
| Tunit -> t, acc
| Tasync (a, t) -> let t, acc = ty_it funs acc t in Tasync (a, t), acc
(*
and ct_it funs acc c = try funs.ct funs acc c with Fallback -> ct funs acc t
and ct funs acc c = match c with

5
compiler/global/global_printer.ml
View file

@ -35,9 +35,6 @@ let print_full_qualname ff qn = _print_qualname ~full:true ff qn
let print_shortname ff {name = n} = print_name ff n
let print_async ff async = match async with
| None -> ()
| Some () -> fprintf ff "async "
let rec print_static_exp ff se = match se.se_desc with
| Sint i -> fprintf ff "%d" i
@ -62,7 +59,6 @@ let rec print_static_exp ff se = match se.se_desc with
| Srecord f_se_list ->
print_record (print_couple print_qualname
print_static_exp """ = """) ff f_se_list
| Sasync se -> fprintf ff "@[<2>async %a@]" print_static_exp se
and print_static_exp_tuple ff l =
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l
@ -75,7 +71,6 @@ and print_type ff = function
| Tarray (ty, n) ->
fprintf ff "@[<hov2>%a^%a@]" print_type ty print_static_exp n
| Tunit -> fprintf ff "unit"
| Tasync (a, t) -> fprintf ff "%a%a" print_async (Some a) print_type t
let print_field ff field =
fprintf ff "@[%a: %a@]" print_qualname field.f_name print_type field.f_type

1
compiler/global/modules.ml
View file

@ -292,7 +292,6 @@ let rec unalias_type t = match t with
| Tarray (ty, n) -> Tarray(unalias_type ty, n)
| Tprod ty_list -> Tprod (List.map unalias_type ty_list)
| Tunit -> Tunit
| Tasync (a, t) -> Tasync (a, unalias_type t)
(** Return the current module as a [module_object] *)

2
compiler/global/static.ml
View file

@ -74,8 +74,6 @@ let eval_core eval apply_op env se = match se.se_desc with
| Srecord f_se_list ->
{ se with se_desc = Srecord
(List.map (fun (f,se) -> f, eval env se) f_se_list) }
| Sasync se' ->
{ se with se_desc = Sasync (eval env se') }
(** [simplify env e] returns e simplified with the
variables values taken from [env] or from the global env with [find_const].

8
compiler/global/types.ml
View file

@ -11,7 +11,6 @@ open Names
open Misc
open Location
type async_t = unit
type static_exp = { se_desc: static_exp_desc; se_ty: ty; se_loc: location }
@ -27,13 +26,11 @@ and static_exp_desc =
| Sarray of static_exp list (** [ e1, e2, e3 ] *)
| Srecord of (field_name * static_exp) list (** { f1 = e1; f2 = e2; ... } *)
| Sop of fun_name * static_exp list (** defined ops for now in pervasives *)
| Sasync of static_exp
and ty =
| 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] *)
| Tasync of async_t * ty (** [async_annotation] * [base_type] *)
| Tunit
let invalid_type = Tprod [] (** Invalid type given to untyped expression etc. *)
@ -48,11 +45,6 @@ let unprod = function
| t -> [t]
let asyncify async ty_list = match async with
| None -> ty_list
| Some a -> List.map (fun ty -> Tasync (a,ty)) ty_list
(** DO NOT use this after the typing, since it could give invalid_type *)
let mk_static_exp ?(loc = no_location) ?(ty = invalid_type) desc =
{ se_desc = desc; se_ty = ty; se_loc = loc }

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

@ -150,7 +150,6 @@ and apply op e_list =
let t1 = typing e1 in
let t2 = ctuplelist (List.map typing e_list) in
cseq t2 t1
| Ebang -> let e = assert_1 e_list in typing e
let rec typing_pat = function
| Evarpat(x) -> cwrite(x)

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

@ -51,11 +51,8 @@ type error =
| Emerge_missing_constrs of QualSet.t
| Emerge_uniq of qualname
| Emerge_mix of qualname
| Epat_should_be_async of ty
| Eshould_be_async of ty
exception Unify
exception Should_be_async of ty
exception TypingError of error
let error kind = raise (TypingError(kind))
@ -164,16 +161,6 @@ let message loc kind =
as the last but one argument (found: %a).@."
print_location loc
print_type ty
| Epat_should_be_async ty ->
eprintf "%aThis pattern is expected to be of async vars \
but the type found is %a.@."
print_location loc
print_type ty
| Eshould_be_async ty ->
eprintf "%aThis expression is expected to be async \
but the type found is %a.@."
print_location loc
print_type ty
end;
raise Errors.Error
@ -398,7 +385,6 @@ let rec check_type const_env = function
| Tprod l ->
Tprod (List.map (check_type const_env) l)
| Tunit -> Tunit
| Tasync (a, t) -> Tasync (a, check_type const_env t)
and typing_static_exp const_env se =
try
@ -449,9 +435,6 @@ and typing_static_exp const_env se =
List.map (typing_static_field const_env fields
(Tid q)) f_se_list in
Srecord f_se_list, Tid q
| Sasync se ->
let typed_se, ty = typing_static_exp const_env se in
Sasync typed_se, Tasync ((),ty)
in
{ se with se_ty = ty; se_desc = desc }, ty
@ -650,7 +633,6 @@ and typing_app const_env h app e_list =
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 result_ty_list = List.map (subst_type_vars m) result_ty_list in
let result_ty_list = asyncify app.a_async 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
@ -754,12 +736,7 @@ and typing_app const_env h app e_list =
let n =
mk_static_int_op (mk_pervasives "+") [array_size t1; array_size t2] in
Tarray (element_type t1, n), app, [typed_e1; typed_e2]
| Ebang ->
let e = assert_1 e_list in
let typed_e, t = typing const_env h e in
(match t with
| Tasync (_, t) -> t, app, [typed_e]
| _ -> message e.e_loc (Eshould_be_async t))
and typing_iterator const_env h
@ -969,7 +946,7 @@ and typing_present_handlers const_env h acc def_names
(typed_present_handlers,
(add total (add partial acc)))
and typing_block const_env h (* TODO async deal with it ! *)
and typing_block const_env h
({ b_local = l; b_equs = eq_list; b_loc = loc } as b) =
try
let typed_l, (local_names, h0) = build const_env h l in

4
compiler/heptagon/hept_printer.ml
View file

@ -129,7 +129,6 @@ 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) =
print_async ff app.a_async;
match app.a_op with
| Eequal ->
let e1, e2 = assert_2 args in
@ -178,9 +177,6 @@ and print_app ff (app, args) =
| Earrow ->
let e1, e2 = assert_2 args in
fprintf ff "@[<2>%a ->@ %a@]" print_exp e1 print_exp e2
| Ebang ->
let e = assert_1 args in
fprintf ff "!(%a)" print_exp e
let rec print_eq ff eq =
match eq.eq_desc with

13
compiler/heptagon/heptagon.ml
View file

@ -49,7 +49,6 @@ and desc =
and app = {
a_op : op;
a_params : static_exp list;
a_async : async_t option;
a_unsafe : bool }
and op =
@ -68,7 +67,6 @@ and op =
| Eselect_slice
| Eupdate
| Econcat
| Ebang
and pat =
| Etuplepat of pat list
@ -92,8 +90,7 @@ and block = {
b_equs : eq list;
b_defnames : ty Env.t;
b_statefull : bool;
b_loc : location;
b_async : async_t option; }
b_loc : location; }
and state_handler = {
s_state : state_name;
@ -189,8 +186,8 @@ let mk_exp desc ?(ct_annot = Clocks.invalid_clock) ?(loc = no_location) ty =
{ e_desc = desc; e_ty = ty; e_ct_annot = ct_annot;
e_base_ck = Cbase; e_loc = loc; }
let mk_app ?(params=[]) ?(unsafe=false) ?(async=None) op =
{ a_op = op; a_params = params; a_async = async; a_unsafe = unsafe }
let mk_app ?(params=[]) ?(unsafe=false) op =
{ a_op = op; a_params = params; a_unsafe = unsafe }
let mk_op_app ?(params=[]) ?(unsafe=false) ?(reset=None) op args =
Eapp(mk_app ~params:params ~unsafe:unsafe op, args, reset)
@ -205,9 +202,9 @@ 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) ?(async = None) ?(locals = []) eqs =
let mk_block ?(statefull = true) ?(defnames = Env.empty) ?(locals = []) eqs =
{ b_local = locals; b_equs = eqs; b_defnames = defnames;
b_statefull = statefull; b_loc = no_location; b_async = async; }
b_statefull = statefull; b_loc = no_location; }
let dfalse =
mk_exp (Econst (mk_static_bool false)) (Tid Initial.pbool)

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

@ -14,7 +14,6 @@ let comment_depth = ref 0
let keyword_table = ((Hashtbl.create 149) : (string, token) Hashtbl.t);;
List.iter (fun (str,tok) -> Hashtbl.add keyword_table str tok) [
"async", ASYNC;
"node", NODE;
"fun", FUN;
"returns", RETURNS;
@ -146,7 +145,6 @@ rule token = parse
| ".." {DOUBLE_DOT}
| "<<" {DOUBLE_LESS}
| ">>" {DOUBLE_GREATER}
| "!" {BANG}
| (['A'-'Z']('_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9']) * as id)
{Constructor id}
| (['A'-'Z' 'a'-'z']('_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9']) * as id)

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

@ -288,8 +288,6 @@ ty_ident:
{ Tid $1 }
| ty_ident POWER simple_exp
{ Tarray ($1, $3) }
| ASYNC t=ty_ident
{ Tasync ((), t) }
;
equs:
@ -427,7 +425,6 @@ simple_exp:
_simple_exp:
| IDENT { Evar $1 }
| const { Econst $1 }
| ASYNC c=const { Econst (mk_static_exp (Sasync c) (Loc($startpos,$endpos))) }
| LBRACE field_exp_list RBRACE { Estruct $2 }
| LBRACKET array_exp_list RBRACKET { mk_call Earray $2 }
| LPAREN tuple_exp RPAREN { mk_call Etuple $2 }
@ -453,10 +450,6 @@ _exp:
/* node call*/
| n=qualname p=call_params LPAREN args=exps RPAREN
{ Eapp(mk_app (Enode n) p , args) }
| ASYNC n=qualname p=call_params LPAREN args=exps RPAREN
{ Eapp(mk_app (Enode n) ~async:(Some ()) p, args) }
| BANG e=exp
{ mk_call Ebang [e] }
| NOT exp
{ mk_op_call "not" [$2] }
| exp INFIX4 exp

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

@ -33,8 +33,6 @@ type field_name = qualname
type constructor_name = qualname
type constant_name = qualname
type async_t = unit
type static_exp = { se_desc: static_exp_desc; se_loc: location }
and static_exp_desc =
@ -49,7 +47,6 @@ and static_exp_desc =
| Sarray of static_exp list (** [ e1, e2, e3 ] *)
| Srecord of (field_name * static_exp) list (** { f1 = e1; f2 = e2; ... } *)
| Sop of fun_name * static_exp list (** defined ops for now in pervasives *)
| Sasync of static_exp
type iterator_type =
| Imap
@ -61,7 +58,6 @@ type ty =
| Tprod of ty list
| Tid of qualname
| Tarray of ty * exp
| Tasync of async_t * ty
and exp =
{ e_desc : edesc;
@ -80,7 +76,7 @@ and edesc =
| Ewhen of exp * constructor_name * var_name
| Emerge of var_name * (constructor_name * exp) list
and app = { a_op: op; a_params: exp list; a_async : async_t option }
and app = { a_op: op; a_params: exp list; }
and op =
| Eequal
@ -98,7 +94,6 @@ and op =
| Eselect_slice
| Eupdate
| Econcat
| Ebang
and pat =
| Etuplepat of pat list
@ -119,8 +114,7 @@ and eqdesc =
and block =
{ b_local : var_dec list;
b_equs : eq list;
b_loc : location;
b_async : async_t option; }
b_loc : location; }
and state_handler =
{ s_state : state_name;
@ -219,8 +213,8 @@ and interface_desc =
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 ?(async=None) params =
{ a_op = op; a_params = params; a_async = async; }
let mk_app op params =
{ a_op = op; a_params = params; }
let mk_call ?(params=[]) op exps =
Eapp (mk_app op params, exps)
@ -253,9 +247,9 @@ let mk_var_dec name ty last loc =
{ v_name = name; v_type = ty;
v_last = last; v_loc = loc }
let mk_block locals ?(async=None) eqs loc =
let mk_block locals eqs loc =
{ b_local = locals; b_equs = eqs;
b_loc = loc; b_async = async }
b_loc = loc; }
let mk_const_dec id ty e loc =
{ c_name = id; c_type = ty; c_value = e; c_loc = loc }

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

@ -104,9 +104,6 @@ and static_exp_desc funs acc sd = match sd with
(f, se), acc in
let f_se_l, acc = mapfold aux acc f_se_l in
Srecord f_se_l, acc
| Sasync se ->
let se, acc = static_exp_it funs acc se in
Sasync se, acc
and exp_it funs acc e = funs.exp funs acc e
@ -301,7 +298,6 @@ and ty funs acc t = match t with
let t, acc = ty_it funs acc t in
let e, acc = exp_it funs acc e in
Tarray (t, e), acc
| Tasync (a, t) -> let t, acc = ty_it funs acc t in Tasync (a, t), acc
and const_dec_it funs acc c = funs.const_dec funs acc c

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

@ -201,7 +201,6 @@ and translate_static_exp_desc ed =
let qualf (f, se) = (qualify_field f, t se) in
Types.Srecord (List.map qualf se_f_list)
| Sop (fn, se_list) -> Types.Sop (qualify_value fn, List.map t se_list)
| Sasync se -> Types.Sasync (t se)
let expect_static_exp e = match e.e_desc with
| Econst se -> translate_static_exp se
@ -216,7 +215,7 @@ let rec translate_type loc ty =
| Tarray (ty, e) ->
let ty = translate_type loc ty in
Types.Tarray (ty, expect_static_exp e)
| Tasync (a, ty) -> Types.Tasync (a, translate_type loc ty))
)
with
| ScopingError err -> message loc err
@ -244,10 +243,10 @@ 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; a_async = async }, 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_app ~params:params ~async:async (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) ->
@ -289,7 +288,6 @@ and translate_op = function
| Eselect_dyn -> Heptagon.Eselect_dyn
| Efun ln -> Heptagon.Efun (qualify_value ln)
| Enode ln -> Heptagon.Enode (qualify_value ln)
| Ebang -> Heptagon.Ebang
and translate_pat loc env = function
| Evarpat x -> Heptagon.Evarpat (Rename.var loc env x)
@ -328,8 +326,7 @@ and translate_block env b =
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;
Heptagon.b_async = b.b_async; }, env
Heptagon.b_loc = b.b_loc; }, env
and translate_state_handler env sh =
let b, env = translate_block env sh.s_block in

3
compiler/main/hept2mls.ml
View file

@ -210,10 +210,9 @@ let rec translate_op = function
| Heptagon.Earray -> Earray
| Heptagon.Etuple -> Etuple
| Heptagon.Earrow -> Error.message no_location Error.Eunsupported_language_construct
| Heptagon.Ebang -> Ebang
let translate_app app =
mk_app ~params:app.Heptagon.a_params ~async:app.Heptagon.a_async
mk_app ~params:app.Heptagon.a_params
~unsafe:app.Heptagon.a_unsafe (translate_op app.Heptagon.a_op)
let rec translate env

9
compiler/main/mls2obc.ml
View file

@ -101,10 +101,6 @@ let rec translate map e =
let e = translate map (assert_1 e_list) in
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)
(* Async operators *)
| Minils.Eapp ({Minils.a_op = Minils.Ebang }, e_list, _) ->
let e = translate map (assert_1 e_list) in
Ebang e
(* 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
@ -336,15 +332,12 @@ and mk_node_call map call_context app loc name_list args ty =
let obj =
{ o_ident = obj_ref_name o; o_class = f;
o_params = app.Minils.a_params;
o_async = app.Minils.a_async;
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
let s = (match app.Minils.a_async with
| None -> [Acall (name_list, o, Mstep, args)]
| Some a -> [Aasync_call (a, name_list, o, Mstep, args)]) in
let s = [Acall (name_list, o, Mstep, args)] in
[], si, [obj], s
| _ -> assert false

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

@ -95,9 +95,6 @@ and typing_op op e_list h e ck = match op with
let e1, e2 = assert_2 e_list in
let ct = skeleton ck e.e_ty
in (expect h (Ck ck) e1; expect h ct e2; ct)
| Ebang ->
let e = assert_1 e_list in
typing h e
and expect h expected_ty e =
let actual_ty = typing h e in

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

@ -18,7 +18,6 @@ open Misc
with or without static parameters *)
type target =
| Obc of (Obc.program -> unit)
| Obc_scalar of (Obc.program -> unit)
| Obc_no_params of (Obc.program -> unit)
| Minils of (Minils.program -> unit)
| Minils_no_params of (Minils.program -> unit)
@ -40,7 +39,7 @@ let write_obc_file p =
comment "Generation of Obc code"
let targets = [ (*"c", Obc_no_params Cmain.program;*)
"java", Obc_scalar Java_main.program;
"java", Obc Java_main.program;
"obc", Obc write_obc_file;
"obc_np", Obc_no_params write_obc_file;
"epo", Minils write_object_file ]
@ -70,12 +69,6 @@ let generate_target p s =
if !verbose then
List.iter (Obc_printer.print stdout) o_list;
List.iter convert_fun o_list
| Obc_scalar convert_fun ->
let o = Mls2obc.program p in
comment "Obc Scalarize";
let o_s = Scalarize.program o in
convert_fun o;
if !verbose then Obc_printer.print stdout o_s
(** Translation into dataflow and sequential languages, defaults to obc. *)

7
compiler/minils/minils.ml
View file

@ -61,7 +61,7 @@ and edesc =
| Eiterator of iterator_type * app * static_exp * exp list * var_ident option
(** map f <<n>> (exp, exp...) reset ident *)
and app = { a_op: op; a_params: static_exp list; a_async : async_t option; a_unsafe: bool }
and app = { a_op: op; a_params: static_exp list; a_unsafe: bool }
(** Unsafe applications could have side effects
and be delicate about optimizations, !be careful! *)
@ -80,7 +80,6 @@ and op =
| Eselect_dyn (** arg1.[arg3...] default arg2 *)
| Eupdate (** [ arg1 with arg3..arg_n = arg2 ] *)
| Econcat (** arg1@@arg2 *)
| Ebang (** !arg1 *)
type pat =
@ -166,8 +165,8 @@ let mk_type_dec type_desc name loc =
let mk_const_dec id ty e loc =
{ c_name = id; c_type = ty; c_value = e; c_loc = loc }
let mk_app ?(params=[]) ?(async=None) ?(unsafe=false) op =
{ a_op = op; a_params = params; a_async = async; a_unsafe = unsafe }
let mk_app ?(params=[]) ?(unsafe=false) op =
{ a_op = op; a_params = params; a_unsafe = unsafe }
(** The modname field has to be set when known, TODO LG : format_version *)
let mk_program o n t c =

2
compiler/minils/mls_compare.ml
View file

@ -90,7 +90,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 | Ebang), _ -> 1 in
| Econcat ), _ -> 1 in
if cr <> 0 then cr
else list_compare static_exp_compare app1.a_params app2.a_params

4
compiler/minils/mls_printer.ml
View file

@ -111,7 +111,6 @@ and print_exp_desc ff = function
print_every reset
and print_app ff (app, args) =
print_async ff app.a_async;
match app.a_op with
| Eequal ->
let e1, e2 = assert_2 args in
@ -157,9 +156,6 @@ and print_app ff (app, args) =
| Econcat ->
let e1, e2 = assert_2 args in
fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2
| Ebang ->
let e = assert_1 args in
fprintf ff "!(%a)" print_exp e
and print_handler ff c =
fprintf ff "@[<2>%a@]" (print_couple print_qualname print_exp "("" -> "")") c

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

@ -274,10 +274,6 @@ and translate_app kind context op e_list =
let context, e1 = translate VRef context e1 in
let context, e2 = translate VRef context e2 in
context, [e1; e2]
| Ebang ->
let e = assert_1 e_list in
let context, e = translate Exp context e in
context, [e]
| Enode _ | Efun _ | Eifthenelse _ ->
assert false (*already done in translate*)

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

@ -402,7 +402,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 | Tasync _) -> assert false (* ill-typed *) in (* TODO async *)
| Etuplepat _, (Tarray _ | Tid _ | Tunit ) -> assert false (* ill-typed *) in
let add_to_lists pat (_, head, children) (eq_list, var_list) =
(* Remember the encoding of resets given above. *)

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

@ -49,7 +49,6 @@ type cty =
| Cty_ptr of cty (** C points-to-other-type type. *)
| Cty_arr of int * cty (** A static array of the specified size. *)
| Cty_void (** Well, [void] is not really a C type. *)
| Cty_future of cty (** async result as a future<t> *)
(** A C block: declarations and statements. In source code form, it begins with
variable declarations before a list of semicolon-separated statements, the
@ -246,7 +245,6 @@ and pp_cexpr fmt ce = match ce with
fprintf fmt "(%a){@[%a@]}" pp_string s (pp_list1 pp_cexpr ",") el
| Carraylit el ->
fprintf fmt "((int []){@[%a@]})" (pp_list1 pp_cexpr ",") el (* TODO master : WRONG *)
| Cmethod_call _ -> assert false (* TODO async *)
and pp_clhs fmt lhs = match lhs with
| Cvar s -> pp_string fmt s

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

@ -25,7 +25,6 @@ type cty =
| Cty_ptr of cty (** C points-to-other-type type. *)
| Cty_arr of int * cty (** A static array of the specified size. *)
| Cty_void (** Well, [void] is not really a C type. *)
| Cty_future of cty (** async result as a future<t> *)
(** A C block: declarations and statements. In source code form, it begins with
variable declarations before a list of semicolon-separated statements, the
@ -48,7 +47,6 @@ and cexpr =
| 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, ...\]]. *)
| Cmethod_call of cexpr * string * cexpr list (** Object member function call with parameters. *)
and cconst =
| Ccint of int (** Integer constant. *)
| Ccfloat of float (** Floating-point number constant. *)

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

@ -103,7 +103,6 @@ let rec ctype_of_otype oty =
ctype_of_otype ty)
| Tprod _ -> assert false
| Tunit -> assert false
| Tasync (a,ty) -> Cty_future (ctype_of_otype ty)
let cvarlist_of_ovarlist vl =
let cvar_of_ovar vd =
@ -289,8 +288,6 @@ let rec cexpr_of_exp var_env exp =
Cstructlit (ctyn, cexps)
| Earray e_list ->
Carraylit (cexprs_of_exps var_env e_list)
| Ebang e ->
Cmethod_call (cexpr_of_exp var_env e, "get", [])
and cexprs_of_exps var_env exps =
List.map (cexpr_of_exp var_env) exps
@ -507,18 +504,6 @@ let rec cstm_of_act var_env obj_env act =
[Csexpr (Cfun_call (classn ^ "_reset", elt ))] )]
)
| Aasync_call (a, 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))] ))]
| _ -> assert false (* TODO array async *)
)
(** Step functions applications can return multiple values, so we use a
local structure to hold the results, before allocating to our
variables. *)
@ -527,8 +512,6 @@ let rec cstm_of_act var_env obj_env act =
let outvl = clhss_of_lhss var_env outvl in
generate_function_call var_env obj_env outvl objn args
| Aasync_call _ -> assert false (* TODO async *)
and cstm_of_act_list var_env obj_env b =
let l = List.map cvar_of_vd b.b_locals in

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

@ -92,7 +92,7 @@ let main_def_of_class_def cd =
| Types.Tid id when id = Initial.pint -> "%d"
| Types.Tid id when id = Initial.pbool -> "%d"
| Tid _ -> "%s"
| Tasync _ -> assert false (* TODO async *) in
in
(** Does reading type [ty] need a buffer? When it is the case,
[need_buf_for_ty] also returns the type's name. *)
@ -102,8 +102,7 @@ let main_def_of_class_def cd =
| Types.Tid id when id = Initial.pint -> None
| Types.Tid id when id = Initial.pbool -> None
| Tid { name = n } -> Some n
| Tasync _ -> assert false (* TODO async *) in
in
let cprint_string s = Csexpr (Cfun_call ("printf", [Cconst (Cstrlit s)])) in
(** Generates scanf statements. *)

1
compiler/obc/c/csubst.ml
View file

@ -41,7 +41,6 @@ and subst_exp map = function
| Caddrof lhs -> Caddrof (subst_lhs map lhs)
| Cstructlit (s, el) -> Cstructlit (s, subst_exp_list map el)
| Carraylit el -> Carraylit (subst_exp_list map el)
| Cmethod_call _ -> (*TODO async*) assert false
and subst_exp_list map =
List.map (subst_exp map)

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

@ -67,7 +67,6 @@ and block = { b_locals : var_dec list;
and act = Anewvar of var_dec * exp
| Aassgn of pattern * exp
| Amethod_call of exp * method_name * exp list
| Aasync_method_call of exp * method_name * exp list (* could be used for async logging etc *)
| Aswitch of exp * (constructor_name * block) list
| Aif of exp * block
| Aifelse of exp * block * block
@ -79,7 +78,6 @@ and exp = Eval of pattern
| Ethis
| Efun of op_name * exp list
| Emethod_call of exp * method_name * exp list
| Easync_method_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*)
@ -114,14 +112,6 @@ let default_value ty = match ty with
let java_pervasive_class c = Names.qualname_of_string ("jeptagon.Pervasives."^c)
let the_java_pervasives = Names.qualname_of_string "jeptagon.Pervasives"
let java_callable = Names.qualname_of_string "java.util.concurrent.Callable"
let import_async = [Names.qualname_of_string "java.util.concurrent.Future";
Names.qualname_of_string "java.util.concurrent.ExecutionException"]
let throws_async = [Names.qualname_of_string "InterruptedException";
Names.qualname_of_string "ExecutionException"]
let mk_var x = Eval (Pvar x)

4
compiler/obc/java/java_main.ml
View file

@ -54,9 +54,9 @@ let program p =
in
mk_block ~locals:[vd_step] acts
in
mk_methode ~static:true ~args:[vd_args] ~throws:throws_async body "main"
mk_methode ~static:true ~args:[vd_args] body "main"
in
let c = mk_classe ~imports:import_async ~fields:[field_step_dnb] ~methodes:[main_methode] class_name in
let c = mk_classe ~fields:[field_step_dnb] ~methodes:[main_methode] class_name in
output_program dir [c]
)

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

@ -72,7 +72,6 @@ and exp ff = function
| 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
| Easync_method_call _ -> Misc.internal_error "java_printer, Easync call not translated" 0
| Enew (c,e_l) -> fprintf ff "new %a%a" full_ty c args e_l
| Enew_array (t,e_l) ->
(match e_l with
@ -142,7 +141,6 @@ 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
| Aasync_method_call _ -> Misc.internal_error "java_printer, Aasync call not translated" 1
| 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 ? *)

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

@ -27,8 +27,6 @@ open Obc
open Obc_utils
open Java
let mk_classe = mk_classe ~imports:import_async
(** Additional classes created during the translation *)
let add_classe, get_classes =
@ -100,9 +98,6 @@ let rec static_exp param_env se = match se.Types.se_desc with
| 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)
| Types.Sasync se ->
let t_c = Tgeneric (java_pervasive_class "StaticFuture", [boxed_ty param_env se.Types.se_ty]) in
Enew (t_c, [static_exp param_env se])
and boxed_ty param_env t = match t with
| Types.Tprod ty_l -> tuple_ty param_env ty_l
@ -111,7 +106,6 @@ and boxed_ty param_env t = match t with
| Types.Tid t when t = Initial.pfloat -> Tclass (Names.local_qn "Float")
| Types.Tid t -> Tclass (qualname_to_class_name t)
| Types.Tarray (t,size) -> Tarray (boxed_ty param_env t, static_exp param_env size)
| Types.Tasync (_,t) -> Tgeneric (Names.pervasives_qn "Future", [boxed_ty param_env t])
| Types.Tunit -> Tunit
and tuple_ty param_env ty_l =
@ -125,7 +119,6 @@ and ty param_env t :Java.ty = match t with
| Types.Tid t when t = Initial.pfloat -> Tfloat
| Types.Tid t -> Tclass (qualname_to_class_name t)
| Types.Tarray (t,size) -> Tarray (ty param_env t, static_exp param_env size)
| Types.Tasync (_,t) -> Tgeneric (Names.pervasives_qn "Future", [boxed_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 }
@ -138,7 +131,6 @@ and exp param_env e = match e.e_desc with
| 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)
| Obc.Ebang e -> Emethod_call (exp param_env e,"get",[])
and exp_list param_env e_l = List.map (exp param_env) e_l
@ -160,17 +152,14 @@ let obj_ref param_env o = match o with
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)
| Obc.Aasync_call (_,[], obj, Mstep, e_l) ->
| 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)
| Obc.Aasync_call (_,[p], obj, Mstep, e_l) ->
| 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)
| Obc.Aasync_call (_,p_l, obj, Mstep, e_l) ->
| 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
@ -181,8 +170,7 @@ let rec act_list param_env act_l acts =
in
let copies = Misc.mapi copy_return_to_var p_l in
assgn::(copies@acts)
| Obc.Acall (_, obj, Mreset, _)
| Obc.Aasync_call (_,_, obj, Mreset, _) ->
| 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 ->
@ -244,106 +232,6 @@ let copy_to_this vd_l =
let create_async_classe async base_classe =
let classe_name = base_classe.o_class |> Names.shortname |> (fun n -> "Async_factory_"^n) |> fresh_classe in
let callable_name = base_classe.o_class |> Names.shortname |> (fun n -> "Async_"^n) in
let callable_classe_name = {qual = QualModule classe_name; name = callable_name } in
Idents.enter_node classe_name;
(* Base class signature *)
let { node_inputs = b_in;
node_outputs = b_out;
node_statefull = b_stateful;
node_params = b_params; } = Modules.find_value base_classe.o_class in
(* Fields *)
(* [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 b_params in
let f = vds_to_fields ~protection:Pprotected v in
let e = vds_to_exps v in
f, v, e, env
in
(* [instance] : field used to represent the instance of the base classe *)
let field_inst, ty_inst, id_inst, var_inst, vd_inst =
let t = Tclass (qualname_to_class_name base_classe.o_class) in
let id = base_classe.o_ident in
mk_field ~protection:Pprotected t id, t, id, mk_var id, mk_var_dec id t
in
(* [result] : field used to stock the asynchronous result *)
let field_result, ty_aresult, ty_result, id_result, var_result =
let t = b_out |> Signature.types_of_arg_list |> Types.prod in
let ty_result = boxed_ty param_env t in
let t = Types.Tasync(async, t) in
let aty = ty param_env t in
let result_id = Idents.gen_var "obc2java" "result" in
mk_field ~protection:Pprotected aty result_id, aty, ty_result, result_id, mk_var result_id
in
let fields = field_inst::field_result::fields_params in
(* [step] arguments *)
let fields_step, vds_step, exps_step =
let v = sig_args_to_vds param_env b_in in
let e = vds_to_exps v in
let f = vds_to_fields v in
f, v, e
in
(* Methods *)
let constructor, reset =
let body, body_r =
let acts_params = copy_to_this vds_params in
let act_inst = Aassgn (Pthis id_inst, Enew (ty_inst, exps_params)) in
let act_result = Aassgn (Pthis id_result, Snull) in
mk_block (act_result::act_inst::acts_params)
, mk_block [act_result; act_inst]
in
mk_methode ~args:vds_params body (shortname classe_name)
, mk_methode body_r "reset"
in
let step =
let body =
let act_syncronize =
Aif( Efun(Initial.mk_pervasives "<>", [Snull; var_result])
, mk_block [Amethod_call(var_result, "get", [])])
in
let act_result =
let exp_call =
let args = var_inst::exps_step in
let executor = Eval (Pfield (Pclass the_java_pervasives, "executor_cached")) in
Emethod_call (executor, "submit", [Enew (Tclass callable_classe_name, args)] )
in Aassgn (Pthis id_result, exp_call)
in
let act_return = Areturn var_result in
mk_block [act_syncronize; act_result; act_return]
in mk_methode ~throws:throws_async ~args:vds_step ~returns:ty_aresult body "step"
in
(* Inner class *)
let callable_class =
let fields = field_inst::fields_step in
let constructor =
let body =
let acts_init = copy_to_this (vd_inst::vds_step) in
mk_block acts_init
in mk_methode ~args:(vd_inst::vds_step) body (shortname callable_classe_name)
in
let call =
let body =
let act = Areturn (Emethod_call (Eval (Pthis id_inst), "step", exps_step)) in
mk_block [act]
in mk_methode ~throws:throws_async ~returns:ty_result body "call"
in mk_classe ~protection:Pprotected ~static:true ~fields:fields ~implements:[java_callable]
~constrs:[constructor] ~methodes:[call] callable_classe_name
in
mk_classe ~fields:fields ~constrs:[constructor]
~methodes:[step;reset] ~classes:[callable_class] classe_name
let class_def_list classes cd_l =
let class_def classes cd =
@ -370,9 +258,7 @@ let class_def_list classes cd_l =
let constructeur, obj_env =
let obj_env = (* In async we change the type of the async objects *)
let aux obj_env od =
let t = match od.o_async with
| None -> Tclass (qualname_to_class_name od.o_class)
| Some a -> let c = create_async_classe a od in add_classe c; Tclass c.c_name
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
@ -426,7 +312,7 @@ let class_def_list classes cd_l =
| 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 ~throws:throws_async ~args:(var_dec_list param_env ostep.Obc.m_inputs) ~returns:return_ty body "step"
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

3
compiler/obc/java/old_java.ml
View file

@ -49,7 +49,6 @@ let rec java_type_default_value = function
| Talias t -> java_type_default_value t
| Tenum _ -> "int", "0" (* TODO java *)
| Tstruct _ -> shortname t, "null" )
| Tasync (a,t) -> assert false (* TODO async *)
| Tarray _ -> assert false (* TODO array *)
| Tprod _ -> assert false (* TODO java *)
| Tunit -> "void", "null"
@ -217,7 +216,6 @@ let rec print_exp ff e p avs ts single =
print_exps ff exps 0 avs ts single;
fprintf ff "@])"
| Earray _ -> assert false (* TODO array *)
| Ebang _ -> assert false (* TODO async *)
and print_exps ff es p avs ts single =
match es with
@ -324,7 +322,6 @@ let rec print_act ff a objs avs ts single =
let o = obj_ref_to_string oref in
fprintf ff "%s.reset();" o
| Afor _ -> assert false (* TODO java array *)
| Aasync_call _ -> assert false (* TODO java array *)
and print_grds ff grds objs avs ts single =

3
compiler/obc/obc.ml
View file

@ -68,7 +68,6 @@ and exp_desc =
| Eop of op_name * exp list
| Estruct of type_name * (field_name * exp) list
| Earray of exp list
| Ebang of exp
type obj_ref =
| Oobj of obj_ident
@ -81,7 +80,6 @@ type method_name =
type act =
| Aassgn of pattern * exp
| Acall of pattern list * obj_ref * method_name * exp list
| Aasync_call of async_t * pattern list * obj_ref * method_name * exp list
| Acase of exp * (constructor_name * block) list
| Afor of var_dec * static_exp * static_exp * block
| Ablock of block
@ -97,7 +95,6 @@ and var_dec =
type obj_dec =
{ o_ident : obj_ident;
o_async : async_t option;
o_class : class_name;
o_params : static_exp list;
o_size : static_exp option; (** size of the array if the declaration is an array of obj *)

7
compiler/obc/obc_mapfold.ml
View file

@ -62,9 +62,6 @@ and edesc funs acc ed = match ed with
| Earray args ->
let args, acc = mapfold (exp_it funs) acc args in
Earray args, acc
| Ebang e ->
let e, acc = exp_it funs acc e in
Ebang e, acc
and lhs_it funs acc l = funs.lhs funs acc l
@ -100,10 +97,6 @@ and act funs acc a = match a with
let lhs_list, acc = mapfold (lhs_it funs) acc lhs_list in
let args, acc = mapfold (exp_it funs) acc args in
Acall(lhs_list, obj, n, args), acc
| Aasync_call(a, lhs_list, obj, n, args) ->
let lhs_list, acc = mapfold (lhs_it funs) acc lhs_list in
let args, acc = mapfold (exp_it funs) acc args in
Aasync_call(a, lhs_list, obj, n, args), acc
| Acase(x, c_b_list) ->
let aux acc (c,b) =
let b, acc = block_it funs acc b in

9
compiler/obc/obc_printer.ml
View file

@ -51,8 +51,6 @@ and print_exp ff e =
fprintf ff "@[";
print_list_r print_exp "[" ";" "]" ff e_list;
fprintf ff "@]"
| Ebang e ->
fprintf ff "!(%a)" print_exp e
and print_op ff op e_list = match e_list with
| [l; r] ->
@ -101,13 +99,6 @@ let rec print_act ff a =
print_obj_call o
print_method_name meth
print_exps es
| Aasync_call (a, var_list, o, meth, es) ->
fprintf ff "@[<2>%a%a%a.%a(%a)@]"
print_lhs_tuple var_list
print_async (Some a)
print_obj_call o
print_method_name meth
print_exps es
| Ablock b ->
fprintf ff "do@\n %a@\ndone" print_block b

1
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;
tel
node fourth() returns (res : bool)