From 315527231ca5870d77f6695b27ed9ddcbba3397c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Wed, 5 Jan 2011 15:51:55 +0100 Subject: [PATCH 01/24] Async in Heptagon Minils Obc. --- compiler/global/clocks.ml | 3 +- compiler/global/global_compare.ml | 20 +++- compiler/global/global_mapfold.ml | 1 + compiler/global/global_printer.ml | 4 + compiler/global/modules.ml | 1 + compiler/global/types.ml | 7 ++ compiler/heptagon/analysis/causality.ml | 1 + compiler/heptagon/analysis/typing.ml | 37 +++++-- compiler/heptagon/hept_printer.ml | 101 +++++++++--------- compiler/heptagon/heptagon.ml | 17 +-- compiler/heptagon/parsing/hept_lexer.mll | 2 + compiler/heptagon/parsing/hept_parser.mly | 18 +++- compiler/heptagon/parsing/hept_parsetree.ml | 17 +-- .../parsing/hept_parsetree_mapfold.ml | 1 + compiler/heptagon/parsing/hept_scoping.ml | 17 +-- compiler/main/hept2mls.ml | 6 +- compiler/main/mls2obc.ml | 32 ++++-- compiler/minils/analysis/clocking.ml | 3 + compiler/minils/minils.ml | 7 +- compiler/minils/mls_compare.ml | 2 +- compiler/minils/mls_printer.ml | 95 ++++++++-------- compiler/minils/transformations/normalize.ml | 4 + compiler/minils/transformations/tomato.ml | 2 +- compiler/obc/c/cgen.ml | 5 + compiler/obc/c/cmain.ml | 7 +- compiler/obc/obc.ml | 2 + compiler/obc/obc_mapfold.ml | 7 ++ compiler/obc/obc_printer.ml | 10 ++ 28 files changed, 278 insertions(+), 151 deletions(-) diff --git a/compiler/global/clocks.ml b/compiler/global/clocks.ml index 61702f7..dd372a5 100644 --- a/compiler/global/clocks.ml +++ b/compiler/global/clocks.ml @@ -94,7 +94,8 @@ 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, _) | Tasync (_, t) -> skeleton ck t + | Tid _ | Tunit -> Ck ck (* TODO here it implicitely says that the base clock is Cbase and that all tuple is on Cbase *) diff --git a/compiler/global/global_compare.ml b/compiler/global/global_compare.ml index 00c75df..d216388 100644 --- a/compiler/global/global_compare.ml +++ b/compiler/global/global_compare.ml @@ -35,6 +35,9 @@ and link_compare li1 li2 = match li1, li2 with | Cindex _, _ -> 1 | 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 @@ -100,7 +103,20 @@ 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 + | 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 diff --git a/compiler/global/global_mapfold.ml b/compiler/global/global_mapfold.ml index 1af3f94..c3e9cff 100644 --- a/compiler/global/global_mapfold.ml +++ b/compiler/global/global_mapfold.ml @@ -60,6 +60,7 @@ 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 diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index 814895c..118b800 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -13,6 +13,9 @@ let print_qualname ff qn = match qn with | { 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 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 @@ -49,6 +52,7 @@ and print_type ff = function | Tarray (ty, n) -> fprintf ff "@[%a^%a@]" print_type ty print_static_exp n | Tunit -> fprintf ff "()" + | 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 diff --git a/compiler/global/modules.ml b/compiler/global/modules.ml index c132353..1b2b8aa 100644 --- a/compiler/global/modules.ml +++ b/compiler/global/modules.ml @@ -287,6 +287,7 @@ 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] *) diff --git a/compiler/global/types.ml b/compiler/global/types.ml index c2832b0..dc5e453 100644 --- a/compiler/global/types.ml +++ b/compiler/global/types.ml @@ -11,6 +11,8 @@ open Names open Misc open Location +type async_t = unit + type static_exp = { se_desc: static_exp_desc; se_ty: ty; se_loc: location } and static_exp_desc = @@ -30,6 +32,7 @@ and ty = | Tprod of ty list | Tid of type_name | Tarray of ty * static_exp + | Tasync of async_t * ty | Tunit let invalid_type = Tprod [] @@ -39,6 +42,10 @@ let prod = function | [ty] -> ty | ty_list -> Tprod ty_list +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 = diff --git a/compiler/heptagon/analysis/causality.ml b/compiler/heptagon/analysis/causality.ml index 289b470..48799ee 100644 --- a/compiler/heptagon/analysis/causality.ml +++ b/compiler/heptagon/analysis/causality.ml @@ -150,6 +150,7 @@ 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) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 9115bea..9edef47 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -51,8 +51,11 @@ 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)) @@ -161,6 +164,16 @@ 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 @@ -385,6 +398,7 @@ 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 @@ -628,18 +642,15 @@ 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 + 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 + 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 }, @@ -740,6 +751,13 @@ 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 it n args_ty_list result_ty_list e_list = match it with @@ -831,6 +849,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 @@ -947,7 +966,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 +and typing_block const_env h (* TODO async deal with it ! *) ({ 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 diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index 1af1988..f845937 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -128,54 +128,59 @@ and print_tag_e_list ff tag_e_list = and print_every ff reset = print_opt (fun ff id -> fprintf ff " every %a" print_exp id) ff reset -and print_app ff (app, args) = match app.a_op with - | Eequal -> - let e1, e2 = assert_2 args in - fprintf ff "@[<2>%a@ = %a@]" print_exp e1 print_exp e2 - | Etuple -> print_exp_tuple ff args - | Efun f | Enode f -> - fprintf ff "@[%a@,%a@,%a@]" - print_qualname f print_params app.a_params print_exp_tuple args - | Eifthenelse -> - let e1, e2, e3 = assert_3 args in - fprintf ff "@[if %a@ then %a@ else %a@]" - print_exp e1 print_exp e2 print_exp e3 - | Efield -> - let r = assert_1 args in - let f = assert_1 app.a_params in - fprintf ff "%a.%a" print_exp r print_static_exp f - | Efield_update -> - let r,e = assert_2 args in - let f = assert_1 app.a_params in - fprintf ff "@[<2>{%a with .%a =@ %a}@]" - print_exp r print_static_exp f print_exp e - | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args - | Earray_fill -> - let e = assert_1 args in - let n = assert_1 app.a_params in - fprintf ff "%a^%a" print_exp e print_static_exp n - | Eselect -> - let e = assert_1 args in - fprintf ff "%a%a" print_exp e print_index app.a_params - | Eselect_slice -> - let e = assert_1 args in - let idx1, idx2 = assert_2 app.a_params in - fprintf ff "%a[%a..%a]" - print_exp e print_static_exp idx1 print_static_exp idx2 - | Eselect_dyn -> - let r, d, e = assert_2min args in - fprintf ff "%a%a default %a" - print_exp r print_dyn_index e print_exp d - | Eupdate -> - let e1, e2, idx = assert_2min args in - fprintf ff "@[<2>(%a with %a =@ %a)@]" - print_exp e1 print_dyn_index idx print_exp e2 - | Econcat -> - let e1, e2 = assert_2 args in - fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2 - | Earrow -> - let e1, e2 = assert_2 args in - fprintf ff "@[<2>%a ->@ %a@]" print_exp e1 print_exp e2 +and print_app ff (app, args) = + print_async ff app.a_async; + match app.a_op with + | Eequal -> + let e1, e2 = assert_2 args in + fprintf ff "@[<2>%a@ = %a@]" print_exp e1 print_exp e2 + | Etuple -> print_exp_tuple ff args + | Efun f | Enode f -> + fprintf ff "@[%a@,%a@,%a@]" + print_qualname f print_params app.a_params print_exp_tuple args + | Eifthenelse -> + let e1, e2, e3 = assert_3 args in + fprintf ff "@[if %a@ then %a@ else %a@]" + print_exp e1 print_exp e2 print_exp e3 + | Efield -> + let r = assert_1 args in + let f = assert_1 app.a_params in + fprintf ff "%a.%a" print_exp r print_static_exp f + | Efield_update -> + let r,e = assert_2 args in + let f = assert_1 app.a_params in + fprintf ff "@[<2>{%a with .%a =@ %a}@]" + print_exp r print_static_exp f print_exp e + | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args + | Earray_fill -> + let e = assert_1 args in + let n = assert_1 app.a_params in + fprintf ff "%a^%a" print_exp e print_static_exp n + | Eselect -> + let e = assert_1 args in + fprintf ff "%a%a" print_exp e print_index app.a_params + | Eselect_slice -> + let e = assert_1 args in + let idx1, idx2 = assert_2 app.a_params in + fprintf ff "%a[%a..%a]" + print_exp e print_static_exp idx1 print_static_exp idx2 + | Eselect_dyn -> + let r, d, e = assert_2min args in + fprintf ff "%a%a default %a" + print_exp r print_dyn_index e print_exp d + | Eupdate -> + let e1, e2, idx = assert_2min args in + fprintf ff "@[<2>(%a with %a =@ %a)@]" + print_exp e1 print_dyn_index idx print_exp e2 + | Econcat -> + let e1, e2 = assert_2 args in + fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2 + | Earrow -> + let e1, e2 = assert_2 args in + fprintf ff "@[<2>%a ->@ %a@]" print_exp e1 print_exp e2 + | Ebang -> + let e = assert_1 args in + fprintf ff "!(%a)" print_exp e let rec print_eq ff eq = match eq.eq_desc with diff --git a/compiler/heptagon/heptagon.ml b/compiler/heptagon/heptagon.ml index 8930d05..dec2663 100644 --- a/compiler/heptagon/heptagon.ml +++ b/compiler/heptagon/heptagon.ml @@ -49,6 +49,7 @@ and desc = and app = { a_op : op; a_params : static_exp list; + a_async : async_t option; a_unsafe : bool } and op = @@ -67,6 +68,7 @@ and op = | Eselect_slice | Eupdate | Econcat + | Ebang and pat = | Etuplepat of pat list @@ -75,7 +77,7 @@ and pat = type eq = { eq_desc : eqdesc; eq_statefull : bool; - eq_loc : location } + eq_loc : location; } and eqdesc = | Eautomaton of state_handler list @@ -90,7 +92,8 @@ and block = { b_equs : eq list; b_defnames : ty Env.t; b_statefull : bool; - b_loc : location } + b_loc : location; + b_async : async_t option; } and state_handler = { s_state : state_name; @@ -186,11 +189,11 @@ 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 = - { a_op = op; a_params = params; a_unsafe = unsafe } +let mk_app ?(params=[]) ?(unsafe=false) ?(async=None) op = + { a_op = op; a_params = params; a_async = async; 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; } @@ -202,9 +205,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) ?(locals = []) eqs = +let mk_block ?(statefull = true) ?(defnames = Env.empty) ?(async = None) ?(locals = []) eqs = { b_local = locals; b_equs = eqs; b_defnames = defnames; - b_statefull = statefull; b_loc = no_location } + b_statefull = statefull; b_loc = no_location; b_async = async; } let dfalse = mk_exp (Econst (mk_static_bool false)) (Tid Initial.pbool) diff --git a/compiler/heptagon/parsing/hept_lexer.mll b/compiler/heptagon/parsing/hept_lexer.mll index 9f035a9..18da7d3 100644 --- a/compiler/heptagon/parsing/hept_lexer.mll +++ b/compiler/heptagon/parsing/hept_lexer.mll @@ -14,6 +14,7 @@ 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; @@ -145,6 +146,7 @@ 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) diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index a849c22..3462aaa 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -47,6 +47,7 @@ open Hept_parsetree %token AROBASE %token DOUBLE_LESS DOUBLE_GREATER %token MAP FOLD FOLDI MAPFOLD +%token ASYNC BANG %token PREFIX %token INFIX0 %token INFIX1 @@ -77,6 +78,7 @@ open Hept_parsetree %left POWER %right PREFIX %left DOT +%left BANG %start program @@ -286,6 +288,8 @@ ty_ident: { Tid $1 } | ty_ident POWER simple_exp { Tarray ($1, $3) } + | ASYNC t=ty_ident + { Tasync ((), t) } ; equs: @@ -309,7 +313,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 +435,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 +449,13 @@ _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) } + | 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 diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index 106a044..444d1d1 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -31,6 +31,8 @@ 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 = @@ -56,6 +58,7 @@ type ty = | Tprod of ty list | Tid of qualname | Tarray of ty * exp + | Tasync of async_t * ty and exp = { e_desc : edesc; @@ -74,7 +77,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; } +and app = { a_op: op; a_params: exp list; a_async : async_t option } and op = | Eequal @@ -92,6 +95,7 @@ and op = | Eselect_slice | Eupdate | Econcat + | Ebang and pat = | Etuplepat of pat list @@ -112,7 +116,8 @@ and eqdesc = and block = { b_local : var_dec list; b_equs : eq list; - b_loc : location; } + b_loc : location; + b_async : async_t option; } and state_handler = { s_state : state_name; @@ -211,8 +216,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 params = - { a_op = op; a_params = params } +let mk_app op ?(async=None) params = + { a_op = op; a_params = params; a_async = async; } let mk_call ?(params=[]) op exps = Eapp (mk_app op params, exps) @@ -246,9 +251,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 eqs loc = +let mk_block locals ?(async=None) eqs loc = { b_local = locals; b_equs = eqs; - b_loc = loc } + b_loc = loc; b_async = async } let mk_const_dec id ty e loc = { c_name = id; c_type = ty; c_value = e; c_loc = loc } diff --git a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml index 912fefc..7a8c3d0 100644 --- a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml +++ b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml @@ -298,6 +298,7 @@ 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 diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index 9b52935..064d69a 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -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) + | Tasync (a, ty) -> Types.Tasync (a, translate_type loc ty)) with | ScopingError err -> message loc err @@ -242,16 +243,17 @@ 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; a_async = async }, 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 ~async:async (translate_op op) in Heptagon.Eapp (app, e_list, None) + | Eiterator (it, { a_op = op; a_params = params }, n, e_list) -> let e_list = List.map (translate_exp env) e_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) | Ewhen (e, c, ce) -> @@ -269,6 +271,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 @@ -285,6 +288,7 @@ 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) @@ -293,7 +297,7 @@ 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_loc = eq.eq_loc; } and translate_eq_desc loc env = function | Eswitch(e, switch_handlers) -> @@ -323,7 +327,8 @@ 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 }, env + Heptagon.b_loc = b.b_loc; + Heptagon.b_async = b.b_async; }, env and translate_state_handler env sh = let b, env = translate_block env sh.s_block in diff --git a/compiler/main/hept2mls.ml b/compiler/main/hept2mls.ml index a2c36ac..0de28cb 100644 --- a/compiler/main/hept2mls.ml +++ b/compiler/main/hept2mls.ml @@ -209,11 +209,11 @@ 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 + | Heptagon.Ebang -> Ebang let translate_app app = - mk_app ~params:app.Heptagon.a_params + mk_app ~params:app.Heptagon.a_params ~async:app.Heptagon.a_async ~unsafe:app.Heptagon.a_unsafe (translate_op app.Heptagon.a_op) let rec translate env diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index c9bd4ae..b47870c 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -74,8 +74,7 @@ let rec translate map e = | Minils.Evar n -> Elhs (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 @@ -98,9 +97,18 @@ let rec translate map e = 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 + (* 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 + |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 in mk_exp ~ty:e.Minils.e_ty desc @@ -347,12 +355,14 @@ and mk_node_call map call_context app loc name_list args = { o_name = 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 = (match app.Minils.a_async with + | None -> [Acall (name_list, o, Mstep, args)] + | Some a -> [Aasync_call (a, 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 = diff --git a/compiler/minils/analysis/clocking.ml b/compiler/minils/analysis/clocking.ml index b13cc27..06978f2 100644 --- a/compiler/minils/analysis/clocking.ml +++ b/compiler/minils/analysis/clocking.ml @@ -95,6 +95,9 @@ 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 diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index 361cfe2..4ecebcc 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -61,7 +61,7 @@ and edesc = | Eiterator of iterator_type * app * static_exp * exp list * var_ident option (** map f <> (exp, exp...) reset ident *) -and app = { a_op: op; a_params: static_exp list; a_unsafe: bool } +and app = { a_op: op; a_params: static_exp list; a_async : async_t option; a_unsafe: bool } (** Unsafe applications could have side effects and be delicate about optimizations, !be careful! *) @@ -80,6 +80,7 @@ and op = | Eselect_dyn (** arg1.[arg3...] default arg2 *) | Eupdate (** [ arg1 with arg3..arg_n = arg2 ] *) | Econcat (** arg1@@arg2 *) + | Ebang (** !arg1 *) type pat = @@ -165,8 +166,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=[]) ?(unsafe=false) op = - { a_op = op; a_params = params; a_unsafe = unsafe } +let mk_app ?(params=[]) ?(async=None) ?(unsafe=false) op = + { a_op = op; a_params = params; a_async = async; a_unsafe = unsafe } (** The modname field has to be set when known, TODO LG : format_version *) let mk_program o n t c = diff --git a/compiler/minils/mls_compare.ml b/compiler/minils/mls_compare.ml index a4fe171..9c07fde 100644 --- a/compiler/minils/mls_compare.ml +++ b/compiler/minils/mls_compare.ml @@ -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), _ -> 1 in + | Econcat | Ebang), _ -> 1 in if cr <> 0 then cr else list_compare static_exp_compare app1.a_params app2.a_params diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index 8bebfc0..0fb87f3 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -110,51 +110,56 @@ and print_exp_desc ff = function print_exp_tuple args print_every reset -and print_app ff (app, args) = match app.a_op with - | Eequal -> - let e1, e2 = assert_2 args in - fprintf ff "@[<2>%a@ = %a@]" print_exp e1 print_exp e2 - | Etuple -> print_exp_tuple ff args - | Efun f | Enode f -> - fprintf ff "@[%a@,%a@,%a@]" - print_qualname f print_params app.a_params print_exp_tuple args - | Eifthenelse -> - let e1, e2, e3 = assert_3 args in - fprintf ff "@[if %a@ then %a@ else %a@]" - print_exp e1 print_exp e2 print_exp e3 - | Efield -> - let r = assert_1 args in - let f = assert_1 app.a_params in - fprintf ff "%a.%a" print_exp r print_static_exp f - | Efield_update -> - let r,e = assert_2 args in - let f = assert_1 app.a_params in - fprintf ff "@[<2>{%a with .%a =@ %a}@]" - print_exp r print_static_exp f print_exp e - | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args - | Earray_fill -> - let e = assert_1 args in - let n = assert_1 app.a_params in - fprintf ff "%a^%a" print_exp e print_static_exp n - | Eselect -> - let e = assert_1 args in - fprintf ff "%a%a" print_exp e print_index app.a_params - | Eselect_slice -> - let e = assert_1 args in - let idx1, idx2 = assert_2 app.a_params in - fprintf ff "%a[%a..%a]" - print_exp e print_static_exp idx1 print_static_exp idx2 - | Eselect_dyn -> - let r, d, e = assert_2min args in - fprintf ff "%a%a default %a" - print_exp r print_dyn_index e print_exp d - | Eupdate -> - let e1, e2, idx = assert_2min args in - fprintf ff "@[<2>(%a with %a =@ %a)@]" - print_exp e1 print_dyn_index idx print_exp e2 - | Econcat -> - let e1, e2 = assert_2 args in - fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2 +and print_app ff (app, args) = + print_async ff app.a_async; + match app.a_op with + | Eequal -> + let e1, e2 = assert_2 args in + fprintf ff "@[<2>%a@ = %a@]" print_exp e1 print_exp e2 + | Etuple -> print_exp_tuple ff args + | Efun f | Enode f -> + fprintf ff "@[%a@,%a@,%a@]" + print_qualname f print_params app.a_params print_exp_tuple args + | Eifthenelse -> + let e1, e2, e3 = assert_3 args in + fprintf ff "@[if %a@ then %a@ else %a@]" + print_exp e1 print_exp e2 print_exp e3 + | Efield -> + let r = assert_1 args in + let f = assert_1 app.a_params in + fprintf ff "%a.%a" print_exp r print_static_exp f + | Efield_update -> + let r,e = assert_2 args in + let f = assert_1 app.a_params in + fprintf ff "@[<2>{%a with .%a =@ %a}@]" + print_exp r print_static_exp f print_exp e + | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args + | Earray_fill -> + let e = assert_1 args in + let n = assert_1 app.a_params in + fprintf ff "%a^%a" print_exp e print_static_exp n + | Eselect -> + let e = assert_1 args in + fprintf ff "%a%a" print_exp e print_index app.a_params + | Eselect_slice -> + let e = assert_1 args in + let idx1, idx2 = assert_2 app.a_params in + fprintf ff "%a[%a..%a]" + print_exp e print_static_exp idx1 print_static_exp idx2 + | Eselect_dyn -> + let r, d, e = assert_2min args in + fprintf ff "%a%a default %a" + print_exp r print_dyn_index e print_exp d + | Eupdate -> + let e1, e2, idx = assert_2min args in + fprintf ff "@[<2>(%a with %a =@ %a)@]" + print_exp e1 print_dyn_index idx print_exp e2 + | Econcat -> + let e1, e2 = assert_2 args in + fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2 + | 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 diff --git a/compiler/minils/transformations/normalize.ml b/compiler/minils/transformations/normalize.ml index a15d639..6fd38f4 100644 --- a/compiler/minils/transformations/normalize.ml +++ b/compiler/minils/transformations/normalize.ml @@ -274,6 +274,10 @@ 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*) diff --git a/compiler/minils/transformations/tomato.ml b/compiler/minils/transformations/tomato.ml index dce1cfd..9352d46 100644 --- a/compiler/minils/transformations/tomato.ml +++ b/compiler/minils/transformations/tomato.ml @@ -398,7 +398,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 | Tasync _) -> assert false (* ill-typed *) in (* TODO async *) let add_to_lists pat (_, head, children) (eq_list, var_list) = (* Remember the encoding of resets given above. *) diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 4f6728a..20ede8c 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -103,6 +103,7 @@ let rec ctype_of_otype oty = ctype_of_otype ty) | Tprod _ -> assert false | Tunit -> assert false + | Tasync _ -> assert false (* TODO async *) let cvarlist_of_ovarlist vl = let cvar_of_ovar vd = @@ -288,6 +289,8 @@ let rec cexpr_of_exp var_env exp = Cstructlit (ctyn, cexps) | Earray e_list -> Carraylit (cexprs_of_exps var_env e_list) + | Ebang _ -> + (* TODO async *) assert false and cexprs_of_exps var_env exps = List.map (cexpr_of_exp var_env) exps @@ -491,6 +494,8 @@ let rec cstm_of_act var_env obj_env act = [Csexpr (Cfun_call (classn ^ "_reset", elt ))] )] ) + | Aasync_call _ -> assert false (* TODO async *) + (** Special case for x = 0^n^n...*) | Aassgn (vn, { e_desc = Econst c }) -> let vn = clhs_of_lhs var_env vn in diff --git a/compiler/obc/c/cmain.ml b/compiler/obc/c/cmain.ml index d295da5..c5bf85e 100644 --- a/compiler/obc/c/cmain.ml +++ b/compiler/obc/c/cmain.ml @@ -85,14 +85,14 @@ 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 | 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" + | Tasync _ -> assert false (* TODO async *) in (** Does reading type [ty] need a buffer? When it is the case, [need_buf_for_ty] also returns the type's name. *) @@ -101,7 +101,8 @@ let main_def_of_class_def cd = | 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 + | Tasync _ -> assert false (* TODO async *) in let cprint_string s = Csexpr (Cfun_call ("printf", [Cconst (Cstrlit s)])) in diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index 9dd83de..7b7107a 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -53,6 +53,7 @@ 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_name @@ -65,6 +66,7 @@ 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_ident * static_exp * static_exp * block diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml index 32cdde3..a0c8dd6 100644 --- a/compiler/obc/obc_mapfold.ml +++ b/compiler/obc/obc_mapfold.ml @@ -62,6 +62,9 @@ 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 @@ -97,6 +100,10 @@ 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 diff --git a/compiler/obc/obc_printer.ml b/compiler/obc/obc_printer.ml index 8738572..4d7c8e5 100644 --- a/compiler/obc/obc_printer.ml +++ b/compiler/obc/obc_printer.ml @@ -51,6 +51,8 @@ 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] -> @@ -75,6 +77,7 @@ 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 | [] -> () @@ -98,6 +101,13 @@ 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 and print_var_dec_list ff var_dec_list = match var_dec_list with | [] -> () From e9e8ca382a47910c3f85461a62d1fa2582e9b8ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Tue, 11 Jan 2011 14:25:50 +0100 Subject: [PATCH 02/24] ml files imported from lucy v3 --- compiler/obc/ml/caml.ml | 98 +++ compiler/obc/ml/caml_aux.ml | 131 ++++ compiler/obc/ml/caml_printer.ml | 404 ++++++++++++ compiler/obc/ml/cenvironment.ml | 46 ++ compiler/obc/ml/coiteration.ml | 848 +++++++++++++++++++++++++ compiler/obc/ml/declarative.ml | 295 +++++++++ compiler/obc/ml/declarative_printer.ml | 699 ++++++++++++++++++++ compiler/obc/ml/default_value.ml | 63 ++ compiler/obc/ml/misc.ml | 295 +++++++++ compiler/obc/ml/ml.ml | 2 + 10 files changed, 2881 insertions(+) create mode 100644 compiler/obc/ml/caml.ml create mode 100644 compiler/obc/ml/caml_aux.ml create mode 100644 compiler/obc/ml/caml_printer.ml create mode 100644 compiler/obc/ml/cenvironment.ml create mode 100644 compiler/obc/ml/coiteration.ml create mode 100644 compiler/obc/ml/declarative.ml create mode 100644 compiler/obc/ml/declarative_printer.ml create mode 100644 compiler/obc/ml/default_value.ml create mode 100644 compiler/obc/ml/misc.ml create mode 100644 compiler/obc/ml/ml.ml diff --git a/compiler/obc/ml/caml.ml b/compiler/obc/ml/caml.ml new file mode 100644 index 0000000..99b7420 --- /dev/null +++ b/compiler/obc/ml/caml.ml @@ -0,0 +1,98 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + + +(** Sequential caml code. *) + +open Misc +open Names +open Idents +open Location + +type caml_code = + { c_types: (string, type_definition) Hashtbl.t; + c_defs: (string * cexp) list; + } + +and immediate = + Cbool of bool + | Cint of int + | Cfloat of float + | Cchar of char + | Cstring of string + | Cvoid + +and cexp = + Cconstant of immediate + | Cglobal of qualified_ident + | Cvar of string + | Cconstruct of qualified_ident * cexp list + | Capply of cexp * cexp list + | Cfun of pattern list * cexp + | Cletin of is_rec * (pattern * cexp) list * cexp + | Cifthenelse of cexp * cexp * cexp + | Cifthen of cexp * cexp + | Cmatch of cexp * (pattern * cexp) list + | Ctuple of cexp list + | Crecord of (qualified_ident * cexp) list + | Crecord_access of cexp * qualified_ident + | Cseq of cexp list + | Cderef of cexp + | Cref of cexp + | Cset of string * cexp + | Clabelset of string * string * cexp + | Cmagic of cexp + +and is_rec = bool + +and pattern = + Cconstantpat of immediate + | Cvarpat of string + | Cconstructpat of qualified_ident * pattern list + | Ctuplepat of pattern list + | Crecordpat of (qualified_ident * pattern) list + | Corpat of pattern * pattern + | Caliaspat of pattern * string + | Cwildpat + +let cvoidpat = Cconstantpat(Cvoid) +let cvoid = Cconstant(Cvoid) +let crefvoid = Cref(cvoid) +let cfalse = Cconstant(Cbool(false)) +let ctrue = Cconstant(Cbool(true)) +let creftrue = Cref(ctrue) +let cdummy = Cmagic (Cconstant (Cvoid)) +let cand_op = {qual = pervasives_module;id = "&&"} +let cor_op = {qual = pervasives_module;id = "or"} +let cnot_op = {qual = pervasives_module;id = "not"} +let cand c1 c2 = Capply (Cglobal (cand_op), [c1;c2]) +let cor c1 c2 = Capply (Cglobal (cor_op), [c1;c2]) +let cnot c = Capply(Cglobal (cnot_op),[c]) +let cvoidfun e = Cfun([cvoidpat], e) +let cvoidapply e = Capply(e, [cvoid]) +let cfun params e = + match params, e with + | params, Cfun(others, e) -> Cfun(params @ others, e) + | [], _ -> cvoidfun e + | _ -> Cfun(params, e) +let capply e l = match l with [] -> cvoidapply e | _ -> Capply(e, l) +let cifthen c e = match c with Cconstant(Cbool(true)) -> e | _ -> Cifthen(c, e) +let cifthenelse c e1 e2 = + match c with + | Cconstant(Cbool(true)) -> e1 + | Cconstant(Cbool(false)) -> e2 + | _ -> Cifthenelse(c, e1, e2) +let cseq e1 e2 = + match e1, e2 with + | Cconstant(Cvoid), _ -> e2 + | _, Cconstant(Cvoid) -> e1 + | e1, Cseq l2 -> Cseq(e1 :: l2) + | Cseq(l1), e2 -> Cseq (l1 @ [e2]) + | _ -> Cseq[e1;e2] + diff --git a/compiler/obc/ml/caml_aux.ml b/compiler/obc/ml/caml_aux.ml new file mode 100644 index 0000000..48da556 --- /dev/null +++ b/compiler/obc/ml/caml_aux.ml @@ -0,0 +1,131 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: caml_aux.ml,v 1.1.1.1 2005-11-03 15:45:23 pouzet Exp $ *) + +(* file caml-aux.ml *) +(* auxiliary functions for caml expressions *) +(* free variables *) + +open Misc;; +open Caml;; +open Declarative;; + +(* convertions from declarative structures to caml ones *) +(* immediates *) +let caml_of_declarative_immediate = function + | Dbool b -> if b then Ftrue else Ffalse + | Dint i -> Fint i + | Dfloat f -> Ffloat f + | Dchar c -> Fchar c + | Dstring s -> Fstring s + +(* globals *) +let string_of_global g = + let pref = g.dqualid.dqual in + (if (pref <> "") && (pref <> "Lucy_pervasives") then + g.dqualid.dqual^"." + else "") ^ g.dqualid.did + +(* pat_desc *) +let rec caml_pattern_of_pat_desc = function + | Dvarpat i -> Fvarpat ("x__"^(string_of_int i)) + | Dconstantpat i -> Fimpat (caml_of_declarative_immediate i) + | Dtuplepat pl -> Ftuplepat (List.map caml_of_declarative_pattern pl) + | Dconstruct0pat g -> Fconstruct0pat (string_of_global g) + | Dconstruct1pat (g,p) -> Fconstruct1pat (string_of_global g, + caml_of_declarative_pattern p) + | Drecordpat gpl -> Frecordpat (List.map + (fun (x,y) -> + (string_of_global x, + caml_of_declarative_pattern y)) + gpl) +(* patterns *) +and caml_of_declarative_pattern p = caml_pattern_of_pat_desc p.dp_desc +(* ---- end of convertions *) + +let rec flat_exp_of_pattern = function + | Fpunit -> Fim Funit + | Fimpat i -> Fim i + | Fvarpat v -> Fvar { cvar_name=v; cvar_imported=false } + | Fconstruct0pat c -> Fconstruct0 c + | Fconstruct1pat (c,p) -> Fconstruct1 (c, flat_exp_of_pattern p) + | Ftuplepat pl -> Ftuple (List.map flat_exp_of_pattern pl) + | Frecordpat cpl -> + Frecord (List.map (fun (x,y) -> (x,flat_exp_of_pattern y)) cpl) + +(* small functions manipulating lists *) +let union x1 x2 = + let rec rec_union l = function + [] -> l + | h::t -> if List.mem h l then (rec_union l t) else (rec_union (h::l) t) + in + rec_union x1 x2 + +let subtract x1 x2 = + let rec sub l = function + [] -> l + | h::t -> if List.mem h x2 then (sub l t) else (sub (h::l) t) + in + sub [] x1 + +let flat l = + let rec f ac = function + [] -> ac + | t::q -> f (ac@t) q + in + f [] l + +let intersect x1 x2 = + let rec inter l = function + [] -> l + | h::t -> if List.mem h x1 then (inter (h::l) t) else (inter l t) + in + inter [] x2 + +(* make a variable *) +let make_var n = Fvar {cvar_name = n;cvar_imported = false} +and make_imported_var n b = Fvar {cvar_name = n;cvar_imported = b} + +let nil_ident = "Lucy__nil" +let state_ident = "Lucy__state" + +(* makes a conditional *) +let ifthenelse(c,e1,e2) = + match c with + Fim(Ftrue) -> e1 + | Fim(Ffalse) -> e2 + | _ -> Fifthenelse(c,e1,e2) + +(* makes a list of conditionnals *) +let ifseq l = + let rec ifs l = + let (c,e)::t = l in + if t = [] then + e + else + ifthenelse (c, e, ifs t) + in + ifs l + + + + + + + + + + + + + + + + diff --git a/compiler/obc/ml/caml_printer.ml b/compiler/obc/ml/caml_printer.ml new file mode 100644 index 0000000..536a407 --- /dev/null +++ b/compiler/obc/ml/caml_printer.ml @@ -0,0 +1,404 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: caml_printer.ml,v 1.20 2008-06-17 13:21:12 pouzet Exp $ *) + +(** Printing [Caml] code *) + +open Misc +open Names +open Format +open Declarative +open Declarative_printer +open Caml + +(** Generic printing of a list. + This function seems to appear in several places... *) +let print_list print print_sep l = + let rec printrec l = + match l with + [] -> () + | [x] -> + print x + | x::l -> + open_box 0; + print x; + print_sep (); + print_space (); + printrec l; + close_box () in + printrec l + +(** Prints an immediate. A patch is needed on float number for + [ocaml] < 3.05. *) +let print_immediate i = + match i with + Cbool(b) -> print_string (if b then "true" else "false") + | Cint(i) -> print_int i + | Cfloat(f) -> print_float f + | Cchar(c) -> print_char '\''; print_char c; print_char '\'' + | Cstring(s) -> print_string "\""; + print_string (String.escaped s); + print_string "\"" + | Cvoid -> print_string "()" + +(** Prints a name. Infix chars are surrounded by parenthesis *) +let is_infix = + let module StrSet = Set.Make(String) in + let set_infix = + List.fold_right + StrSet.add + ["or"; "quo"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] + StrSet.empty in + fun s -> StrSet.mem s set_infix + +let print_name s = + let c = String.get s 0 in + let s = if is_infix s then "(" ^ s ^ ")" + else match c with + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> s + | '*' -> "( " ^ s ^ " )" + | _ -> if s = "()" then s else "(" ^ s ^ ")" in + print_string s + +(** Prints a global name *) +let print_qualified_ident {qual=q;id=n} = + (* special case for values imported from the standard library *) + if (q = pervasives_module) or (q = Modules.compiled_module_name ()) + or (q = "") + then print_name n + else + begin + print_string q; + print_string "."; + print_name n + end + +let priority exp = + match exp with + Crecord _ | Crecord_access _ | Cvar _ | Ctuple _ + | Cglobal _ | Cconstant _ | Cconstruct(_, []) | Cderef _ -> 3 + | Clet _ | Cfun _ | Cseq _ -> 1 + | Cset _ | Clabelset _ + | Cref _ | Capply _ | Cmagic _ | Cconstruct _ -> 2 + | Cifthen _ | Cifthenelse _ | Cmatch _ -> 0 + +let priority_pattern p = + match p with + Cconstructpat _ | Cconstantpat _ | Cvarpat _ + | Ctuplepat _ | Crecordpat _ -> 2 + | _ -> 1 + +(** Emission of code *) +let rec print pri e = + open_box 2; + (* if the priority of the context is higher than the *) + (* priority of e, we ass a parenthesis *) + let pri_e = priority e in + if pri > pri_e then print_string "("; + begin match e with + Cconstant(e) -> print_immediate e + | Cglobal(gl) -> print_qualified_ident gl + | Cvar(s) -> print_name s + | Cconstruct(gl, e_list) -> + print_qualified_ident gl; + if e_list <> [] then print_tuple e_list + | Capply(f,l) -> + print pri_e f; + print_space (); + print_list (print (pri_e + 1)) (fun () -> ()) l + | Cfun(pat_list,e) -> + print_string "fun"; + print_space (); + print_list (print_pattern 0) (fun () -> ()) pat_list; + print_space (); + print_string "->"; + print_space (); + print 0 e + (* local definition *) + | Clet(is_rec, l, e) -> print_let is_rec l e + | Cifthenelse(e1,e2,e3) -> + print_string "if"; + print_space (); + print (pri_e - 1) e1; + print_space (); + print_string "then"; + print_space (); + print 2 e2; + print_space (); + print_string "else"; + print_space (); + print 2 e3 + | Cifthen(e1,e2) -> + print_string "if"; + print_space (); + print (pri_e - 1) e1; + print_space (); + print_string "then"; + print_space (); + print 2 e2 + | Ctuple(l) -> print_tuple l + | Crecord(l) -> + print_string "{"; + print_list + (fun (gl, e) -> print_qualified_ident gl; + print_string " = "; + print 1 e) + (fun () -> print_string ";") l; + print_string "}" + | Crecord_access(e, gl) -> + print pri_e e; + print_string "."; + print_qualified_ident gl + | Cmatch(e,l) -> + print_string "match "; + print 0 e; + print_string " with"; + print_space (); + List.iter + (fun pat_expr -> + print_string "| "; + print_match_pat_expr 2 pat_expr) l + | Cseq l -> print_list (print 2) (fun () -> print_string ";") l + | Cderef(e) -> + print_string "!"; + print pri_e e + | Cref(e) -> + print_string "ref"; + print_space (); + print (pri_e + 1) e + | Cset(s, e) -> + print_string s; + print_string " :="; + print_space (); + print pri_e e + | Clabelset(s, l, e) -> + print_string s; + print_string "."; + print_string l; + print_space (); + print_string "<-"; + print_space (); + print pri_e e + | Cmagic(e) -> + print_string "Obj.magic"; + print_space (); + print (pri_e+1) e + end; + if pri > pri_e then print_string ")"; + close_box() + +and print_tuple e_list = + print_string "("; + print_list (print 2) (fun () -> print_string ",") e_list; + print_string ")" + +and print_let_pat_expr (pat, expr) = + match pat, expr with + pat, Cfun(pat_list, expr) -> + open_box 2; + print_list (print_pattern 0) (fun () -> ()) (pat :: pat_list); + print_string " ="; + print_space (); + print 0 expr; + close_box () + | _ -> + print_pattern 0 pat; + print_string " = "; + print 0 expr + +and print_let is_rec l e = + open_box 0; + if is_rec then print_string "let rec " else print_string "let "; + print_list print_let_pat_expr + (fun () -> print_string "\n"; print_string "and ") l; + print_string " in"; + print_break 1 0; + print 0 e; + close_box () + +and print_pattern pri pat = + open_box 2; + let pri_e = priority_pattern pat in + if pri > pri_e then print_string "("; + begin match pat with + Cconstantpat(i) -> print_immediate i + | Cvarpat(v) -> print_string v + | Cconstructpat(gl, pat_list) -> + print_qualified_ident gl; + if pat_list <> [] then print_tuple_pat pat_list + | Ctuplepat(pat_list) -> + print_tuple_pat pat_list + | Crecordpat(l) -> + print_string "{"; + print_list (fun (gl, pat) -> print_qualified_ident gl; + print_string "="; + print_pattern (pri_e - 1) pat) + (fun () -> print_string ";") l; + print_string "}" + | Corpat(pat1, pat2) -> + print_pattern pri_e pat1; + print_string "|"; + print_pattern pri_e pat2 + | Caliaspat(pat, s) -> + print_pattern pri_e pat; + print_space (); + print_string "as"; + print_space (); + print_string s + | Cwildpat -> print_string "_" + end; + if pri > pri_e then print_string ")"; + close_box () + +and print_tuple_pat pat_list = + print_string "("; + print_list (print_pattern 0) (fun () -> print_string ",") pat_list; + print_string ")" + +and print_match_pat_expr prio (pat, expr) = + open_box 2; + print_pattern 0 pat; + print_space (); print_string "->"; print_space (); + print prio expr; + close_box (); + print_space ();; + +(* print a definition *) +let print_definition (name, e) = + print_string "let "; + print_let_pat_expr (Cvarpat(name), e) + +(* print code *) +let print_code e = print 0 e + +(* print types *) +let rec print_type typ = + open_box 1; + begin match typ with + Darrow(is_node, typ1, typ2) -> + print_type typ1; + if is_node then print_string " => " else print_string " -> "; + print_type typ2 + | Dproduct(ty_list) -> + print_list print_type (fun _ -> print_string " *") ty_list + | Dconstr(qual_ident, ty_list) -> + if ty_list <> [] then + begin + print_string "("; + print_list print_type (fun _ -> print_string ",") ty_list; + print_string ")"; + print_space () + end; + print_qualified_ident qual_ident + | Dtypvar(i) -> print_type_name i + | Dbase(b) -> print_base_type b + | Dsignal(ty) -> print_type ty; print_space (); print_string "sig" + end; + close_box () + +and print_type_name n = + print_string "'a"; + print_int n + +and print_base_type b = + match b with + Dtyp_bool -> print_string "bool" + | Dtyp_int -> print_string "int" + | Dtyp_float -> print_string "float" + | Dtyp_unit -> print_string "unit" + | Dtyp_string -> print_string "string" + | Dtyp_char -> print_string "char" + +(* print variant *) +let print_variant (qualid, { arg = typ_list; res = typ }) = + print_string " | "; + print_qualified_ident qualid; + match typ_list with + [] -> (* arity = 0 *) + () + | _ -> print_string " of "; + print_list print_type (fun () -> print_string "*") typ_list + +let print_record (qualid, is_mutable, { res = typ1 }) = + if is_mutable then print_string "mutable "; + print_qualified_ident qualid; + print_string ":"; + print_type typ1; + print_string ";" + +let print_type_declaration s { d_type_desc = td; d_type_arity = l } = + open_box 2; + if l <> [] then + begin + print_string "("; + print_list print_type_name (fun _ -> print_string ",") l; + print_string ")"; + print_space () + end; + print_string s; + print_string " = "; + begin match td with + Dabstract_type -> () + | Dabbrev(ty) -> + print_type ty + | Dvariant_type variant_list -> + List.iter print_variant variant_list + | Drecord_type record_list -> + print_string "{"; + print_list print_record (fun _ -> ()) record_list; + print_string "}" + end; + print_newline (); + close_box () + +let print_type_declarations l = + let rec printrec l = + match l with + [] -> () + | [s, d] -> print_type_declaration s d + | (s, d) :: l -> + print_type_declaration s d; + print_string "and "; + printrec l in + open_box 0; + print_string "type "; + printrec l; + print_newline (); + close_box ();; + +(* the main function *) +set_max_boxes max_int ;; + +let output_expr oc e = + (* emit on channel oc *) + set_formatter_out_channel oc; + print 0 e; + print_flush () + +let output_code oc c = + (* emit on channel oc *) + set_formatter_out_channel oc; + print_code c + +let output_definitions oc d_list = + (* emit on channel oc *) + set_formatter_out_channel oc; + print_list print_definition print_newline d_list; + print_flush () + +let output oc caml_code = + set_formatter_out_channel oc; + (* print type declarations *) + let l = Misc.listoftable caml_code.c_types in + if l <> [] then print_type_declarations l; + (* print value definitions *) + print_list print_definition print_newline caml_code.c_code; + print_flush () + diff --git a/compiler/obc/ml/cenvironment.ml b/compiler/obc/ml/cenvironment.ml new file mode 100644 index 0000000..d410adb --- /dev/null +++ b/compiler/obc/ml/cenvironment.ml @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: cenvironment.ml,v 1.1 2006-03-18 08:04:25 pouzet Exp $ *) + +open Misc +open Declarative + +(** Environment with static link **) +type cblock = + { c_block: block; (* table of free names *) + c_state: name; (* the name of the internal state *) + c_write: name; (* temporary values *) + } +type env = cblock list +let empty_env = [] +let current env = List.hd env +let cblock env = (current env).c_block +let statename env = (current env).c_state + +let push_block block env = + { c_block = block; + c_state = symbol#name; + c_write = symbol#name } :: env +let push block env = + if env = empty_env + then push_block block env + else let cblock = current env in + { cblock with c_block = block } :: env +let rec findall env i = + match env with + [] -> raise Not_found + | { c_block = b; c_state = st; c_write = wt } :: env -> + try + Hashtbl.find b.b_env i, st, wt + with + Not_found -> findall env i +let find env i = + let id, _, _ = findall env i in + id diff --git a/compiler/obc/ml/coiteration.ml b/compiler/obc/ml/coiteration.ml new file mode 100644 index 0000000..712d1cb --- /dev/null +++ b/compiler/obc/ml/coiteration.ml @@ -0,0 +1,848 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: coiteration.ml,v 1.27 2008-06-10 06:54:36 delaval Exp $ *) + + +(** Translating [declarative] code into sequential [caml] code. *) + +open Misc +open Names +open Declarative +open Rw +open Dmisc +open Caml +open Cenvironment + +let prefix_for_names = "_" +let prefix_for_inits = "_init" +let prefix_for_memos = "_pre" +let prefix_for_statics = "_static" +let prefix_for_clocks = "_cl" +let prefix_for_lasts = "__last" + +let prefix_state_type = "_state_" +let prefix_state_constr = "`St_" +let prefix_state_label = "_mem_" +let prefix_state_constr_nil = "`Snil_" +let prefix_for_self_state = "_self_" +let prefix_for_temp = "_temp_" + +(** the type of unknown states *) +(* type 'a state = Snil | St of 'a *) +let state_nil = Cconstruct(qualid prefix_state_constr_nil, []) +let state_nil_pat = Cconstructpat(qualid prefix_state_constr_nil, []) +let state_pat pat_list = Cconstructpat(qualid prefix_state_constr, pat_list) +let state e_list = Cconstruct(qualid prefix_state_constr, e_list) +let state_record name_e_list = + Crecord(List.map (fun (name, e) -> (qualid name), e) name_e_list) + +let intro_state_type () = + let tname = prefix_state_type in + let result_type = + Dconstr(qualid prefix_state_type, [Dtypvar(0)]) in + let variants = + [(qualid prefix_state_constr_nil, { arg = []; res = result_type }); + (qualid prefix_state_constr, {arg = [Dtypvar(0)]; res = result_type})] + in + let type_def = + { d_type_desc = Dvariant_type(variants); + d_type_arity = [0] } in + add_type (tname, type_def) + +(** introduce a new type for enumerated states *) +(* type ('a1,...,'an) state_k = St1 of 'a1 | ... Stm of 'an *) +let intro_enum_type n = + let l = Misc.from n in + (* name of the result type *) + let tname = prefix_state_type ^ (string_of_int(symbol#name)) in + let result_type = + Dconstr(qualid tname, List.map (fun name -> Dtypvar(name)) l) in + let variants = + List.map + (fun name -> + (qualid (tname ^ prefix_state_constr ^ (string_of_int name)), + { arg = [Dtypvar(name)]; res = result_type })) l in + let type_def = + { d_type_desc = Dvariant_type(variants); + d_type_arity = l } in + add_type (tname, type_def); + tname ^ prefix_state_constr + +(** introduce a new type for record states *) +(* type ('a1,...,'an) state_k = {mutable name1:a1;...;mutable namen:an} *) +let intro_record_type name_value_list = + let l = Misc.from (List.length name_value_list) in + let tname = prefix_state_type ^ (string_of_int(symbol#name)) in + let result_type = + Dconstr(qualid tname, List.map (fun name -> Dtypvar(name)) l) in + let labels = + List.map2 + (fun (name,_) ai -> + (qualid name, + true, + { res = Dtypvar(ai); arg = result_type })) name_value_list l in + let type_def = + { d_type_desc = Drecord_type(labels); + d_type_arity = l } in + add_type (tname, type_def) + +(** the intermediate code generated during the compilation process *) +type tcode = + Tlet of pattern * cexp + | Tset of string * cexp + | Tlabelset of string * string * cexp + | Tletrec of (pattern * cexp) list + | Texp of cexp + +(* and its translation into caml code *) +let rec clet tcode ce = + let code2c tcode ce = + match tcode with + Tlet(p, c) -> Clet(false, [p,c], ce) + | Tset(s, e) -> cseq (Cset(s,e)) ce + | Tlabelset(s, n, e) -> cseq (Clabelset(s, n, e)) ce + | Tletrec(l) -> Clet(true, l, ce) + | Texp(c) when ce = cvoid -> c + | Texp(c) -> cseq c ce in + match tcode with + [] -> ce + | tc :: tcode -> code2c tc (clet tcode ce) + +let cseq tcode = clet tcode cvoid +let ifthen c ce = + match c with + Cconstant(Cbool(true)) -> ce + | _ -> Cifthen(c, ce) + +let merge code ce l = + (* we make special treatments for conditionals *) + match l with + [] -> code + | [Cconstantpat(Cbool(b1)), c1; + Cconstantpat(Cbool(b2)), c2] -> + if b1 then + Texp(Cifthenelse(ce, c1, c2)) :: code + else + Texp(Cifthenelse(ce, c2, c1)) :: code + (* general case *) + | _ -> Texp(Cmatch(ce, l)) :: code + + +(** extract the set of static computations from an expression *) +let rec static acc e = + let acc, desc = match e.d_desc with + | Dconstant _ | Dvar _ | Dfun _ -> acc, e.d_desc + | Dtuple l -> + let acc, l = static_list acc l in + acc, Dtuple(l) + | Dprim(g, e_list) -> + (* pointwise application *) + let acc, e_list = static_list acc e_list in + acc, Dprim(g, e_list) + | Dconstruct(g, e_list) -> + let acc, e_list = static_list acc e_list in + acc, Dconstruct(g, e_list) + | Drecord(gl_expr_list) -> + let static_record (gl, expr) (acc, gl_expr_list) = + let acc, e = static acc expr in + acc, (gl, e) :: gl_expr_list in + let acc, l = + List.fold_right static_record gl_expr_list (acc, []) in + acc, Drecord(l) + | Drecord_access(expr, gl) -> + let acc, e = static acc expr in + acc, Drecord_access(e, gl) + | Difthenelse(e0, e1, e2) -> + let acc, e0 = static acc e0 in + let acc, e1 = static acc e1 in + let acc, e2 = static acc e2 in + acc, Difthenelse(e0, e1, e2) + | Dlet(block, e_let) -> + let acc, block = static_block acc block in + let acc, e = static acc e_let in + acc, Dlet(block, e_let) + | Dapply(is_state, f, l) -> + let acc, f = static acc f in + let acc, l = static_list acc l in + acc, Dapply(is_state, f, l) + | Deseq(e1, e2) -> + let acc, e1 = static acc e1 in + let acc, e2 = static acc e2 in + acc, Deseq(e1, e2) + | Dwhen(e1) -> + let acc, e1 = static acc e1 in + acc, Dwhen(e1) + | Dclock(ck) -> + acc, Dclock(ck) + | Dlast _ | Dinit _ | Dpre _ | Dtest _ -> + (* this case should not arrive *) + fatal_error "static" in + acc, { e with d_desc = desc } + +and static_list acc l = + match l with + [] -> acc, [] + | e :: l -> + let acc, e = static acc e in + let acc, l = static_list acc l in + acc, e :: l + +and static_block acc b = + let acc, eq = static_eq acc b.b_equations in + acc, { b with b_equations = eq } + +(* extract the set of static computations from an equation *) +and static_eqs acc eq_list = + match eq_list with + [] -> acc, [] + | eq :: eq_list -> + let acc, eq = static_eq acc eq in + let acc, eq_list = static_eqs acc eq_list in + acc, dcons eq eq_list + +and static_eq acc eq = + match eq with + Dget _ -> acc, eq + | Dequation(pat, e) -> + let acc, e = static acc e in + acc, Dequation(pat, e) + | Dwheneq(eq, ck) -> + let acc, eq = static_eq acc eq in + acc, Dwheneq(eq, ck) + | Dmerge(is_static, e, p_block_list) -> + let acc, e = static acc e in + let acc, p_block_list = static_pat_block_list acc p_block_list in + acc, Dmerge(is_static, e, p_block_list) + | Dnext(n, e) -> + let acc, e = static acc e in + acc, Dnext(n, e) + | Dseq(eq_list) -> + let acc, eq_list = static_eqs acc eq_list in + acc, Dseq(eq_list) + | Dpar(eq_list) -> + let acc, eq_list = static_eqs acc eq_list in + acc, Dpar(eq_list) + | Dblock(block) -> + let acc, block = static_block acc block in + acc, Dblock(block) + | Dstatic(pat, e) -> + (pat, e) :: acc, no_equation + | Demit _ | Dlasteq _ | Dautomaton _ | Dreset _ | Dpresent _ -> + (* these cases should not arrive since control structures have *) + (* been translated into the basic kernel *) + fatal_error "static_eq" + +and static_pat_block_list acc p_block_list = + (* treat one handler *) + let static_pat_block acc (pat, block) = + let acc, block = static_block acc block in + acc, (pat, block) in + match p_block_list with + [] -> acc, [] + | pat_block :: pat_block_list -> + let acc, pat_block = static_pat_block acc pat_block in + let acc, pat_block_list = static_pat_block_list acc pat_block_list in + acc, pat_block :: pat_block_list + +(** Auxiliary definitions **) +let string_of_ident ident = + let prefix = + match ident.id_kind with + Kinit -> prefix_for_inits + | Kstatic -> prefix_for_statics + | Kmemo -> prefix_for_memos + | Kclock -> prefix_for_clocks + | Klast -> prefix_for_lasts + | _ -> prefix_for_names in + let suffix = + match ident.id_original with + None -> "" + | Some(n) when (is_an_infix_or_prefix_operator n) -> "__infix" + | Some(n) -> "__" ^ n in + prefix ^ (string_of_int ident.id_name) ^ suffix + +let string_of_name env i = + (* find the original name when it exists *) + let ident = find env i in + string_of_ident ident + +let name i = prefix_for_names ^ (string_of_int i) +let memo i = prefix_for_memos ^ (string_of_int i) +let initial i = prefix_for_inits ^ (string_of_int i) +let clock i = prefix_for_clocks ^ (string_of_int i) +let stat i = prefix_for_statics ^ (string_of_int i) + +(* the name of the current state *) +let selfstate env = prefix_for_self_state ^ (string_of_int (statename env)) + +(* access to a write variable *) +let access_write wt s = Cderef (Cvar s) + +(* makes an access to a name *) +let access env i = + let ident, st, wt = findall env i in + let s = string_of_ident ident in + match ident.id_kind with + Kinit | Kmemo | Kstatic -> + Crecord_access(Cvar(prefix_for_self_state ^ (string_of_int st)), + qualid s) + | _ -> + if is_a_write ident + then access_write wt s + else Cvar(s) + +let set name c = Tset(name, c) +let next self name c = Tlabelset(self, name, c) + +(** Compilation of functions *) +(* x1...xn. is translated into + + (1) combinatorial function + + \x1...xn.code;res + + (2) \x1...xn.self. + let self = match !self with + Nil -> let v = { ... init ... } in + self := St(v);v + | St(self) -> self in + code; + res + + r = f [...] x1...xn is translated into: + + (1) combinatorial function + + f = f [...] x1...xn + + (2) state function + + st = ref Nil initialisation part + + r = f x1...xn st step part + +Rmk: we can also write: "if reset then self := { ... }" +*) + +let co_apply env is_state (init_write, init_mem) f subst e_list = + if is_state then + (* state function *) + let st = prefix_for_names ^ (string_of_int symbol#name) in + let prefix = selfstate env in + (init_write, (st, Cref(state_nil)) :: init_mem), + Capply(f, + (subst @ e_list @ [Crecord_access(Cvar(prefix), qualid st)])) + else + (init_write, init_mem), Capply(f, subst @ e_list) + +(* prepare the initialization of memory variables *) +let cmatchstate self states = + let v = prefix_for_names ^ (string_of_int (symbol#name)) in + let st = prefix_state_constr ^ (string_of_int (symbol#name)) in + Cmatch(Cderef(Cvar(self)), + [Cconstructpat(qualid st,[Cvarpat(self)]), Cvar(self); + Cwildpat, Clet(false, [Cvarpat(v), states], + Cseq[Cset(self, + Cconstruct(qualid st, [Cvar(v)])); + Cvar(v)])]) + +(* prepare the initialization of write variables *) +let define_init_writes env init_write code = + List.fold_right + (fun (name, e) code -> Clet(false, [Cvarpat(name), Cref e], code)) + init_write code + +let co_fun env + is_state params p_list static (init_write, init_mem) code result = + if init_mem <> [] then intro_record_type init_mem; + + let code = clet code result in + let code = + if init_write <> [] + then define_init_writes env init_write code + else code in + let self = selfstate env in + if is_state + then + if init_mem = [] then Cfun(params @ p_list @ [Cvarpat(self)], code) + else Cfun(params @ p_list @ [Cvarpat(self)], + Clet(false, [Cvarpat(self), + cmatchstate self + (clet static (state_record init_mem))], + code)) + else Cfun(params @ p_list, code) + +(** Compilation of pattern matching *) +(* + match e with + P1 -> e1 + | ... + | Pn -> en + +(1) e is a static computation + +- initialisation code + let memory = match e with + P1 -> St1 { ... } + | ... + | Pn -> Stn { ... } + +- step code + match memory with + St1{...} -> step1 +| ... +| Stn{...} -> stepn + +(2) e may evolve at every instant + +- init code + ...i1... + ...in... + +- match e with + P1 -> step1 + | ... + | Pn -> stepn + +for the moment, we treat case (1) as case (2) *) + +(* +let co_static_merge e (pat, init_code_fvars_list) = + (* introduces the type definitions for the representation of states *) + let n = List.length init_code_fvars_list in + let prefix_constructor = intro_enum_type n in + + (* builds a constructor value *) + let constructor prefix number f_vars = + Cconstruct(qualid (prefix ^ (string_of_int number)), + List.map (fun name -> Cvar(name)) fvars) in + let constructor_pat prefix number f_vars = + Cconstructpat(qualid (prefix ^ (string_of_int number)), + List.map (fun name -> Cvarpat(name)) fvars) in + + (* computes the initialisation part *) + let rec states number init_code_fvars_list = + match init_code_fvars_list with + [] -> [] + | (pat, init, _, fvars) :: init_code_fvars_list -> + let pat_code = (pat, clet init (constructor prefix number fvars)) in + let pat_code_list = states (number + 1) init_code_fvars_list in + pat_code :: code_list in + + (* computes the transition part *) + let rec steps number init_code_fvars_list = + match init_code_fvars_list with + [] -> [] + | (_, _, code, fvars) :: init_code_fvars_list -> + let pat_code = (constructor_pat prefix number fvars, code) in + let pat_code_list = steps (number + 1) init_code_fvars_list in + pat_code :: pat_code_list in + + (* make the final code *) + let memory = symbol#name in + let init_code = Cmatch(e, states 0 init_code_fvars_list) in + let step_code = Cmatch(Cvar memory, steps 0 init_code_fvars_list) in + Tlet(memory, init_code), step_code + +*) + +(** Compilation of clocks *) +let rec translate_clock env init ck = + match ck with + Dfalse -> init, cfalse + | Dtrue -> init, ctrue + | Dclockvar(n) -> init, access env n + | Don(is_on, ck, car) -> + let init, ck = translate_clock env init ck in + let init, car = translate_carrier env init car in + init, if is_on then cand car ck + else cand (cnot car) ck + +and translate_carrier env init car = + match car with + Dcfalse -> init, cfalse + | Dctrue -> init, ctrue + | Dcvar(n) -> init, access env n + | Dcglobal(g, res, ck) -> + (* a global clock allocates memory *) + (* and is compiled as a function call *) + let res = match res with None -> cfalse | Some(n) -> access env n in + let init, c = translate_clock env init ck in + let init, new_ce = + co_apply env true init (Cglobal g) [c] [res] in + init, new_ce + +(** Compiling immediate. *) +let translate_immediate i = + match i with + | Dbool(b) -> Cbool(b) + | Dint(i) -> Cint(i) + | Dfloat(f) -> Cfloat(f) + | Dchar(c) -> Cchar(c) + | Dstring(s) -> Cstring(s) + | Dvoid -> Cvoid + +(** Compiling variables. *) +let translate_var env v = + match v with + Dglobal(g) -> Cglobal(g) + | Dlocal(n) -> access env n + +(** Compiling a pattern. *) +let rec translate_pat env pat = + match pat with + | Dconstantpat(i) -> Cconstantpat(translate_immediate(i)) + | Dvarpat(s) -> Cvarpat(string_of_name env s) + | Dtuplepat(l) -> Ctuplepat(List.map (translate_pat env) l) + | Dconstructpat(gl, pat_list) -> + Cconstructpat(gl, List.map (translate_pat env) pat_list) + | Dorpat(pat1, pat2) -> Corpat(translate_pat env pat1, + translate_pat env pat2) + | Drecordpat(gl_pat_list) -> + Crecordpat + (List.map (fun (gl, pat) -> (gl, translate_pat env pat)) + gl_pat_list) + | Daliaspat(pat, i) -> Caliaspat(translate_pat env pat, + string_of_name env i) + | Dwildpat -> Cwildpat + +(* +(* add accesses to write variables defined in patterns *) +let rec add_write_access env code pat = + match pat with + Dconstantpat(i) -> code + | Dvarpat(s) when is_a_write (find env s) -> + Tset(string_of_name env s, access env s) :: code + | Dvarpat _ -> code + | Dtuplepat(l) | Dconstructpat(_, l) -> + List.fold_left (add_write_access env) code l + | Dorpat(pat1, pat2) -> + add_write_access env (add_write_access env code pat1) pat2 + | Drecordpat(gl_pat_list) -> + List.fold_left (fun code (_, pat) -> add_write_access env code pat) + code gl_pat_list + | Daliaspat(pat, i) -> + add_write_access env (add_write_access env code pat) (Dvarpat(i)) + | Dwildpat -> code +*) + +(** Compiling an expression *) +(* takes an environment giving information about variables *) +(* and an expression and returns the new code *) +let rec translate env init e = + match e.d_desc with + | Dconstant(i) -> + let i = translate_immediate i in + init, Cconstant(i) + | Dvar(v, subst) -> + let v = translate_var env v in + let init, s = translate_subst env init subst in + let v = match s with [] -> v | l -> Capply(v, l) in + init, v + | Dtuple l -> + let init, lc = translate_list env init l in + init, Ctuple(lc) + | Dfun(is_state, params, p_list, body, result) -> + (* state function *) + let env = push_block body env in + (* compiles types and clock abstractions *) + let params = translate_forall env params in + (* compiles parameters *) + let p_list = List.map (translate_pat env) p_list in + (* remove static computation from the body *) + (* and put it in the allocation place for stateful functions *) + let (static_code, init_code, body, result) = + if is_state + then + let static_code, body = static_block [] body in + let static_code, result = static static_code result in + let static_code = List.rev static_code in + (* translate the static code *) + let static_code, init_code = + translate_static_code env static_code in + (static_code, init_code, body, result) + else + ([], ([], []), body, result) in + (* then translate the body *) + let init_code, body = translate_block env init_code body in + let init_code, result = translate env init_code result in + init, + co_fun env is_state params p_list static_code init_code body result + | Dprim(g, e_list) -> + (* pointwise application *) + let init, ce_list = translate_list env init e_list in + init, Capply(Cglobal(g), ce_list) + | Dconstruct(g, e_list) -> + let init, ce_list = translate_list env init e_list in + init, Cconstruct(g, ce_list) + | Drecord(gl_expr_list) -> + let translate_record (gl, expr) (init, gl_expr_list) = + let init, ce = translate env init expr in + init, (gl, ce) :: gl_expr_list in + let init, l = + List.fold_right translate_record gl_expr_list (init, []) in + init, Crecord(l) + | Drecord_access(expr, gl) -> + let init, ce = translate env init expr in + init, Crecord_access(ce, gl) + | Difthenelse(e0, e1, e2) -> + let init, c0 = translate env init e0 in + let init, c1 = translate env init e1 in + let init, c2 = translate env init e2 in + init, Cifthenelse(c0, c1, c2) + | Dlet(block, e_let) -> + let env = push block env in + let init, code = translate_block env init block in + let init, ce = translate env init e_let in + init, clet code ce + | Dapply(is_state, { d_desc = Dvar(f, subst) }, l) -> + let f = translate_var env f in + let init, l = translate_list env init l in + let init, subst = translate_subst env init subst in + co_apply env is_state init f subst l + | Dapply(is_state, f, l) -> + let init, f = translate env init f in + let init, l = translate_list env init l in + co_apply env is_state init f [] l + | Deseq(e1, e2) -> + let init, e1 = translate env init e1 in + let init, e2 = translate env init e2 in + init, Cseq [e1; e2] + | Dwhen(e1) -> + translate env init e1 + | Dclock(ck) -> + translate_clock env init ck + | Dlast _ | Dinit _ | Dpre _ | Dtest _ -> + (* this case should not arrive *) + fatal_error "translate" + +and translate_list env init l = + match l with + [] -> init, [] + | ce :: l -> + let init, ce = translate env init ce in + let init, l = translate_list env init l in + init, ce :: l + +and translate_block env init b = + (* allocate the memory in the initialisation part *) + let init = allocate_memory env init in + (* compiles the body *) + let init, code = translate_equation env init [] b.b_equations in + (* sets code in the correct order *) + let code = List.rev code in + (* returns the components of the block *) + init, code + +(* the input equations must be already scheduled *) +and translate_equations env init code eq_list = + match eq_list with + [] -> init, code + | eq :: eq_list -> + let init, code = translate_equation env init code eq in + translate_equations env init code eq_list + +and translate_equation_into_exp env init eq = + let init, code = translate_equation env init [] eq in + (* sets code in the correct order *) + let code = List.rev code in + init, cseq code + +and translate_block_into_exp env init block = + let init, code = translate_block env init block in + init, cseq code + +and translate_equation env init code eq = + match eq with + Dget(pat, v) -> + let cpat = translate_pat env pat in + let n = translate_var env v in + init, Tlet(cpat, n) :: code + | Dequation(Dvarpat(n), e) when is_a_write (find env n) -> + let name = string_of_name env n in + let init, ce = translate env init e in + init, (set name ce) :: code + | Dequation(pat, e) | Dstatic(pat, e) -> + let is_rec = is_recursive pat e in + let pat = translate_pat env pat in + let init, ce = translate env init e in + init, if is_rec then Tletrec([pat, ce]) :: code + else Tlet(pat, ce) :: code + | Dwheneq(eq, ck) -> + let init, ce = translate_equation_into_exp env init eq in + let init, ck_ce = translate_clock env init ck in + init, Texp(ifthen ck_ce ce) :: code + | Dmerge(is_static, e, p_block_list) -> + let init, ce = translate env init e in + let init, l = translate_pat_block_list env init p_block_list in + init, merge code ce l + | Dnext(n, e) -> + (* n is either a memo or an initialisation variable *) + let init, ce = translate env init e in + init, (next (selfstate env) (string_of_name env n) ce) :: code + | Dseq(eq_list) | Dpar(eq_list) -> + translate_equations env init code eq_list + | Dblock(block) -> + translate_block env init block + | Demit _ | Dlasteq _ | Dautomaton _ | Dreset _ | Dpresent _ -> + (* these cases should not arrive since control structures have *) + (* been translated into the basic kernel *) + fatal_error "translate_equation" + +(* compilation of pattern matching *) +and translate_pat_block_list env init p_block_list = + (* compile one handler *) + let translate_pat_block init (pat, block) = + let env = push block env in + let cpat = translate_pat env pat in + let init, ce = translate_block_into_exp env init block in + init, (cpat, ce) in + match p_block_list with + [] -> init, [] + | pat_block :: pat_block_list -> + let init, pat_ce = translate_pat_block init pat_block in + let init, pat_ce_list = + translate_pat_block_list env init pat_block_list in + init, pat_ce :: pat_ce_list + +(* translate a pure (stateless) expression *) +and translate_pure env e = + let init, ce = translate env ([], []) e in + assert (init = ([], [])); + ce + +(* computes extra parameters for clock abstraction *) +and translate_forall env params = + let p_clocks = + List.map (fun n -> Cvarpat(string_of_name env n)) params.s_clock in + let p_carriers = + List.map (fun n -> Cvarpat(string_of_name env n)) params.s_carrier in + p_clocks @ p_carriers + +(* generates an application for clock instanciation *) +and translate_subst env init subst = + let rec translate_clock_list init cl_list = + match cl_list with + [] -> init, [] + | cl :: cl_list -> + let init, cl = translate_clock env init cl in + let init, cl_list = translate_clock_list init cl_list in + init, cl :: cl_list in + let rec translate_carrier_list init car_list = + match car_list with + [] -> init, [] + | car :: car_list -> + let init, car = translate_carrier env init car in + let init, car_list = translate_carrier_list init car_list in + init, car :: car_list in + let init, cl_list = translate_clock_list init subst.s_clock in + let init, car_list = translate_carrier_list init subst.s_carrier in + init, cl_list @ car_list + +(* Initialisation code *) +and allocate_memory env init = + let allocate _ ident (acc_write, acc_mem) = + match ident.id_kind with + Kmemo -> + (* we allocate only one cell *) + let default = default_value env ident in + acc_write, (memo ident.id_name, default) :: acc_mem + | Kinit -> + (* init variables are considered to be state variables *) + acc_write, (initial ident.id_name, Cconstant(Cbool(true))) :: acc_mem + | _ when is_a_write ident -> + (* local write variables are allocated too *) + (* but they will be stored in a stack allocated structure *) + let name = string_of_name env ident.id_name in + let default = default_value env ident in + (name, default) :: acc_write, acc_mem + | _ -> acc_write, acc_mem in + Hashtbl.fold allocate (cblock env).b_env init + +(* add static code into the initialisation part *) +and translate_static_code env static_code = + (* add one equation *) + (* we compute the list of introduced names and compile the equation *) + let translate_eq acc (pat, e) = + let acc = fv_pat acc pat in + let pat = translate_pat env pat in + let ce = translate_pure env e in + acc, Tlet(pat, ce) in + let rec translate_static_code acc static_code = + match static_code with + [] -> acc, [] + | pat_e :: static_code -> + let acc, cpat_ce = translate_eq acc pat_e in + let acc, static_code = translate_static_code acc static_code in + acc, cpat_ce :: static_code in + (* introduced names must be added to the memory *) + let intro acc_mem n = + let v = string_of_name env n in + (* modify the kind of [n] *) + set_static (find env n); + (string_of_name env n, Cvar(v)) :: acc_mem in + + (* first compile the static code *) + let acc, static_code = translate_static_code [] static_code in + (* introduced names must be added to the memory initialisation *) + let acc_mem = List.fold_left intro [] acc in + static_code, ([], acc_mem) + +(* default value *) +and default_value env ident = + (* find a value from a type *) + let rec value ty = + match ty with + Dproduct(ty_l) -> Ctuple(List.map value ty_l) + | Dbase(b) -> + let v = match b with + Dtyp_bool -> Cbool(false) + | Dtyp_int -> Cint(0) + | Dtyp_float -> Cfloat(0.0) + | Dtyp_unit -> Cvoid + | Dtyp_char -> Cchar(' ') + | Dtyp_string -> Cstring("") in + Cconstant(v) + | Dsignal(ty) -> Ctuple[value ty; cfalse] + | Dtypvar _ | Darrow _ -> cdummy + | Dconstr(qualid, _) -> + try + let desc = find_type qualid in + match desc.d_type_desc with + Dabstract_type -> cdummy + | Dabbrev(ty) -> + value ty + | Dvariant_type l -> + let case = List.hd l in + begin match case with + (qual, { arg = ty_l }) -> + Cconstruct(qual, List.map value ty_l) + end + | Drecord_type l -> + let field_of_type (qual, _, ty_ty) = (qual, value ty_ty.res) in + Crecord (List.map field_of_type l) + with + Not_found -> cdummy in + let value (Dtypforall(_, ty)) = value ty in + match ident.id_value with + None -> value ident.id_typ + | Some(e) -> translate_pure env e + +(** Compilation of a table of declarative code *) +let translate table = + let translate (s, e) = (s, translate_pure empty_env e) in + (* introduce the type of states *) +(* intro_state_type (); *) + (* then translate *) + (* translate the code *) + { c_types = table.d_types; + c_code = List.map translate table.d_code; + c_vars = table.d_vars; + } diff --git a/compiler/obc/ml/declarative.ml b/compiler/obc/ml/declarative.ml new file mode 100644 index 0000000..ae6db9e --- /dev/null +++ b/compiler/obc/ml/declarative.ml @@ -0,0 +1,295 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: declarative.ml,v 1.18 2007-01-11 07:35:53 pouzet Exp $ *) +(* the intermediate format *) + +open Misc +open Names + +(* one set of (unique) names *) +type name = int + +type global = + Gname of string * name + | Gmodname of qualified_ident + +(* type definitions *) +type type_definition = + { d_type_desc: type_components; + d_type_arity: int list + } + +and ('a, 'b) ptyp = { arg: 'a; res: 'b } + +and type_components = + Dabstract_type + | Dabbrev of typ + | Dvariant_type of (qualified_ident * (typ list, typ) ptyp) list + | Drecord_type of (qualified_ident * is_mutable * (typ, typ) ptyp) list + +and is_mutable = bool + +(* types *) +and typs = Dtypforall of name list * typ +and typ = + | Darrow of is_node * typ * typ + | Dproduct of typ list + | Dconstr of qualified_ident * typ list + | Dtypvar of name + | Dbase of base_typ + | Dsignal of typ + +and is_node = bool + +and base_typ = + Dtyp_bool | Dtyp_int | Dtyp_float | Dtyp_unit | + Dtyp_char | Dtyp_string + +type guard = clock + +and clock = + | Dfalse (* the false clock *) + | Dtrue (* the base clock *) + | Don of bool * clock * carrier (* "cl on c" or "cl on not c" *) + | Dclockvar of name (* 'a *) + +and carrier = + Dcfalse + | Dctrue + | Dcvar of name + | Dcglobal of qualified_ident * name option * clock + (* identifier, reset name and clock *) + +(* immediate values *) +type immediate = + | Dbool of bool + | Dint of int + | Dfloat of float + | Dchar of char + | Dstring of string + | Dvoid + +type 'a desc = + { d_desc: 'a; + d_ty: typ; + d_guard: guard + } + +(* patterns *) +type pattern = + | Dwildpat + | Dvarpat of name + | Dconstantpat of immediate + | Dtuplepat of pattern list + | Dconstructpat of qualified_ident * pattern list + | Drecordpat of (qualified_ident * pattern) list + | Daliaspat of pattern * name + | Dorpat of pattern * pattern + +(* signal expressions *) +type spattern = + | Dandpat of spattern * spattern + | Dexppat of expr + | Dcondpat of expr * pattern + +(* expressions *) +and expr = expr_desc desc + +and expr_desc = + | Dconstant of immediate + | Dvar of var * subst + | Dlast of name + | Dpre of expr option * expr + | Difthenelse of expr * expr * expr + | Dinit of clock * name option + | Dtuple of expr list + | Dconstruct of qualified_ident * expr list + | Drecord of (qualified_ident * expr) list + | Drecord_access of expr * qualified_ident + | Dprim of qualified_ident * expr list + | Dfun of is_state * params * pattern list * block * expr + | Dapply of is_state * expr * expr list + | Dlet of block * expr + | Deseq of expr * expr + | Dtest of expr (* testing the presence "?" *) + | Dwhen of expr (* instruction "when" *) + | Dclock of clock + +and is_state = bool + +and var = + | Dlocal of name + | Dglobal of qualified_ident + +and is_external = bool (* true for imported ML values *) + +(* type and clock instance *) +and ('a, 'b, 'c) substitution = + { s_typ: 'a list; + s_clock: 'b list; + s_carrier: 'c list } + +and subst = (typ, clock, carrier) substitution +and params = (name, name, name) substitution + +(* block *) +and block = + { b_env: (name, ident) Hashtbl.t; (* environment *) + mutable b_write: name list; (* write variables *) + b_equations: equation; (* equations *) + } + +(* equation *) +and equation = + Dequation of pattern * expr (* equation p = e *) + | Dnext of name * expr (* next x = e *) + | Dlasteq of name * expr (* last x = e *) + | Demit of pattern * expr (* emit pat = e *) + | Dstatic of pattern * expr (* static pat = e *) + | Dget of pattern * var (* pat = x *) + | Dwheneq of equation * guard (* eq when clk *) + | Dmerge of is_static * expr (* control structure *) + * (pattern * block) list + | Dreset of equation * expr (* reset *) + | Dautomaton of clock * (state_pat * block * block * escape * escape) list + (* automaton weak and strong *) + | Dpar of equation list (* parallel equations *) + | Dseq of equation list (* sequential equations *) + | Dblock of block (* block structure *) + | Dpresent of clock * (spattern * block) list * block + (* presence testing *) + +and escape = (spattern * block * is_continue * state) list + +and is_static = bool +and is_strong = bool +and is_continue = bool + +and state_pat = string * pattern list +and state = string * expr list + +(* ident definition *) +and ident = + { id_name: name; (* its name (unique identifier) *) + id_original: string option; (* its original name when possible *) + id_typ: typs; (* its type *) + id_value: expr option; (* its initial value when possible *) + mutable id_kind: id_kind; (* kind of identifier *) + mutable id_write: bool; (* physically assigned or not *) + mutable id_last: bool; (* do we need its last value also? *) + mutable id_signal: bool; (* is-it a signal? *) + } + +(* a local variable in a block may be of four different kinds *) +and id_kind = + Kinit (* initialisation state variable *) + | Kclock (* clock variable *) + | Kreset (* reset variable *) + | Kmemo (* state variable *) + | Kstatic (* static variable *) + | Klast (* last variable *) + | Kvalue (* defined variable *) + | Kshared (* shared variable with several definitions *) + | Kinput (* input variable, i.e, argument *) + +(* global definition *) +(* Invariant: expr must be bounded and static *) + +(* the declarative code associated to a file *) +type declarative_code = + { mutable d_modname: string; (* module name *) + mutable d_types: (string, type_definition) Hashtbl.t; + (* type definitions *) + mutable d_code: (string * expr) list; (* value definitions *) + mutable d_vars: string list; (* defined names *) + } + + +(* the generated code of a module *) +let dc = { d_modname = ""; + d_types = Hashtbl.create 7; + d_code = []; + d_vars = [] + } + +let code () = dc + +(* thing to do when starting the production of declarative code *) +(* for a file *) +let start modname = + dc.d_modname <- modname; + dc.d_types <- Hashtbl.create 7; + dc.d_code <- []; + dc.d_vars <- [] + +(* things to do at the end of the front-end*) +let finish () = + dc.d_code <- List.rev dc.d_code + +(* apply a function to every value *) +let replace translate = + let rec replace (s, e) = + let e = translate e in + dc.d_code <- (s, e) :: dc.d_code in + let code = dc.d_code in + dc.d_code <- []; + List.iter replace code; + dc.d_code <- List.rev dc.d_code + + +(* add an input to the declarative code *) +let add_dec (name, code) = + dc.d_code <- (name, code) :: dc.d_code; + dc.d_vars <- name :: dc.d_vars + +(* add a type definition to the declarative code *) +let add_type (name, type_def) = + Hashtbl.add dc.d_types name type_def + +(* read code from and write code into a file *) +let read_declarative_code ic = input_value ic + +let write_declarative_code oc = + output_value oc (code ()) + +(* the list of opened modules *) +let dc_modules = (Hashtbl.create 7 : (string, declarative_code) Hashtbl.t) + +(* add a module to the list of opened modules *) +let add_module m = + let name = String.uncapitalize m in + try + let fullname = find_in_path (name ^ ".dcc") in + let ic = open_in fullname in + let dc = input_value ic in + Hashtbl.add dc_modules m dc; + close_in ic; + dc + with + Cannot_find_file _ -> + Printf.eprintf + "Cannot find the compiled declarative file %s.dcc.\n" + name; + raise Error + +let find_value qualid = + let dc = + if qualid.qual = dc.d_modname then dc + else raise Not_found +(* + try + Hashtbl.find dc_modules qualid.qual + with + Not_found -> add_module qualid.qual *) in + List.assoc qualid.id dc.d_code + +let find_type qualid = + if qualid.qual = dc.d_modname then Hashtbl.find dc.d_types qualid.qual + else raise Not_found diff --git a/compiler/obc/ml/declarative_printer.ml b/compiler/obc/ml/declarative_printer.ml new file mode 100644 index 0000000..6c93d2c --- /dev/null +++ b/compiler/obc/ml/declarative_printer.ml @@ -0,0 +1,699 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: declarative_printer.ml,v 1.13 2007-01-11 07:35:53 pouzet Exp $ *) + +open Misc +open Names +open Declarative +open Modules +open Format + +(* generic printing of a list *) +let print_list print l = + let rec printrec l = + match l with + [] -> () + | [x] -> + print x + | x::l -> + print x; + print_space (); + printrec l in + printrec l + +(* local name *) +let print_name i = + print_string "/";print_int i + +(* global names *) +let print_qualified_ident { qual = q; id = id } = + if (q = pervasives_module) or (q = compiled_module_name ()) + or (q = "") + then print_string id + else + begin + print_string q; + print_string "."; + print_string id + end + +(* print types *) +let rec print_type typ = + open_box 1; + begin match typ with + Darrow(is_node, typ1, typ2) -> + print_string "("; + if is_node then print_string "=>" else print_string "->"; + print_space (); + print_list print_type [typ1;typ2]; + print_string ")" + | Dproduct(ty_list) -> + print_string "("; + print_string "*"; + print_space (); + print_list print_type ty_list; + print_string ")" + | Dconstr(qual_ident, ty_list) -> + if ty_list <> [] then print_string "("; + print_qualified_ident qual_ident; + if ty_list <> [] then + begin print_space (); + print_list print_type ty_list; + print_string ")" + end + | Dsignal(ty) -> print_type ty; print_space (); print_string "sig" + | Dtypvar(i) -> print_int i + | Dbase(b) -> print_base_type b + end; + close_box () + +and print_base_type b = + match b with + Dtyp_bool -> print_string "bool" + | Dtyp_int -> print_string "int" + | Dtyp_float -> print_string "float" + | Dtyp_unit -> print_string "unit" + | Dtyp_string -> print_string "string" + | Dtyp_char -> print_string "char" + +let print_typs (Dtypforall(l, typ)) = + match l with + [] -> (* we do not print the quantifier when there is no type variable *) + print_type typ + | l -> + open_box 1; + print_string "(forall"; + print_space (); + print_list print_name l; + print_space (); + print_type typ; + print_string ")"; + close_box () + +(* print clocks *) +let rec print_clock clk = + match clk with + | Dfalse -> print_string "false" + | Dtrue -> print_string "true" + | Dclockvar(i) -> print_name i + | Don(b, clk, c) -> + print_string "("; + if b then print_string "on" else print_string "onot"; + print_space (); + print_clock clk; + print_space (); + print_carrier c; + print_string ")" +and print_carrier c = + match c with + Dcfalse -> print_string "false" + | Dctrue -> print_string "true" + | Dcvar(i) -> print_name i + | Dcglobal(qual_ident, res, clk) -> + print_qualified_ident qual_ident; + print_string "("; + (match res with + None -> () + | Some(n) -> print_space ();print_name n;print_space ()); + print_clock clk; + print_string ")" + +(* immediate values *) +let print_immediate i = + match i with + Dbool(b) -> print_string (if b then "true" else "false") + | Dint(i) -> print_int i + | Dfloat(f) -> print_float f + | Dchar(c) -> print_char c + | Dstring(s) -> print_string s + | Dvoid -> print_string "()" + +(* print patterns *) +let atom_pat pat = + match pat with + Dconstantpat _ | Dvarpat _ | Dwildpat -> true + | _ -> false + +let rec print_pat pat = + open_box 1; + if not (atom_pat pat) then print_string "("; + begin match pat with + Dwildpat -> print_string "_" + | Dconstantpat(i) -> print_immediate i + | Dvarpat(i) -> print_name i + | Dconstructpat(qual_ident, pat_list) -> + print_string "constr"; + print_space (); + print_qualified_ident qual_ident; + if pat_list <> [] then print_space (); + print_list print_pat pat_list + | Dtuplepat(pat_list) -> + print_string ","; + print_space (); + print_list print_pat pat_list + | Drecordpat(l) -> + print_string "record"; + print_list + (fun (qual_ident, pat) -> + open_box 1; + print_string "("; + print_qualified_ident qual_ident; + print_space (); + print_pat pat; + print_string ")"; + close_box ()) l + | Dorpat(pat1, pat2) -> + print_string "orpat"; + print_space (); + print_list print_pat [pat1;pat2] + | Daliaspat(pat, i) -> + print_string "as"; + print_space (); + print_pat pat; + print_space (); + print_int i + end; + if not (atom_pat pat) then print_string ")"; + close_box () + +(* print statepat *) +let print_statepat (s, l) = + match l with + [] -> print_string s + | l -> print_string "("; + print_string s; + print_space (); + print_list print_pat l; + print_string ")" + +(* print expressions *) +let atom e = + match e.d_desc with + Dconstant _ -> true + | _ -> false + +(* print variables *) +let print_var v = + match v with + Dlocal(n) -> + print_string "local"; + print_space (); + print_name n + | Dglobal(qual_ident) -> + print_string "global"; + print_space (); + print_qualified_ident qual_ident + +let rec print e = + open_box 1; + if not (atom e) then print_string "("; + begin match e.d_desc with + Dconstant(i) -> print_immediate i + | Dvar(v, subst) -> + print_var v; + print_subst subst + | Dlast(i) -> + print_string "last"; + print_space (); + print_name i + | Dpre(opt_default, e) -> + print_string "pre"; + print_space (); + begin match opt_default with + None -> print e + | Some(default) -> + print default; print_space (); print e + end + | Dinit(ck, None) -> + print_string "init"; + print_space (); + print_clock ck + | Dinit(ck, Some(n)) -> + print_string "init"; + print_space (); + print_clock ck; + print_space (); + print_name n + | Difthenelse(e0,e1,e2) -> + print_string "if"; + print_space (); + print e0; + print_space (); + print e1; + print_space (); + print e2 + | Dtuple(l) -> + print_string ","; + print_space (); + print_list print l + | Dconstruct(qual_ident,l) -> + print_string "constr"; + print_space (); + print_qualified_ident qual_ident; + if l <> [] then print_space (); + print_list print l + | Dprim(qual_ident, l) -> + print_string "("; + print_qualified_ident qual_ident; + print_space (); + print_list print l; + print_string ")" + | Drecord(l) -> + print_string "record"; + print_space (); + print_list (fun (qual_ident, e) -> + open_box 1; + print_string "("; + print_qualified_ident qual_ident; + print_space (); + print e; + print_string ")"; + close_box ()) l + | Drecord_access(e,qual_ident) -> + print_string "access"; + print_space (); + print e; + print_space (); + print_qualified_ident qual_ident + | Dfun(is_state, params, args, block, e) -> + print_string ("fun" ^ (if is_state then "(s)" else "(c)")); + print_space (); + print_params params; + print_space (); + print_list print_pat args; + print_space (); + print_block block; + print_space (); + print_string "return "; + print e + | Dapply(is_state, f, e_list) -> + print_string ("apply" ^ (if is_state then "(s)" else "(c)")); + print_space (); + print f; + print_space (); + print_list print e_list + | Dlet(block, e) -> + print_string "let"; + print_space (); + print_block block; + print_space (); + print e + | Deseq(e1, e2) -> + print_string "seq"; + print_space (); + print e1; + print_space (); + print e2 + | Dtest(e1) -> + print_string "test"; + print_space (); + print e1 + | Dwhen(e1) -> + print_string "when"; + print_space (); + print e1 + | Dclock(ck) -> + print_string "clock"; + print_space (); + print_clock ck + end; + if not (atom e) then print_string ")"; + close_box() + +and print_block b = + (* print variable definitions *) + let print_env env = + open_box 1; + print_string "(env"; + print_space (); + Hashtbl.iter (fun i ident -> print_ident ident;print_space ()) env; + print_string ")"; + close_box () in + (* main function *) + open_box 1; + print_string "("; + (* environment *) + print_env b.b_env; + print_space (); + (* equations *) + print_equation b.b_equations; + print_space (); + (* write variables *) + print_string "(write"; + print_space (); + print_list print_name b.b_write; + print_string ")"; + print_string ")"; + close_box () + +(* print ident declarations *) +(* e.g, "(kind x/412 (int) (cl) (write) (last) (signal) (= 412))" *) +and print_ident id = + let print_kind () = + match id.id_kind with + Kinit -> print_string "init" + | Kclock -> print_string "clock" + | Kmemo -> print_string "memo" + | Kstatic -> print_string "static" + | Klast -> print_string "last" + | Kreset -> print_string "reset" + | Kvalue -> print_string "value" + | Kinput -> print_string "input" + | Kshared -> print_string "shared" in + let print_name () = + begin match id.id_original with + None -> () + | Some(s) -> print_string s + end; + print_name id.id_name in + let print_typs () = + print_string "("; + print_typs id.id_typ; + print_string ")" in + let print_write () = + if id.id_write then + begin print_space (); print_string "(write)" end in + let print_last () = + if id.id_last then + begin print_space (); print_string "(last)" end in + let print_signal () = + if id.id_signal then + begin print_space (); print_string "(signal)" end in + let print_expr () = + match id.id_value with + None -> () + | Some(e) -> + print_space ();print_string "(= "; print e; print_string ")" in + (* main function *) + open_box 1; + print_string "("; + print_kind (); + print_space (); + print_name (); + print_space (); + print_typs (); + print_space (); + print_write (); + print_last (); + print_signal (); + print_expr (); + print_string ")"; + close_box () + +(* prints a sequence of sets of parallel equations *) +and print_equation eq = + open_box 1; + print_string "("; + begin match eq with + Dequation(pat, e) -> + print_string "let"; + print_space (); + print_pat pat; + print_space (); + print e; + print_space (); + print_clock e.d_guard + | Dlasteq(n, e) -> + print_string "last"; + print_space (); + print_name n; + print_space (); + print e; + print_space (); + print_clock e.d_guard + | Demit(pat, e) -> + print_string "emit"; + print_space (); + print_pat pat; + print_space (); + print e; + print_space (); + print_clock e.d_guard + | Dstatic(pat, e) -> + print_string "static"; + print_space (); + print_pat pat; + print_space (); + print e; + print_space (); + print_clock e.d_guard + | Dnext(n, e) -> + print_string "next"; + print_space (); + print_name n; + print_space (); + print e; + print_space (); + print_clock e.d_guard + | Dget(pat, v) -> + print_string "get"; + print_space (); + print_pat pat; + print_space (); + print_var v + | Dwheneq(eq, clk) -> + print_string "when"; + print_space (); + print_clock clk; + print_space (); + print_equation eq + | Dmerge(is_static, e, pat_block_list) -> + print_string "merge"; + print_space (); + if is_static then print_string "static" + else print_clock e.d_guard; + print_space (); + print e; + print_space (); + print_list (fun (pat, block) -> + open_box 1; + print_string "("; + print_pat pat; + print_space (); + print_block block; + print_string ")"; + close_box ()) pat_block_list + | Dpresent(ck, scondpat_block_list, block) -> + print_string "present"; + print_space (); + print_clock ck; + print_space (); + print_list (fun (scondpat, block) -> + open_box 1; + print_string "("; + print_spat scondpat; + print_space (); + print_block block; + print_string ")"; + close_box ()) scondpat_block_list; + print_space (); + print_block block + | Dreset(eq, e) -> + print_string "reset"; + print_space (); + print_equation eq; + print_space (); + print e + | Dautomaton(ck, handlers) -> + print_string "automaton"; + print_space (); + print_clock ck; + print_space (); + print_list print_handler handlers + | Dpar(eq_list) -> + print_string "par"; + print_space (); + print_list print_equation eq_list + | Dseq(eq_list) -> + print_string "seq"; + print_space (); + print_list print_equation eq_list + | Dblock(b) -> + print_string "block"; + print_space (); + print_block b + end; + print_string ")"; + close_box () + +(* print the handlers of an automaton *) +and print_handler (statepat, b_weak, b_strong, weak_escape, strong_escape) = + open_box 1; + print_string "(state"; + print_space (); + print_statepat statepat; + print_space (); + print_block b_weak; + print_space (); + print_block b_strong; + print_space (); + print_string "(weak "; + print_escape weak_escape; + print_string ")"; + print_space (); + print_string "(strong "; + print_escape weak_escape; + print_string ")"; + print_string ")"; + close_box () + +and print_escape escape_list = + print_list + (fun (spat, b, is_continue, state) -> + print_string "("; + if is_continue then print_string "continue " else print_string "then "; + print_spat spat; + print_space (); + print_block b; + print_space (); + print_state state; + print_string ")") + escape_list; + close_box () + + +(* print type and clock instance *) +and print_subst { s_typ = st; s_clock = scl; s_carrier = sc } = + match st, scl, sc with + [],[],[] -> () + | l1,l2,l3 -> + print_string "["; + print_list print_type l1; + print_string "]"; + print_space (); + print_string "["; + print_list print_clock l2; + print_string "]"; + print_space (); + print_string "["; + print_list print_carrier l3; + print_string "]"; + +and print_params { s_typ = pt; s_clock = pcl; s_carrier = pc } = + match pt, pcl, pc with + [],[],[] -> () + | l1,l2,l3 -> + print_string "["; + print_list print_name l1; + print_string "]"; + print_space (); + print_string "["; + print_list print_name l2; + print_string "]"; + print_space (); + print_string "["; + print_list print_name l3; + print_string "]" + +and print_state (s, l) = + match l with + [] -> print_string s + | l -> print_string "("; + print_string s; + print_space (); + print_list print l; + print_string ")" + +and atom_spat spat = + match spat with + Dexppat _ | Dcondpat _ -> true + | _ -> false + +and print_spat spat = + open_box 1; + if not (atom_spat spat) then print_string "("; + begin match spat with + Dandpat(spat1, spat2) -> + print_string "& "; + print_spat spat1; + print_space (); + print_spat spat2 + | Dexppat(e) -> + print e + | Dcondpat(e, pat) -> + print_string "is "; + print e; + print_space (); + print_pat pat + end; + if not (atom_spat spat) then print_string ")"; + close_box () + +(* the main entry for printing definitions *) +let print_definition (name, e) = + open_box 2; + print_string "(def "; + if is_an_infix_or_prefix_operator name + then begin print_string "( "; print_string name; print_string " )" end + else print_string name; + print_space (); + print e; + print_string ")"; + print_newline (); + close_box () + +(* print types *) +let print_variant (qualid, { arg = typ_list; res = typ }) = + print_string "("; + print_qualified_ident qualid; + print_string "("; + print_list print_type typ_list; + print_string ")"; + print_space (); + print_type typ; + print_string ")" + +let print_record (qualid, is_mutable, { arg = typ1; res = typ2 }) = + print_string "("; + if is_mutable then print_string "true" else print_string "false"; + print_space (); + print_qualified_ident qualid; + print_space (); + print_type typ1; + print_space (); + print_type typ2; + print_string ")" + +let print_type_declaration s { d_type_desc = td; d_type_arity = arity } = + open_box 2; + print_string "(type["; + print_list print_name arity; + print_string "]"; + print_space (); + print_string s; + print_space (); + begin match td with + Dabstract_type -> () + | Dabbrev(ty) -> + print_type ty + | Dvariant_type variant_list -> + List.iter print_variant variant_list + | Drecord_type record_list -> + List.iter print_record record_list + end; + print_string ")"; + print_newline (); + close_box ();; + +(* the main functions *) +set_max_boxes max_int ;; + +let output_equations oc eqs = + set_formatter_out_channel oc; + List.iter print_equation eqs + +let output oc declarative_code = + set_formatter_out_channel oc; + (* print type declarations *) + Hashtbl.iter print_type_declaration declarative_code.d_types; + (* print value definitions *) + List.iter print_definition declarative_code.d_code; + print_flush () + diff --git a/compiler/obc/ml/default_value.ml b/compiler/obc/ml/default_value.ml new file mode 100644 index 0000000..ff2800a --- /dev/null +++ b/compiler/obc/ml/default_value.ml @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Gregoire Hamon, Marc Pouzet *) +(* Organization : SPI team, LIP6 laboratory, University Paris 6 *) +(* *) +(**************************************************************************) + +(* $Id: default_value.ml,v 1.1.1.1 2005-11-03 15:45:23 pouzet Exp $ *) + +(** Computes a default value from a type *) + +open Misc +open Names +open Def_types +open Types +open Initialization +open Caml + +let default x ty = + let rec def ty = + match ty with + TypeVar{contents = Typindex _} -> Cdummy "" + | TypeVar{contents = Typlink ty} -> def ty + | Tarrow _ -> x + | Tproduct(t_list) -> + if t_list = [] + then Cdummy "" + else Ctuple (List.map def t_list) + | Tconstr (info, tlist) -> + if info.qualid.qual = pervasives_module then + match info.qualid.id with + | "int" -> Cim (Cint 0) + | "bool" | "clock" -> Cim (Cbool false) + | "float" -> Cim (Cfloat 0.0) + | "char" -> Cim (Cchar 'a') + | "string" -> Cim (Cstring "") + | "unit" -> Cim (Cvoid) + | _ -> Cdummy "" + else + match info.info_in_table.type_desc with + Abstract_type -> Cdummy "" + | Variant_type l -> + begin + let case = List.hd l in + match case.info_in_table.typ_desc with + Tarrow (ty1, ty2) -> + Cconstruct1 ({ cqual = case.qualid.qual; + cid = case.qualid.id }, def ty1) + | _ -> + Cconstruct0 { cqual = case.qualid.qual; + cid = case.qualid.id } + end + | Record_type l -> + let field_of_type x = + let ty1,_ = filter_arrow x.info_in_table.typ_desc in + ({ cqual = x.qualid.qual; cid = x.qualid.id }, def ty1) in + Crecord (List.map field_of_type l) + in + def ty + + diff --git a/compiler/obc/ml/misc.ml b/compiler/obc/ml/misc.ml new file mode 100644 index 0000000..ec719ac --- /dev/null +++ b/compiler/obc/ml/misc.ml @@ -0,0 +1,295 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: misc.ml,v 1.11 2006-09-30 12:27:27 pouzet Exp $ *) + +(* version of the compiler *) +let version = "3.0b" + +let date = DATE + +(* standard module *) +let pervasives_module = "Pervasives" +let standard_lib = STDLIB + +(* variable creation *) +(* generating names *) +class name_generator = + object + val mutable counter = 0 + method name = + counter <- counter + 1; + counter + method reset = + counter <- 0 + method init i = + counter <- i + end + +(* association table with memoization *) +class name_assoc_table f = + object + val mutable counter = 0 + val mutable assoc_table: (int * string) list = [] + method name var = + try + List.assq var assoc_table + with + not_found -> + let n = f counter in + counter <- counter + 1; + assoc_table <- (var,n) :: assoc_table; + n + method reset = + counter <- 0; + assoc_table <- [] + end + +(* error during the whole process *) +exception Error + +(* internal error : for example, an abnormal pattern matching failure *) +(* gives the name of the function *) +exception Internal_error of string + +let fatal_error s = raise (Internal_error s) + +let not_yet_implemented s = + Printf.eprintf "The construction %s is not implemented yet.\n" s; + raise Error + +(* creating a name generator for type and clock calculus *) +(* ensure unicity for the whole process *) +let symbol = new name_generator + +(* generic and non generic variables in the various type systems *) +let generic = -1 +let notgeneric = 0 +let maxlevel = max_int + +let binding_level = ref 0 +let top_binding_level () = !binding_level = 0 + +let push_binding_level () = binding_level := !binding_level + 1 +let pop_binding_level () = + binding_level := !binding_level - 1; + assert (!binding_level > generic) +let reset_binding_level () = binding_level := 0 + +(* realtime mode *) +let realtime = ref false + +(* assertions *) +let no_assert = ref false + +(* converting integers into variable names *) +(* variables are printed 'a, 'b *) +let int_to_letter bound i = + if i < 26 + then String.make 1 (Char.chr (i+bound)) + else String.make 1 (Char.chr ((i mod 26) + bound)) ^ string_of_int (i/26) + +let int_to_alpha i = int_to_letter 97 i + +(* printing information *) +class on_off = + object + val mutable status = false + method set = status <- true + method get = status + end + +let print_type = new on_off +let print_clock = new on_off +let print_init = new on_off +let print_causality = new on_off +let no_causality = ref false +let no_initialisation = ref false + +let no_deadcode = ref false + +(* control what is done in the compiler *) +exception Stop + +let only = ref "" +let set_only_info o = only := o +let parse_only () = + if !only = "parse" then raise Stop +let type_only () = + if !only = "type" then raise Stop +let clock_only () = + if !only = "clock" then raise Stop +let caus_only () = + if !only = "caus" then raise Stop +let init_only () = + if !only = "init" then raise Stop +let dec_only () = + if !only = "parse" or !only = "type" + or !only = "clock" or !only = "init" + or !only = "dec" then raise Stop + +(* load paths *) +let load_path = ref ([] : string list) + +(* no link *) +let no_link = ref false + +(* simulation node *) +let simulation_node = ref "" + +(* sampling rate *) +let sampling_rate : int option ref = ref None + +(* level of inlining *) +let inlining_level = ref 10 + +(* emiting declarative code *) +let print_declarative_code = ref false +let print_auto_declarative_code = ref false +let print_total_declarative_code = ref false +let print_last_declarative_code = ref false +let print_signals_declarative_code = ref false +let print_reset_declarative_code = ref false +let print_linearise_declarative_code = ref false +let print_initialize_declarative_code = ref false +let print_split_declarative_code = ref false +let print_inline_declarative_code = ref false +let print_constant_declarative_code = ref false +let print_deadcode_declarative_code = ref false +let print_copt_declarative_code = ref false + +(* total emission of signals *) +let set_total_emit = ref false + +(* generating C *) +let make_c_code = ref false + +(* profiling information about the compilation *) +let print_exec_time = ref false + +exception Cannot_find_file of string + +let find_in_path filename = + if Sys.file_exists filename then + filename + else if not(Filename.is_implicit filename) then + raise(Cannot_find_file filename) + else + let rec find = function + [] -> + raise(Cannot_find_file filename) + | a::rest -> + let b = Filename.concat a filename in + if Sys.file_exists b then b else find rest + in find !load_path + + +(* Prompts: [error_prompt] is printed before compiler error *) +(* and warning messages *) +let error_prompt = ">" + +(* list intersection *) +let intersect l1 l2 = + List.exists (fun el -> List.mem el l1) l2 + +(* remove an entry from an association list *) +let rec remove n l = + match l with + [] -> raise Not_found + | (m, v) :: l -> + if n = m then l else (m, v) :: remove n l + +(* list substraction. l1 - l2 *) +let sub_list l1 l2 = + let rec sl l l1 = + match l1 with + [] -> l + | h :: t -> sl (if List.mem h l2 then l else (h :: l)) t in + sl [] l1 + +(* union *) +let rec union l1 l2 = + match l1, l2 with + [], l2 -> l2 + | l1, [] -> l1 + | x :: l1, l2 -> + if List.mem x l2 then union l1 l2 else x :: union l1 l2 + +let addq x l = if List.memq x l then l else x :: l + +let rec unionq l1 l2 = + match l1, l2 with + [], l2 -> l2 + | l1, [] -> l1 + | x :: l1, l2 -> + if List.memq x l2 then unionq l1 l2 else x :: unionq l1 l2 + +(* intersection *) +let rec intersection l1 l2 = + match l1, l2 with + ([], _) | (_, []) -> [] + | x :: l1, l2 -> if List.mem x l2 then x :: intersection l1 l2 + else intersection l1 l2 + +(* the last element of a list *) +let rec last l = + match l with + [] -> raise (Failure "last") + | [x] -> x + | _ :: l -> last l + +(* iterator *) +let rec map_fold f acc l = + match l with + [] -> acc, [] + | x :: l -> + let acc, v = f acc x in + let acc, l = map_fold f acc l in + acc, v :: l + +(* flat *) +let rec flat l = + match l with + [] -> [] + | x :: l -> x @ flat l + +(* reverse *) +let reverse l = + let rec reverse acc l = + match l with + [] -> acc + | x :: l -> reverse (x :: acc) l in + reverse [] l + +(* generic printing of a list *) +let print_list print print_sep l = + let rec printrec l = + match l with + [] -> () + | [x] -> + print x + | x::l -> + print x; + print_sep (); + printrec l in + printrec l + +(* generates the sequence of integers *) +let rec from n = if n = 0 then [] else n :: from (n-1) + +(* for infix operators, print parenthesis around *) +let is_an_infix_or_prefix_operator op = + if op = "" then false + else + let c = String.get op 0 in + not (((c >= 'a') & (c <= 'z')) or ((c >= 'A') & (c <= 'Z'))) + +(* making a list from a hash-table *) +let listoftable t = + Hashtbl.fold (fun key value l -> (key, value) :: l) t [] diff --git a/compiler/obc/ml/ml.ml b/compiler/obc/ml/ml.ml new file mode 100644 index 0000000..139597f --- /dev/null +++ b/compiler/obc/ml/ml.ml @@ -0,0 +1,2 @@ + + From 6c763f1eb8921c5b660ab09237c26e83e300ddcd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Tue, 11 Jan 2011 14:26:50 +0100 Subject: [PATCH 03/24] tentative 1 de faire marcher java. --- compiler/obc/java/java.ml | 200 +++++++----------- .../obc/java/{javamain.ml => java_main.ml} | 0 2 files changed, 79 insertions(+), 121 deletions(-) rename compiler/obc/java/{javamain.ml => java_main.ml} (100%) diff --git a/compiler/obc/java/java.ml b/compiler/obc/java/java.ml index 1e6b895..57c2517 100644 --- a/compiler/obc/java/java.ml +++ b/compiler/obc/java/java.ml @@ -13,6 +13,7 @@ open Modules open Format open Obc open Misc +open Types open Names open Idents open Pp_tools @@ -38,48 +39,20 @@ let print_name ff name = let print_shortname ff longname = print_name ff (shortname longname) -let o_types : type_dec list ref = ref [] - -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" +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 -> - 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 + (match find_type t with + | Tabstract -> assert false + | 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" let print_type ff ty = let jty,_ = java_type_default_value ty in @@ -125,7 +98,7 @@ let rec print_tags ff n = function | [] -> () | tg :: tgs' -> fprintf ff "@ public static final int %a = %d;" - print_name tg + print_name ( shortname tg ) (* TODO java deal with modules *) n; print_tags ff (n+1) tgs' @@ -135,28 +108,30 @@ let print_enum_type ff tn tgs = print_tags ff 1 tgs; fprintf ff "@]@ }@]" -let print_type_to_file java_dir headers { t_name = tn; t_desc = td} = - let tn = jname_of_name tn in +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 "/*" "*/"; + (*Misc.print_header_info ff "/*" "*/"; *) List.iter (fprintf ff "%s") headers; - (* fprintf ff "@[package %s;@\n@\n" headers; *) + (* fprintf ff "@[package %s;@\n@\n" headers; *) (* TODO java deal with modules *) print_enum_type ff tn tgs; fprintf ff "@."; close_out out_ch | Type_struct fields -> let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in let ff = formatter_of_out_channel out_ch in - Misc.print_header_info ff "/*" "*/"; + (* Misc.print_header_info ff "/*" "*/"; *)(* TODO java deal with modules *) List.iter (fprintf ff "%s") headers; (* fprintf ff "@[package %s;@\n@\n" headers; *) - print_struct_type ff tn fields; + 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 @@ -168,26 +143,17 @@ type answer = | 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 + 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 @@ -225,20 +191,21 @@ let priority = function | _ -> 0 let rec print_lhs ff e avs single = - match e with - | Var x -> + match e.pat_desc with + | Lvar x -> print_var ff x avs single - | Mem x -> print_ident ff x - | Field(e, field) -> + | 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 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) -> + match e.e_desc with + | Elhs 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,_) -> @@ -249,6 +216,8 @@ let rec print_exp ff e p avs ts single = print_shortname type_name; 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 @@ -277,7 +246,7 @@ and print_op ff op es p avs ts single = | "~-", [e] -> fprintf ff "-"; print_exp ff e 6 avs ts single; - | _ -> + | _ ->(* begin begin match op with @@ -291,7 +260,8 @@ and print_op ff op es p avs ts single = fprintf ff "@[("; print_exps ff es 0 avs ts single; fprintf ff ")@]" - end + end *) + assert false (* TODO java *) let rec print_proj ff xs ao avs single = let rec walk ind = function @@ -309,18 +279,18 @@ let bool_case = function | ("false", _) :: _ -> true | _ -> false -let obj_call_to_string = function - | Context o - | Array_context (o,_) -> o +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 - | Assgn (x, e) -> + | Aassgn (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 + | Acall (xs,oref,Mstep,es) -> + let o = obj_ref_to_string oref in (match xs with | [x] -> print_lhs ff x avs single; @@ -330,7 +300,7 @@ let rec print_act ff a objs avs ts single = fprintf ff "@]"; fprintf ff ");@ " | xs -> - let cn = (List.find (fun od -> od.obj = o) objs).cls in + 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; @@ -340,13 +310,7 @@ let rec print_act ff a objs 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) -> + | Acase (e, grds) -> let grds = List.map (fun (ln,act) -> (shortname ln),act) grds in @@ -356,13 +320,17 @@ let rec print_act ff a objs avs ts single = (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 -> () + | Acall (_,oref,Mreset,_) -> + 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 = match grds with | [] -> () - | [(tg, act)] -> + | (tg, b) :: grds' -> (* retrieve class name *) let cn = (fst (List.find @@ -372,19 +340,7 @@ and print_grds ff grds objs avs ts single = fprintf ff "@[case %a.%a:@ " print_name cn print_name tg; - print_act ff act objs avs ts single; - fprintf ff "@ break;@]"; - | (tg, act) :: grds' -> - (* retrieve class name *) - let cn = (fst - (List.find - (fun (tn, tgs) -> - List.exists (fun tg' -> tg = tg') tgs) - ts)) in - fprintf ff "@[case %a.%a:@ " - print_name cn - print_name tg; - print_act ff act objs avs ts single; + print_block ff b objs avs ts single; fprintf ff "@ break;@ @]@ "; print_grds ff grds' objs avs ts single @@ -393,26 +349,26 @@ and print_if ff e grds objs avs ts single = | [("true", a)] -> fprintf ff "@[@[if (%a) {@ " (fun ff e -> print_exp ff e 0 avs ts single) e; - print_act ff a objs avs ts single; + print_block ff a objs avs ts single; fprintf ff "@]@ }@]" | [("false", a)] -> fprintf ff "@[@[if (!%a) {@ " (fun ff e -> print_exp ff e 6 avs ts single) e; - print_act ff a objs avs ts single; + print_block ff a objs avs ts single; fprintf ff "@]@ }@]" | [("true", a1); ("false", a2)] -> fprintf ff "@[@[if (%a) {@ " (fun ff e -> print_exp ff e 0 avs ts single) e; - print_act ff a1 objs avs ts single; + print_block ff a1 objs avs ts single; fprintf ff "@]@ @[} else {@ "; - print_act ff a2 objs avs ts single; + print_block ff a2 objs avs ts single; fprintf ff "@]@ }@]" | [("false", a2); ("true", a1)] -> fprintf ff "@[@[if (%a) {@ " (fun ff e -> print_exp ff e 0 avs ts single) e; - print_act ff a1 objs avs ts single; + print_block ff a1 objs avs ts single; fprintf ff "@]@ @[} else {@ "; - print_act ff a2 objs avs ts single; + print_block ff a2 objs avs ts single; fprintf ff "@]@ }@]" | _ -> assert false @@ -423,6 +379,8 @@ and print_asgn ff x e avs ts single = 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 "@["; @@ -435,9 +393,9 @@ let print_vd ff vd = let print_obj ff od = fprintf ff "@["; fprintf ff "%a %a = new %a();" - print_shortname od.cls - print_name od.obj - print_shortname od.cls; + print_shortname od.o_class + print_name od.o_name + print_shortname od.o_class; fprintf ff "@]" let rec print_objs ff ods = @@ -488,14 +446,14 @@ let rec print_mem ff = function 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 + let n = jname_of_name n in fprintf ff "@[@ @[public "; - if single then print_type ff (List.hd s.out).v_type + 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.inp; + print_in ff s.m_inputs; fprintf ff "@]) {@ "; - let loc = if single then (List.hd s.out) :: s.local else s.local in + 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; diff --git a/compiler/obc/java/javamain.ml b/compiler/obc/java/java_main.ml similarity index 100% rename from compiler/obc/java/javamain.ml rename to compiler/obc/java/java_main.ml From ed214627065976b937455e1385300e677668b723 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Tue, 11 Jan 2011 14:27:29 +0100 Subject: [PATCH 04/24] Add java to the compiling process. --- compiler/minils/main/mls2seq.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/compiler/minils/main/mls2seq.ml b/compiler/minils/main/mls2seq.ml index c41e56e..c05df1f 100644 --- a/compiler/minils/main/mls2seq.ml +++ b/compiler/minils/main/mls2seq.ml @@ -15,7 +15,7 @@ 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) @@ -39,6 +39,7 @@ let write_obc_file p = comment "Generation of Obc code" let targets = [ "c", Obc_no_params Cmain.program; + "java", Obc_no_params Java_main.program; "obc", Obc write_obc_file; "obc_np", Obc_no_params write_obc_file; "epo", Minils write_object_file ] From fc08753bd9b7c4c1b9f9cd2d58a73189937f4f51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Le=CC=81onard=20Ge=CC=81rard?= Date: Tue, 11 Jan 2011 14:46:28 +0100 Subject: [PATCH 05/24] tentative 1 de async dans C --- compiler/obc/c/c.mli | 2 ++ compiler/obc/c/cgen.ml | 48 +++++++++++++++++++++++++--------------- compiler/obc/c/csubst.ml | 1 + 3 files changed, 33 insertions(+), 18 deletions(-) diff --git a/compiler/obc/c/c.mli b/compiler/obc/c/c.mli index cee66f0..5e9a817 100644 --- a/compiler/obc/c/c.mli +++ b/compiler/obc/c/c.mli @@ -25,6 +25,7 @@ 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 *) (** A C block: declarations and statements. In source code form, it begins with variable declarations before a list of semicolon-separated statements, the @@ -48,6 +49,7 @@ and cexpr = | 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. *) diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 20ede8c..9c68c4c 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -103,7 +103,7 @@ let rec ctype_of_otype oty = ctype_of_otype ty) | Tprod _ -> assert false | Tunit -> assert false - | Tasync _ -> assert false (* TODO async *) + | Tasync (a,ty) -> Cty_future (ctype_of_otype ty) let cvarlist_of_ovarlist vl = let cvar_of_ovar vd = @@ -289,8 +289,8 @@ let rec cexpr_of_exp var_env exp = Cstructlit (ctyn, cexps) | Earray e_list -> Carraylit (cexprs_of_exps var_env e_list) - | Ebang _ -> - (* TODO async *) assert false + | 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 @@ -309,7 +309,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 @@ -474,6 +474,19 @@ let rec cstm_of_act var_env obj_env act = [Cfor(name x, int_of_static_exp i1, int_of_static_exp i2, cstm_of_act_list var_env obj_env act)] + (** Special case for x = 0^n^n...*) + | Aassgn (vn, { e_desc = Econst c }) -> + let vn = clhs_of_lhs var_env vn in + create_affect_const var_env vn c + + (** Purely syntactic translation from an Obc local variable to a C + local one, with recursive translation of the rhs expression. *) + | Aassgn (vn, e) -> + let vn = clhs_of_lhs var_env vn in + let ty = assoc_type_lhs vn var_env in + 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) -> @@ -494,20 +507,17 @@ let rec cstm_of_act var_env obj_env act = [Csexpr (Cfun_call (classn ^ "_reset", elt ))] )] ) - | Aasync_call _ -> assert false (* TODO async *) - - (** Special case for x = 0^n^n...*) - | Aassgn (vn, { e_desc = Econst c }) -> - let vn = clhs_of_lhs var_env vn in - create_affect_const var_env vn c - - (** Purely syntactic translation from an Obc local variable to a C - local one, with recursive translation of the rhs expression. *) - | Aassgn (vn, e) -> - let vn = clhs_of_lhs var_env vn in - let ty = assoc_type_lhs vn var_env in - let ce = cexpr_of_exp var_env e in - create_affect_stm vn ce ty + | 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 @@ -517,6 +527,8 @@ 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 diff --git a/compiler/obc/c/csubst.ml b/compiler/obc/c/csubst.ml index 71829ab..4ac69af 100644 --- a/compiler/obc/c/csubst.ml +++ b/compiler/obc/c/csubst.ml @@ -41,6 +41,7 @@ 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) From df469db394cdb651055e80cc8736bcce761343a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Thu, 20 Jan 2011 23:05:18 +0100 Subject: [PATCH 06/24] New Java backend closing --- compiler/global/global_printer.ml | 2 + compiler/global/idents.mli | 6 +- compiler/global/names.ml | 1 + compiler/global/types.ml | 10 +- compiler/heptagon/transformations/every.ml | 4 +- compiler/heptagon/transformations/present.ml | 1 + compiler/heptagon/transformations/reset.ml | 12 +- compiler/main/mls2obc.ml | 144 ++--- compiler/minils/main/mls2seq.ml | 2 +- compiler/minils/transformations/itfusion.ml | 6 +- compiler/minils/transformations/normalize.ml | 2 +- compiler/obc/c/c.ml | 27 +- compiler/obc/c/c.mli | 5 +- compiler/obc/java/java.ml | 599 +++---------------- compiler/obc/java/java_main.ml | 5 + compiler/obc/java/java_printer.ml | 150 +++++ compiler/obc/java/obc2java.ml | 263 ++++++++ compiler/obc/java/old_java.ml | 546 +++++++++++++++++ compiler/obc/obc.ml | 27 +- compiler/obc/obc_printer.ml | 8 +- compiler/utilities/misc.ml | 2 +- todo.txt | 2 + 22 files changed, 1174 insertions(+), 650 deletions(-) create mode 100644 compiler/obc/java/java_printer.ml create mode 100644 compiler/obc/java/obc2java.ml create mode 100644 compiler/obc/java/old_java.ml diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index 118b800..e4145ec 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -13,6 +13,8 @@ let print_qualname ff qn = match qn with | { 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 print_shortname ff {name = n} = print_name ff n + let print_async ff async = match async with | None -> () | Some () -> fprintf ff "async " diff --git a/compiler/global/idents.mli b/compiler/global/idents.mli index ee1ab96..a8c6282 100644 --- a/compiler/global/idents.mli +++ b/compiler/global/idents.mli @@ -2,6 +2,7 @@ open Names (** This modules manages unique identifiers, + /!\ To be effective, [enter_node] has to be called when entering a node [gen_fresh] generates an identifier [name] returns a unique name (inside its node) from an identifier. *) @@ -11,7 +12,7 @@ type ident (** Type to be used for local variables *) type var_ident = ident -(** Comparision on idents with the same properties as [Pervasives.compare] *) +(** Comparison on idents with the same properties as [Pervasives.compare] *) val ident_compare : ident -> ident -> int (** Get the full name of an identifier (it is guaranteed to be unique) *) @@ -21,6 +22,9 @@ val name : ident -> string generate a fresh ident with a sweet [name]. It should be used to define a [fresh] function specific to a pass. *) val gen_fresh : string -> ('a -> string) -> 'a -> ident + +(** [gen_var pass_name name] + generates a fresh ident with a sweet [name] *) val gen_var : string -> string -> ident (** [ident_of_name n] returns an identifier corresponding diff --git a/compiler/global/names.ml b/compiler/global/names.ml index 2fe3877..dd31ee7 100644 --- a/compiler/global/names.ml +++ b/compiler/global/names.ml @@ -34,6 +34,7 @@ module S = Set.Make (struct type t = string let compare = compare end) let shortname { name = n; } = n +let qualname { qual = n; } = n let fullname { qual = qual; name = n; } = qual ^ "." ^ n diff --git a/compiler/global/types.ml b/compiler/global/types.ml index dc5e453..53b3aea 100644 --- a/compiler/global/types.ml +++ b/compiler/global/types.ml @@ -29,13 +29,13 @@ 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 - | Tasync of async_t * 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 [] +let invalid_type = Tprod [] (** Invalid type given to untyped expression etc. *) let prod = function | [] -> assert false diff --git a/compiler/heptagon/transformations/every.ml b/compiler/heptagon/transformations/every.ml index d6a6b2c..bcf6ae0 100644 --- a/compiler/heptagon/transformations/every.ml +++ b/compiler/heptagon/transformations/every.ml @@ -16,10 +16,10 @@ let edesc funs (v,acc_eq_list) ed = let ed, (v, acc_eq_list) = Hept_mapfold.edesc funs (v,acc_eq_list) ed in match ed with | Eapp (op, e_list, Some re) when not (is_var re) -> - let re, vre, eqre = Reset.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 + let re, vre, eqre = Reset.bool_var_from_exp re in Eiterator(it, op, n, e_list, Some re), (vre::v, eqre::acc_eq_list) | _ -> ed, (v, acc_eq_list) diff --git a/compiler/heptagon/transformations/present.ml b/compiler/heptagon/transformations/present.ml index 1223a56..0d811d5 100644 --- a/compiler/heptagon/transformations/present.ml +++ b/compiler/heptagon/transformations/present.ml @@ -7,6 +7,7 @@ (* *) (**************************************************************************) (* removing present statements *) + open Heptagon open Hept_mapfold diff --git a/compiler/heptagon/transformations/reset.ml b/compiler/heptagon/transformations/reset.ml index 6e7055e..8720a43 100644 --- a/compiler/heptagon/transformations/reset.ml +++ b/compiler/heptagon/transformations/reset.ml @@ -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 @@ -82,7 +82,7 @@ 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 diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index b47870c..161c03d 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -14,15 +14,14 @@ open Idents open Signature open Obc open Types -open Control open Static open Obc_mapfold open Initial + let fresh_it () = Idents.gen_var "mls2obc" "i" -let gen_obj_name n = - (shortname n) ^ "_mem" ^ (gen_symbol ()) +let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst") let op_from_string op = { qual = "Pervasives"; name = op; } @@ -56,7 +55,7 @@ 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 [] @@ -71,7 +70,7 @@ 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 -> Elhs (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 -> @@ -116,25 +115,22 @@ let rec translate map e = 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 lhs = Control.var_from_name map x in + [Acase (mk_exp (Elhs lhs), 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 = fresh_it () in let cpt2 = fresh_it () in - let x = var_from_name map x in + let x = Control.var_from_name map x in (match e1.Minils.e_ty, e2.Minils.e_ty with | Tarray (_, n1), Tarray (_, n2) -> let e1 = translate map e1 in @@ -154,36 +150,23 @@ and translate_act map pat in [a1; a2] | _ -> assert false ) - - | Minils.Evarpat x, - Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; - Minils.a_params = [n] }, [e], _) -> + | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; Minils.a_params = [n] }, [e], _) -> let cpt = 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], _) -> + [ Afor (cpt, mk_static_int 0, n, + mk_block [Aassgn (mk_lhs (Larray (Control.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 e = translate map e in - let idx = mk_exp (Eop (op_from_string "+", - [mk_evar cpt; - mk_exp (Econst idx1) ])) in + let idx = mk_exp (Eop (op_from_string "+", [mk_evar cpt; mk_exp (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 + [ 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_block [Aassgn (mk_lhs (Larray (Control.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 = 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 @@ -191,13 +174,9 @@ and translate_act map pat Aassgn (x, mk_exp (Elhs (lhs_of_idx_list (lhs_of_exp e1) idx))) 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]; - pfalse, mk_block [false_act] ]) ] - - | Minils.Evarpat x, - Minils.Eapp ({ Minils.a_op = Minils.Eupdate }, - e1::e2::idx, _) -> - let x = var_from_name map x in + [ Acase (cond, [ ptrue, mk_block [true_act]; pfalse, mk_block [false_act] ]) ] + | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eupdate }, e1::e2::idx, _) -> + let x = Control.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, @@ -208,17 +187,14 @@ and translate_act map pat [copy; action] | 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 + let action = Aassgn (mk_lhs (Lfield (x, f)), translate map e2) in [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; @@ -229,14 +205,21 @@ 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) + +let size_from_call_context c = match c with + | None -> None + | Some oa -> Some (oa.oa_size) + +let empty_call_context = None (** [si] is the initialization actions used in the reset method. [j] obj decs @@ -247,12 +230,12 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } 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 + 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, _) -> @@ -273,7 +256,7 @@ 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) -> @@ -281,11 +264,11 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } 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 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 @@ -295,22 +278,22 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } 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 call_context = Some { oa_index = mk_lhs (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 + 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 = @@ -323,10 +306,8 @@ and mk_node_call map call_context app loc name_list args = [], [], [], [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_lhs (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 } -> @@ -350,9 +331,9 @@ 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 @@ -456,20 +437,19 @@ let translate_node Minils.n_params = params; Minils.n_loc = loc; } as n) = + Idents.enter_node f; 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 + 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 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 s = Control.joinlist (s_list @ s_list') in let j = j' @ j in - let si = joinlist (si @ si') in + 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 diff --git a/compiler/minils/main/mls2seq.ml b/compiler/minils/main/mls2seq.ml index c05df1f..519ff6e 100644 --- a/compiler/minils/main/mls2seq.ml +++ b/compiler/minils/main/mls2seq.ml @@ -38,7 +38,7 @@ let write_obc_file p = close_out obc; comment "Generation of Obc code" -let targets = [ "c", Obc_no_params Cmain.program; +let targets = [ (*"c", Obc_no_params Cmain.program;*) "java", Obc_no_params Java_main.program; "obc", Obc write_obc_file; "obc_np", Obc_no_params write_obc_file; diff --git a/compiler/minils/transformations/itfusion.ml b/compiler/minils/transformations/itfusion.ml index 6e7c0e3..d36c3d6 100644 --- a/compiler/minils/transformations/itfusion.ml +++ b/compiler/minils/transformations/itfusion.ml @@ -9,13 +9,13 @@ open Minils (* Functions to temporarily store anonymous nodes*) let mk_fresh_node_name () = Modules.fresh_value "itfusion" "temp" -let fresh_vd_of_arg = +let fresh_vd_of_arg a = Idents.gen_fresh "itfusion" (fun a -> match a.a_name with | None -> "v" - | Some n -> n) + | Some n -> n) a -let fresh_var = Idents.gen_fresh "itfusion" (fun () -> "x") +let fresh_var () = Idents.gen_var "itfusion" "x" let anon_nodes = ref QualEnv.empty diff --git a/compiler/minils/transformations/normalize.ml b/compiler/minils/transformations/normalize.ml index 6fd38f4..9fcab15 100644 --- a/compiler/minils/transformations/normalize.ml +++ b/compiler/minils/transformations/normalize.ml @@ -132,7 +132,7 @@ let const e c = (* normal form for expressions and equations: *) (* - e ::= op(e,...,e) | x | C | e when C(x) *) (* - act ::= e | merge x (C1 -> act) ... (Cn -> act) | (act,...,act) *) -(* - eq ::= [x = v fby e] | [pat = act ] | [pat = f(e1,...,en) every n *) +(* - eq ::= [x = v fby e] | [pat = act] | [pat = f(e1,...,en) every n *) (* - A-normal form: (e1,...,en) when c(x) = (e1 when c(x),...,en when c(x) *) type kind = VRef | Exp | Act | Any diff --git a/compiler/obc/c/c.ml b/compiler/obc/c/c.ml index 7805387..e5e5bb8 100644 --- a/compiler/obc/c/c.ml +++ b/compiler/obc/c/c.ml @@ -12,14 +12,7 @@ open List open Modules open Names -let rec print_list ff print sep l = - match l with - | [] -> () - | [x] -> print ff x - | x :: l -> - print ff x; - fprintf ff "%s@ " sep; - print_list ff print sep l +let print_list ff print sep l = Pp_tools.print_list_r print "" sep "" ff l (** [cname_of_name name] translates the string [name] to a valid C identifier. Copied verbatim from the old C backend. *) @@ -56,6 +49,7 @@ 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 *) (** A C block: declarations and statements. In source code form, it begins with variable declarations before a list of semicolon-separated statements, the @@ -81,19 +75,20 @@ 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, ...\]]. *) + | 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. *) | 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. **) @@ -179,6 +174,7 @@ let rec pp_cty fmt cty = match cty with | Cty_ptr cty' -> fprintf fmt "%a*" pp_cty cty' | Cty_arr (n, cty') -> fprintf fmt "%a[%d]" pp_cty cty' n | Cty_void -> fprintf fmt "void" + | Cty_future cty' -> fprintf fmt "future<%a>" pp_cty cty' (** [pp_array_decl cty] returns the base type of a (multidimensionnal) array and the string of indices. *) @@ -249,7 +245,9 @@ and pp_cexpr fmt ce = match ce with | 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 *) + 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 | Cderef lhs' -> fprintf fmt "*%a" pp_clhs lhs' @@ -314,11 +312,10 @@ let pp_cfile_desc fmt filen cfile = let output_cfile dir (filen, cfile_desc) = if !Compiler_options.verbose then Format.printf "C-NG generating %s/%s@." dir filen; - let buf = Buffer.create 20000 in let oc = open_out (Filename.concat dir filen) in - let fmt = Format.formatter_of_buffer buf in + let fmt = Format.formatter_of_out_channel oc in pp_cfile_desc fmt filen cfile_desc; - Buffer.output_buffer oc buf; + pp_print_flush fmt (); close_out oc let output dir cprog = diff --git a/compiler/obc/c/c.mli b/compiler/obc/c/c.mli index 5e9a817..58d522c 100644 --- a/compiler/obc/c/c.mli +++ b/compiler/obc/c/c.mli @@ -46,9 +46,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, ...\]]. *) | Cmethod_call of cexpr * string * cexpr list (** Object member function call with parameters. *) and cconst = | Ccint of int (** Integer constant. *) diff --git a/compiler/obc/java/java.ml b/compiler/obc/java/java.ml index 57c2517..21c76b2 100644 --- a/compiler/obc/java/java.ml +++ b/compiler/obc/java/java.ml @@ -7,540 +7,103 @@ (* *) (**************************************************************************) +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 Types -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 + | 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_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 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" ) - | Tasync (a,t) -> assert false (* TODO async *) - | Tarray _ -> assert false (* TODO array *) - | Tprod _ -> assert false (* TODO java *) - | Tunit -> "void", "null" +and protection = Ppublic | Pprotected | Pprivate | Ppackage -let print_type ff ty = - let jty,_ = java_type_default_value ty in - print_name ff jty +and field = { f_protection : protection; + f_static : bool; + f_final : bool; + f_type : ty; + f_name : field_ident; + f_value : exp option } -let print_field ff (name,ty) = - fprintf ff "%a %a;" - print_type ty - print_name name - -let print_const_field ff (name,ty) = - fprintf ff "%a@ %a" - print_type ty - print_name name - -let print_assgt_field ff (name,_) = - fprintf ff "this.%a = %a;" - print_name name - print_name name - -(* assumes tn is already translated with jname_of_name *) -let print_struct_type ff tn fields = - fprintf ff "@[@[public class %s {@ " tn; - (* fields *) - print_list print_field "" "" "" ff fields; - (* constructor *) - let sorted_fields = - List.sort - (fun (n1,_) (n2,_) -> String.compare n1 n2) - fields in - fprintf ff "@ @[public %s(@[" tn; - print_list print_const_field "" "," "" ff sorted_fields; - fprintf ff "@]) {@ "; - (* constructor assignments *) - print_list print_assgt_field "" "" "" ff fields; - (* constructor end *) - fprintf ff "@]@ }"; - (* class end *) - fprintf ff "@]@ }@]" +and methode = { m_protection : protection; + m_static : bool; + m_name : method_name; + m_args : var_dec list; + m_returns : ty; + m_body : block; } -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' +and block = { b_locals : var_dec list; + b_body : act list; } -(* assumes tn is already translated with jname_of_name *) -let print_enum_type ff tn tgs = - fprintf ff "@[@[public class %s {" tn; - print_tags ff 1 tgs; - fprintf ff "@]@ }@]" +and act = Anewvar of var_dec * exp + | Aassgn of pattern * exp + | Amethod_call of pattern * 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_ident * exp * exp * block + | Areturn of exp -let rec print_type_to_file java_dir headers { t_name = tn; t_desc = td} = - let tn = jname_of_name (shortname tn) in (* TODO java deal with modules *) - match td with - | Type_abs -> () - | Type_enum tgs -> - let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in - let ff = formatter_of_out_channel out_ch in - (*Misc.print_header_info ff "/*" "*/"; *) - List.iter (fprintf ff "%s") headers; - (* fprintf ff "@[package %s;@\n@\n" headers; *) (* TODO java deal with modules *) - print_enum_type ff tn tgs; - fprintf ff "@."; - close_out out_ch - | Type_struct fields -> - let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in - let ff = formatter_of_out_channel out_ch in - (* Misc.print_header_info ff "/*" "*/"; *)(* TODO java deal with modules *) - List.iter (fprintf ff "%s") headers; - (* fprintf ff "@[package %s;@\n@\n" headers; *) - print_struct_type ff tn - (List.map (fun {f_name = n;f_type = t} -> (shortname n,t)) fields); (* TODO java deal with modules *) - fprintf ff "@."; - close_out out_ch - | Type_alias t -> assert false (* TODO java *) +and exp = Eval of pattern + | Efun of op_name * exp list + | Emethod_call of pattern * method_name * exp list + | Enew of ty * exp list + | Evoid (*printed as nothing*) + | Earray of exp list + | Svar of const_name + | Sint of int + | Sfloat of float + | Sbool of bool + | Sconstructor of constructor_name -let print_types java_dir headers tps = - List.iter (print_type_to_file java_dir headers) tps +and pattern = Pfield of pattern * field_name + | Pvar of var_ident + | Parray_elem of pattern * exp + | Pthis of field_ident -(******************************) +type program = classe list -type answer = - | Sing of var_ident - | Mult of var_ident list +let mk_methode ?(protection=Ppublic) ?(static=false) ?(args=[]) ?(returns=Tunit) + body name = + { m_protection = protection; m_static = static; m_name = name; m_args = args; m_returns = returns; m_body = body; } -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 mk_classe ?(protection=Ppublic) ?(static=false) ?(fields=[]) ?(classes=[]) ?(constrs=[]) ?(methodes=[]) + class_name = + { c_protection = protection; c_static = static; c_name = class_name; + c_kind = Cgeneric { cd_fields = fields; cd_classs = classes; cd_constructors = constrs; cd_methodes = methodes; } } -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 - | Elhs l -> print_lhs ff l avs single - | Econst c -> print_const ff c ts - | Eop (op, es) -> print_op ff op es p avs ts single - | Estruct (type_name,fields) -> - let fields = - List.sort - (fun (ln1,_) (ln2,_) -> - String.compare (shortname ln1) (shortname ln2)) - fields in - let exps = List.map (fun (_,e) -> e) fields in - fprintf ff "new %a(@[" - print_shortname type_name; - print_exps ff exps 0 avs ts single; - fprintf ff "@])" - | Earray _ -> assert false (* TODO array *) - | Ebang _ -> assert false (* TODO async *) - -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 mk_enum ?(protection=Ppublic) ?(static=false) + constructor_names class_name = + { c_protection = protection; c_static = static; c_name = class_name; c_kind = Cenum(constructor_names) } -let bool_case = function - | [] -> assert false - | ("true", _) :: _ - | ("false", _) :: _ -> true - | _ -> false - -let obj_ref_to_string = function - | Oobj o -> o - | Oarray (o,p) -> o (* TODO java array *) - -let rec print_act ff a objs avs ts single = - match a with - | Aassgn (x, e) -> - fprintf ff "@["; - print_asgn ff x e avs ts single; - fprintf ff ";@]" - | Acall (xs,oref,Mstep,es) -> - let o = obj_ref_to_string oref in - (match xs with - | [x] -> - print_lhs ff x avs single; - fprintf ff " = %s.step(" o; - fprintf ff "@["; - print_exps ff es 0 avs ts single; - fprintf ff "@]"; - fprintf ff ");@ " - | xs -> - let cn = (List.find (fun od -> od.o_name = o) objs).o_class in - let at = (jname_of_name (shortname cn)) ^ "Answer" in - let ao = o ^ "_ans" in - fprintf ff "%s %s = new %s();@ " at ao at; - fprintf ff "%s = %s.step(" ao o; - fprintf ff "@["; - print_exps ff es 0 avs ts single; - fprintf ff "@]"; - fprintf ff ");@ "; - print_proj ff xs ao avs single) - | Acase (e, grds) -> - let grds = - List.map - (fun (ln,act) -> (shortname ln),act) grds in - if bool_case grds - then print_if ff e grds objs avs ts single - else (fprintf ff "@[@[switch (%a) {@ " - (fun ff e -> print_exp ff e 0 avs ts single) e; - print_grds ff grds objs avs ts single; - fprintf ff "@]@ }@]"); - | Acall (_,oref,Mreset,_) -> - let o = obj_ref_to_string oref in - fprintf ff "%s.reset();" o - | Afor _ -> assert false (* TODO java array *) - | Aasync_call _ -> assert false (* TODO java array *) - - -and print_grds ff grds objs avs ts single = - match grds with - | [] -> () - | (tg, b) :: grds' -> - (* retrieve class name *) - let cn = (fst - (List.find - (fun (tn, tgs) -> - List.exists (fun tg' -> tg = tg') tgs) - ts)) in - fprintf ff "@[case %a.%a:@ " - print_name cn - print_name tg; - print_block ff b objs avs ts single; - fprintf ff "@ break;@ @]@ "; - print_grds ff grds' objs avs ts single - -and print_if ff e grds objs avs ts single = - match grds with - | [("true", a)] -> - fprintf ff "@[@[if (%a) {@ " - (fun ff e -> print_exp ff e 0 avs ts single) e; - print_block ff a objs avs ts single; - fprintf ff "@]@ }@]" - | [("false", a)] -> - fprintf ff "@[@[if (!%a) {@ " - (fun ff e -> print_exp ff e 6 avs ts single) e; - print_block ff a objs avs ts single; - fprintf ff "@]@ }@]" - | [("true", a1); ("false", a2)] -> - fprintf ff "@[@[if (%a) {@ " - (fun ff e -> print_exp ff e 0 avs ts single) e; - print_block ff a1 objs avs ts single; - fprintf ff "@]@ @[} else {@ "; - print_block ff a2 objs avs ts single; - fprintf ff "@]@ }@]" - | [("false", a2); ("true", a1)] -> - fprintf ff "@[@[if (%a) {@ " - (fun ff e -> print_exp ff e 0 avs ts single) e; - print_block ff a1 objs avs ts single; - fprintf ff "@]@ @[} else {@ "; - print_block ff a2 objs avs ts single; - fprintf ff "@]@ }@]" - | _ -> assert false - -and print_asgn ff x e avs ts single = - fprintf ff "@["; - print_lhs ff x avs single; - fprintf ff " = "; - print_exp ff e 0 avs ts single; - fprintf ff "@]" - -and print_block ff b objs avs ts single = () (* TODO urgent java *) - -let print_vd ff vd = - let jty,jdv = java_type_default_value vd.v_type in - fprintf ff "@["; - print_name ff jty; - fprintf ff " %s = %s;" - (jname_of_name (name vd.v_ident)) - jdv; - fprintf ff "@]" - -let print_obj ff od = - fprintf ff "@["; - fprintf ff "%a %a = new %a();" - print_shortname od.o_class - print_name od.o_name - print_shortname od.o_class; - fprintf ff "@]" - -let rec print_objs ff ods = - match ods with - | [] -> () - | od :: ods' -> - print_obj ff od; - fprintf ff "@ "; - print_objs ff ods' - -let print_comps ff fds= - let rec walk n = function - | [] -> () - | fd :: fds' -> - fprintf ff "@ "; - fprintf ff "public "; - print_type ff fd.v_type; - fprintf ff " c_%s;" (string_of_int n); - walk (n + 1) fds' - in walk 1 fds - -let print_ans_struct ff name fields = - fprintf ff "@[@[public class %s {" name; - print_comps ff fields; - fprintf ff "@]@ }@]@ " - -let print_vd' ff vd = - fprintf ff "@["; - print_type ff vd.v_type; - fprintf ff "@ %s" (jname_of_name (name vd.v_ident)); - fprintf ff "@]" - -let rec print_in ff = function - | [] -> () - | [vd] -> print_vd' ff vd - | vd :: vds' -> - print_vd' ff vd; - fprintf ff ",@ "; - print_in ff vds' - -let rec print_mem ff = function - | [] -> () - | vd :: m' -> - print_vd ff vd; - fprintf ff "@ "; - print_mem ff m' - -let print_loc ff vds = print_mem ff vds - -let print_step ff n s objs ts single = - let n = jname_of_name n in - fprintf ff "@[@ @[public "; - if single then print_type ff (List.hd s.m_outputs).v_type - else fprintf ff "%s" (n ^ "Answer"); - fprintf ff " step(@["; - print_in ff s.m_inputs; - fprintf ff "@]) {@ "; - let loc = if single then (List.hd s.m_outputs) :: s.m_body.b_locals else s.m_body.b_locals in - if loc = [] then () else (print_loc ff loc; fprintf ff "@ "); - if single then fprintf ff "@ " - else fprintf ff "%sAnswer step_ans = new %sAnswer();@ @ " n n; - print_act ff s.bd objs - (List.map (fun vd -> vd.v_ident) s.out) ts single; - fprintf ff "@ @ return "; - if single - then fprintf ff "%s" (jname_of_name (Idents.name (List.hd s.out).v_ident)) - else fprintf ff "step_ans"; - fprintf ff ";@]@ }@ @]" - -let print_reset ff r ts = - fprintf ff "@[@ @[public void reset() {@ "; - print_act ff r [] [] ts false; - fprintf ff "@]@ }@ @]" - -let print_class ff headers ts single opened_mod cl = - let clid = jname_of_name cl.cl_id in - List.iter (fprintf ff "%s") headers; - (* fprintf ff "@[package %s;@\n@\n" headers; *) - (* import opened modules *) - List.iter - (fun m -> - fprintf ff "import %s.*;@\n" (String.uncapitalize m)) - opened_mod; - - fprintf ff "@\n@[public class %s {@ " clid; - if cl.mem = [] then () - else fprintf ff "@[@ "; print_mem ff cl.mem; fprintf ff "@]"; - if cl.objs = [] then () - else fprintf ff "@[@ "; print_objs ff cl.objs; fprintf ff "@]"; - print_reset ff cl.reset ts; - print_step ff clid cl.step cl.objs ts single; - fprintf ff "@]@ }@]" - -let print_class_and_answer_to_file java_dir headers ts opened_mod cl = - let clid = jname_of_name cl.cl_id in - let print_class_to_file single = - let out_ch = open_out (java_dir ^ "/" ^ clid ^ ".java") in - let ff = formatter_of_out_channel out_ch in - Misc.print_header_info ff "/*" "*/"; - print_class ff headers ts single opened_mod cl; - fprintf ff "@."; - close_out out_ch - in - match cl.step.out with - | [_] -> print_class_to_file true - | _ -> - let out_ch = open_out (java_dir ^ "/" ^ clid ^ "Answer.java") in - let ff = formatter_of_out_channel out_ch in - Misc.print_header_info ff "/*" "*/"; - List.iter (fprintf ff "%s") headers; - (* fprintf ff "@[package %s;@\n@\n" headers; *) - List.iter - (fun m -> - fprintf ff "import %s.*;@\n" (String.uncapitalize m)) - opened_mod; - print_ans_struct ff (clid ^ "Answer") cl.step.out; - fprintf ff "@."; - close_out out_ch; - print_class_to_file false - -let print_classes java_dir headers ts opened_mod cls = - List.iter - (print_class_and_answer_to_file java_dir headers ts opened_mod) - cls - -(******************************) -let print java_dir p = - let headers = - List.map snd - (List.filter - (fun (tag,_) -> tag = "java") - p.o_pragmas) in - print_types java_dir headers p.o_types; - o_types := p.o_types; - print_classes - java_dir headers - (List.flatten - (List.map - (function - | { t_desc = Type_abs } -> [] - | { t_name = tn; t_desc = Type_enum tgs } -> [tn, tgs] - | { t_name = tn; t_desc = Type_struct fields } -> - [tn, (List.map fst fields)]) - p.o_types)) - p.o_opened - p.o_defs - -(******************************) +let mk_field ?(protection = Ppublic) ?(static = false) ?(final = false) ?(value = None) + ty name = + { f_protection = protection; f_static = static; f_final = final; f_type = ty; f_name = name; f_value = value } diff --git a/compiler/obc/java/java_main.ml b/compiler/obc/java/java_main.ml index e83e6c5..402c4ef 100644 --- a/compiler/obc/java/java_main.ml +++ b/compiler/obc/java/java_main.ml @@ -1,4 +1,9 @@ +open Java +open Java_printer +open Obc2java + + let program p = let filename = filename_of_module p in let dirname = build_path filename in diff --git a/compiler/obc/java/java_printer.ml b/compiler/obc/java/java_printer.ml new file mode 100644 index 0000000..be0a6ca --- /dev/null +++ b/compiler/obc/java/java_printer.ml @@ -0,0 +1,150 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* Java printer *) + +open Java +open Pp_tools +open Format + +let 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 op_name = Global_printer.print_qualname (* TODO java fix this for infix etc... see others is_infix and old_java *) +let var_ident = Global_printer.print_ident +let const_name = Global_printer.print_qualname + +let rec ty 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,_) -> fprintf ff "%a[]" ty t + | Tunit -> pp_print_string ff "void" + +let protection ff = function + | Ppublic -> fprintf ff "public " + | Pprotected -> fprintf ff "protected " + | Pprivate -> fprintf ff "private " + | Ppackage -> () + +let var_dec ff vd = fprintf ff "%a %a" ty vd.vd_type var_ident vd.vd_ident + +let vd_list s1 s2 s3 ff vd_l = print_list_r var_dec s1 s2 s3 ff vd_l + +let static ff s = if s then fprintf ff "static " else () + +let final ff f = if f then fprintf ff "final " else () + +let rec 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_name + (print_opt2 exp " =@ ") f.f_value + +and exp ff = function + | Eval p -> pattern ff p + | Efun (f,e_l) -> fprintf ff "%a@[%a@]" op_name f args e_l + | Emethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" pattern o method_name m args e_l + | Enew (c,e_l) -> fprintf ff "new %a%a" ty c args e_l + | Evoid -> () + | Earray e_l -> fprintf ff "@[<2>%a@]" (print_list_r exp "{"",""}") e_l + | 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 + +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 + | 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 act ff = function + | Anewvar (vd,e) -> fprintf ff "%a = %a" var_dec vd exp e + | Aassgn (p,e) -> fprintf ff "%a = %a" pattern p exp e + | Amethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" pattern o method_name m args e_l + | Aswitch (e, c_b_l) -> + let pcb ff (c,b) = fprintf ff "@[case %a:@ %a@ break;@]" bare_constructor_name c block b in + fprintf ff "@[switch (%a) {@ %a@]@\n}" + exp e + (print_list_r pcb """""") c_b_l + | Aif (e,bt) -> + fprintf ff "@[<2>if (%a) {@ %a@ }@]" exp e block bt + | Aifelse (e,bt,bf) -> + fprintf ff "@[<2>if (%a) {@ %a@ }@]@\n@[<2>else {@ %a@ }@]" + exp e + block bt + block bf + | Ablock b -> fprintf ff "@[<2>{@ %a@ }]" block b + | Afor (x, i1, i2, b) -> + fprintf ff "@[<2>for %a = %a to %a {@ %a@ }@]" + var_ident x + exp i1 + exp i2 + block b + | Areturn e -> fprintf ff "return %a" exp e + +let methode ff m = + fprintf ff "@[<4>%a%a%a %a @[<2>%a@] {@\n%a@]@\n}" + protection m.m_protection + static m.m_static + ty m.m_returns + method_name m.m_name + (vd_list "("","")") m.m_args + block m.m_body + +let rec class_desc ff cd = + let pm = print_list methode """""" in + fprintf ff "@[%a@ %a@ %a@ %a@]" + (print_list_r field """;"";") cd.cd_fields + (print_list_r classe """""") cd.cd_classs + pm cd.cd_constructors + pm cd.cd_methodes + +and classe ff c = match c.c_kind with + | Cenum c_l -> + fprintf ff "@[<4>%a%aenum %a {@\n%a@]@\n}" + protection c.c_protection + static c.c_static + class_name c.c_name + (print_list_r bare_constructor_name """,""") c_l + | Cgeneric cd -> + fprintf ff "@[<4>%a%aclass %a {@\n%a@]@\n}" + protection c.c_protection + static c.c_static + class_name c.c_name + class_desc cd + +let output_classe dir c = + let { Names.name = file_name; Names.qual = package_name } = c.c_name in + let file_name = file_name ^ ".java" in + let oc = open_out (Filename.concat dir file_name) in + let ff = Format.formatter_of_out_channel oc in + fprintf ff "package %s;@\n" package_name; + classe ff c; + pp_print_flush ff (); + close_out oc + diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml new file mode 100644 index 0000000..a6894c6 --- /dev/null +++ b/compiler/obc/java/obc2java.ml @@ -0,0 +1,263 @@ +(**************************************************************************) +(* *) +(* 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 *) + +open Format +open Misc +open Names +open Modules +open Signature +open Obc +open Java + + +(** a [Module] becomes a [package] *) +let translate_qualname q = match q with + | { qual = "Pervasives" } -> q + | { qual = m } when m = g_env.current_mod -> q (* current module is not translated to keep track, + there is no issue since printed without the qualifier *) + | { qual = m } when m = local_qualname -> q + | _ -> { q with qual = String.lowercase q.qual } + +(** a [Module.const] becomes a [module.CONSTANTES.CONST] *) +let translate_const_name q = + let q = translate_qualname q in + { qual = q.qual ^ ".CONSTANTES"; name = String.uppercase q.name } + +(** a [Module.name] becomes a [module.Name] + used for type_names, class_names, fun_names *) +let qualname_to_class_name q = + let q = translate_qualname q in + { q with name = String.capitalize q.name } + +(** a [Module.Constr] of an [Module.enum] type becomes a [module.Enum.CONSTR] of the [module.Enum] class *) +let _translate_constructor_name q q_ty = + let classe = qualname_to_class_name q_ty in + let classe_name = classe.qual ^ "." ^ classe.name in + let constr = { qual = classe_name; name = q |> shortname |> String.uppercase } in + constr + +let translate_constructor_name q = + match Modules.find_constrs c with + | Tid c_ty -> _translate_constructor_name q q_ty + | _ -> assert false + +(** a [name] becomes a [package.Name] *) +let name_to_classe_name n = n |> Modules.current_qual |> qualname_to_class_name + +(** translate an ostatic_exp into an jexp *) +let rec static_exp param_env se = match se.Types.se_desc with + | Types.Svar c -> + if shortname c = local_qualname + then let n = NamesEnv.find (shortname c) param_env in Svar (n |> Idents.name |> local_qn) + else 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 -> assert false; + | Types.Stuple t -> assert false; (* TODO java ?? not too dificult if needed, return Tuplen<..>() *) + | Types.Sarray_power _ -> assert false; (* TODO java array *) + | Types.Sarray se_l -> Earray (List.map (static_exp param_env) se_l) + | Types.Srecord _ -> 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 -> + let ln = ty_l |> List.length |> Pervasives.char_of_int |> (String.make 1) in + Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_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.Tasync _ -> assert false; (* TODO async *) + | Types.Tunit -> Tunit + +and ty param_env t :Java.ty = match t with + | Types.Tprod ty_l -> + let ln = ty_l |> List.length |> Pervasives.char_of_int |> (String.make 1) in + Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_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.Tasync _ -> assert false; (* TODO async *) + | Types.Tunit -> Tunit + + +let var_dec_list param_env vd_l = + let _vd vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident } in + List.map _vd vd_l + +let act_list param_env act_l = + let _act acts act = 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, call) in + assgn::acts + | Obc.Acall (p_l, obj, _, 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 copies = Misc.mapi (fun i p -> Aassgn (p, Eval (Pfield (return_id, "c"^(string_of_int i))))) p_l in + assgn::(copies@acts) + | Obc.Acall (_, obj, Mreset, _) -> + let acall = Amethod_call (obj_ref param_env obj, "step", []) in + acall::acts + | Obc.Async_call _ -> assert false (* TODO java async *) + | Obc.Acase (e, c_b_l) -> + let _c_b (c,b) = translate_constructor_name + Aswitch (exp param_env e, + +let 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 bacts = act_list param_env ob.Obc.b_body in + let acts = end_acts @ bacts in + { b_locals = locals; b_body = acts } + +let class_def_list classes cd_l = + let class_def classes cd = + Idents.enter_node cd.cd_name; + let class_name = qualname_to_class_name cd.cd_name in + (* [param_env] is an env mapping local param name to ident *) + let constructeur, param_env = + let param_to_arg param_env p = + let p_ident = Idents.gen_var "obc2java" 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 + let args, param_env = Misc.mapfold param_to_arg NamesEnv.empty cd.cd_params in + let body = + (* TODO java array : also initialize arrays with [ new int[3] ] *) + let final_field_init_act arg = Aassgn (Pthis arg.vd_ident, Eval (Pvar arg.vd_ident)) in + let obj_init_act acts od = + let params = List.map (static_exp param_env) od.o_params in + let act = match od.o_size with + | None -> Aassgn (Pthis od.o_ident, Enew (Tclass od.o_class, params)) + | Some size -> assert false; (* TODO java : + Aassgn (Pthis od.o_ident, Enew ( Tarray, Earray [Enew (Tclass, params)... ] ) ) cf node.java*) + in + act::acts + in + let acts = List.map final_field_init_act args in + let acts = List.fold_left obj_init_act acts cd.cd_objs in + { b_locals = []; b_body = acts } + in + mk_methode ~args:args body (shortname class_name), param_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 = (* TODO [o_params] are treated in the [reset] code *) + let jty = match od.o_size with + | None -> Tclass (qualname_to_class_name od.o_class) + | Some size -> Tarray (Tclass (qualname_to_class_name od.o_class), static_exp param_env size) + in + (mk_field ~protection:Pprotected jty od.o_ident) :: fields + in + let params_to_field fields p = + let p_ident = NamesEnv.find p.p_name param_env in + (mk_field ~protection:Pprotected ~final:true (ty param_env p.p_type) p_ident) :: fields + in + let fields = List.fold_left mem_to_field [] cd.cd_mems in + let fields = List.fold_left obj_to_field fields cd.cd_objs in + List.fold_left params_to_field fields cd.cd_params + 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.m_body in + mk_methode ~args:(var_dec_list ostep.m_inputs) ~returns:jreturn_ty body "step" + in + let reset = + let oreset = find_reset_method cd in + let body = block param_env oreset.m_body in + mk_methode body "reset" + in + let classe = mk_classe ~fields=fields ~constrs=[constructeur] ~methodes=[step;reset] class_name in + classe::classes + in + List.fold_left classe_def classes cd_l + + +let type_dec_list classes td_l = + let param_env = NamesEnv.empty in + let _td classes td = + let classe_name = td.t_name |> qualname_to_class_name |> Names.shortname in + let classe, jty = match td.t_desc with + | Type_abs -> eprintf "Abstract types not supported in Java backend"; assert false (* TODO java *) + | Type_alias ot -> classes + | Type_enum c_l -> + let mk_constr_enum oc = + let jc = _translate_constructor_name oc td.t_name in + add_constr_name oc jc; + jc + in + (mk_enum (List.map mk_constr_enum oc_l) classe_name) :: classes + | Type_struct f_l -> + let mk_field_jfield { f_name = oname; f_type = oty } = + let jty = ty param_env oty in + let name = oname |> Names.shortname |> String.lowercase in + add_Field_name oname name; + mk_field jty name + in + (mk_classe ~fields:(List.map mk_field_jfield f_l) classe_name) :: classes + in + add_type_name td.t_name jty; + classes + in + List.fold_left classes _td + + +let const_dec_list cd_l = + 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 in + let value = static_exp ovalue in + let t = ty param_env otype in + mk_field ~static:true ~final:true ~value:value t name + in + match cd_l with + | [] -> [] + | _ -> + let classe_name = "CONSTANTES" |> name_to_classe_name |> shortname 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_defs in + p + + + diff --git a/compiler/obc/java/old_java.ml b/compiler/obc/java/old_java.ml new file mode 100644 index 0000000..57c2517 --- /dev/null +++ b/compiler/obc/java/old_java.ml @@ -0,0 +1,546 @@ +(**************************************************************************) +(* *) +(* 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" ) + | Tasync (a,t) -> assert false (* TODO async *) + | Tarray _ -> assert false (* TODO array *) + | Tprod _ -> assert false (* TODO java *) + | Tunit -> "void", "null" + +let print_type ff ty = + let jty,_ = java_type_default_value ty in + print_name ff jty + +let print_field ff (name,ty) = + fprintf ff "%a %a;" + print_type ty + print_name name + +let print_const_field ff (name,ty) = + fprintf ff "%a@ %a" + print_type ty + print_name name + +let print_assgt_field ff (name,_) = + fprintf ff "this.%a = %a;" + print_name name + print_name name + +(* assumes tn is already translated with jname_of_name *) +let print_struct_type ff tn fields = + fprintf ff "@[@[public class %s {@ " tn; + (* fields *) + print_list print_field "" "" "" ff fields; + (* constructor *) + let sorted_fields = + List.sort + (fun (n1,_) (n2,_) -> String.compare n1 n2) + fields in + fprintf ff "@ @[public %s(@[" tn; + print_list print_const_field "" "," "" ff sorted_fields; + fprintf ff "@]) {@ "; + (* constructor assignments *) + print_list print_assgt_field "" "" "" ff fields; + (* constructor end *) + fprintf ff "@]@ }"; + (* class end *) + fprintf ff "@]@ }@]" + + +let rec print_tags ff n = function + | [] -> () + | tg :: tgs' -> + fprintf ff "@ public static final int %a = %d;" + print_name ( shortname tg ) (* TODO java deal with modules *) + n; + print_tags ff (n+1) tgs' + +(* assumes tn is already translated with jname_of_name *) +let print_enum_type ff tn tgs = + fprintf ff "@[@[public class %s {" tn; + print_tags ff 1 tgs; + fprintf ff "@]@ }@]" + +let rec print_type_to_file java_dir headers { t_name = tn; t_desc = td} = + let tn = jname_of_name (shortname tn) in (* TODO java deal with modules *) + match td with + | Type_abs -> () + | Type_enum tgs -> + let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in + let ff = formatter_of_out_channel out_ch in + (*Misc.print_header_info ff "/*" "*/"; *) + List.iter (fprintf ff "%s") headers; + (* fprintf ff "@[package %s;@\n@\n" headers; *) (* TODO java deal with modules *) + print_enum_type ff tn tgs; + fprintf ff "@."; + close_out out_ch + | Type_struct fields -> + let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in + let ff = formatter_of_out_channel out_ch in + (* Misc.print_header_info ff "/*" "*/"; *)(* TODO java deal with modules *) + List.iter (fprintf ff "%s") headers; + (* fprintf ff "@[package %s;@\n@\n" headers; *) + print_struct_type ff tn + (List.map (fun {f_name = n;f_type = t} -> (shortname n,t)) fields); (* TODO java deal with modules *) + fprintf ff "@."; + close_out out_ch + | Type_alias t -> assert false (* TODO java *) + +let print_types java_dir headers tps = + List.iter (print_type_to_file java_dir headers) tps + +(******************************) + +type answer = + | Sing of var_ident + | Mult of var_ident list + +let print_const ff c ts = + match c.se_desc with + | Sint i -> fprintf ff "%d" i + | Sfloat f -> fprintf ff "%f" f + | Sbool true -> fprintf ff "true" + | Sbool false -> fprintf ff "false" + | Sconstructor c -> + let tg = shortname c in (* TODO java gérer les modules *) + let s = (fst (List.find (fun (tn, tgs) -> List.exists (fun tg' -> tg = tg') tgs) ts)) + ^ "." ^ (jname_of_name tg) in + fprintf ff "%s" s + | _ -> assert false (* TODO java *) + +let position a xs = + let rec walk i = function + | [] -> None + | x :: xs' -> if x = a then Some i else walk (i + 1) xs' + in walk 1 xs + +let print_ident ff id = + print_name ff (name id) + +let print_var ff x avs single = + match (position x avs) with + | None -> print_ident ff x + | Some n -> + if single then print_ident ff (List.hd avs) + else fprintf ff "step_ans.c_%d" n + +let javaop_of_op = function + | "=" -> "==" + | "<>" -> "!=" + | "or" -> "||" + | "&" -> "&&" + | "*." -> "*" + | "/." -> "/" + | "+." -> "+" + | "-." -> "-" + | op -> op + +let priority = function + | "*" | "/" | "*." | "/." -> 5 + | "+" | "-" | "+." | "-." -> 4 + | "=" | "<>" | "<=" | "=>" -> 3 + | "&" -> 2 + | "|" -> 1 + | _ -> 0 + +let rec print_lhs ff e avs single = + match e.pat_desc with + | Lvar x -> + print_var ff x avs single + | Lmem x -> print_ident ff x + | Lfield(e, field) -> + print_lhs ff e avs single; + fprintf ff ".%s" (jname_of_name (shortname field)) + | Larray _ -> assert false (* TODO java array *) + +let rec print_exp ff e p avs ts single = + match e.e_desc with + | Elhs l -> print_lhs ff l avs single + | Econst c -> print_const ff c ts + | Eop (op, es) -> print_op ff op es p avs ts single + | Estruct (type_name,fields) -> + let fields = + List.sort + (fun (ln1,_) (ln2,_) -> + String.compare (shortname ln1) (shortname ln2)) + fields in + let exps = List.map (fun (_,e) -> e) fields in + fprintf ff "new %a(@[" + print_shortname type_name; + print_exps ff exps 0 avs ts single; + fprintf ff "@])" + | Earray _ -> assert false (* TODO array *) + | Ebang _ -> assert false (* TODO async *) + +and print_exps ff es p avs ts single = + match es with + | [] -> () + | [e] -> print_exp ff e p avs ts single + | e :: es' -> + print_exp ff e p avs ts single; + fprintf ff ",@ "; + print_exps ff es' p avs ts single + +and print_op ff op es p avs ts single = + match (shortname op), es with + | (("+" | "-" | "*" | "/" + |"+." | "-." | "*." | "/." + | "=" | "<>" | "<" | "<=" + | ">" | ">=" | "&" | "or") as op_name, [e1;e2]) -> + let p' = priority op_name in + if p' < p then fprintf ff "(" else (); + print_exp ff e1 p' avs ts single; + fprintf ff " %s " (javaop_of_op op_name); + print_exp ff e2 p' avs ts single; + if p' < p then fprintf ff ")" else () + | "not", [e] -> + fprintf ff "!"; + print_exp ff e 6 avs ts single; + | "~-", [e] -> + fprintf ff "-"; + print_exp ff e 6 avs ts single; + | _ ->(* + begin + begin + match op with + | Name(op_name) -> + print_name ff op_name; + | Modname({ qual = mod_name; id = op_name }) -> + fprintf ff "%a.%a" + print_name (String.uncapitalize mod_name) + print_name op_name + end; + fprintf ff "@[("; + print_exps ff es 0 avs ts single; + fprintf ff ")@]" + end *) + assert false (* TODO java *) + +let rec print_proj ff xs ao avs single = + let rec walk ind = function + | [] -> () + | x :: xs' -> + print_lhs ff x avs single; + fprintf ff " = %s.c_%d;@ " ao ind; + walk (ind + 1) xs' + in walk 1 xs + + +let bool_case = function + | [] -> assert false + | ("true", _) :: _ + | ("false", _) :: _ -> true + | _ -> false + +let obj_ref_to_string = function + | Oobj o -> o + | Oarray (o,p) -> o (* TODO java array *) + +let rec print_act ff a objs avs ts single = + match a with + | Aassgn (x, e) -> + fprintf ff "@["; + print_asgn ff x e avs ts single; + fprintf ff ";@]" + | Acall (xs,oref,Mstep,es) -> + let o = obj_ref_to_string oref in + (match xs with + | [x] -> + print_lhs ff x avs single; + fprintf ff " = %s.step(" o; + fprintf ff "@["; + print_exps ff es 0 avs ts single; + fprintf ff "@]"; + fprintf ff ");@ " + | xs -> + let cn = (List.find (fun od -> od.o_name = o) objs).o_class in + let at = (jname_of_name (shortname cn)) ^ "Answer" in + let ao = o ^ "_ans" in + fprintf ff "%s %s = new %s();@ " at ao at; + fprintf ff "%s = %s.step(" ao o; + fprintf ff "@["; + print_exps ff es 0 avs ts single; + fprintf ff "@]"; + fprintf ff ");@ "; + print_proj ff xs ao avs single) + | Acase (e, grds) -> + let grds = + List.map + (fun (ln,act) -> (shortname ln),act) grds in + if bool_case grds + then print_if ff e grds objs avs ts single + else (fprintf ff "@[@[switch (%a) {@ " + (fun ff e -> print_exp ff e 0 avs ts single) e; + print_grds ff grds objs avs ts single; + fprintf ff "@]@ }@]"); + | Acall (_,oref,Mreset,_) -> + let o = obj_ref_to_string oref in + fprintf ff "%s.reset();" o + | Afor _ -> assert false (* TODO java array *) + | Aasync_call _ -> assert false (* TODO java array *) + + +and print_grds ff grds objs avs ts single = + match grds with + | [] -> () + | (tg, b) :: grds' -> + (* retrieve class name *) + let cn = (fst + (List.find + (fun (tn, tgs) -> + List.exists (fun tg' -> tg = tg') tgs) + ts)) in + fprintf ff "@[case %a.%a:@ " + print_name cn + print_name tg; + print_block ff b objs avs ts single; + fprintf ff "@ break;@ @]@ "; + print_grds ff grds' objs avs ts single + +and print_if ff e grds objs avs ts single = + match grds with + | [("true", a)] -> + fprintf ff "@[@[if (%a) {@ " + (fun ff e -> print_exp ff e 0 avs ts single) e; + print_block ff a objs avs ts single; + fprintf ff "@]@ }@]" + | [("false", a)] -> + fprintf ff "@[@[if (!%a) {@ " + (fun ff e -> print_exp ff e 6 avs ts single) e; + print_block ff a objs avs ts single; + fprintf ff "@]@ }@]" + | [("true", a1); ("false", a2)] -> + fprintf ff "@[@[if (%a) {@ " + (fun ff e -> print_exp ff e 0 avs ts single) e; + print_block ff a1 objs avs ts single; + fprintf ff "@]@ @[} else {@ "; + print_block ff a2 objs avs ts single; + fprintf ff "@]@ }@]" + | [("false", a2); ("true", a1)] -> + fprintf ff "@[@[if (%a) {@ " + (fun ff e -> print_exp ff e 0 avs ts single) e; + print_block ff a1 objs avs ts single; + fprintf ff "@]@ @[} else {@ "; + print_block ff a2 objs avs ts single; + fprintf ff "@]@ }@]" + | _ -> assert false + +and print_asgn ff x e avs ts single = + fprintf ff "@["; + print_lhs ff x avs single; + fprintf ff " = "; + print_exp ff e 0 avs ts single; + fprintf ff "@]" + +and print_block ff b objs avs ts single = () (* TODO urgent java *) + +let print_vd ff vd = + let jty,jdv = java_type_default_value vd.v_type in + fprintf ff "@["; + print_name ff jty; + fprintf ff " %s = %s;" + (jname_of_name (name vd.v_ident)) + jdv; + fprintf ff "@]" + +let print_obj ff od = + fprintf ff "@["; + fprintf ff "%a %a = new %a();" + print_shortname od.o_class + print_name od.o_name + print_shortname od.o_class; + fprintf ff "@]" + +let rec print_objs ff ods = + match ods with + | [] -> () + | od :: ods' -> + print_obj ff od; + fprintf ff "@ "; + print_objs ff ods' + +let print_comps ff fds= + let rec walk n = function + | [] -> () + | fd :: fds' -> + fprintf ff "@ "; + fprintf ff "public "; + print_type ff fd.v_type; + fprintf ff " c_%s;" (string_of_int n); + walk (n + 1) fds' + in walk 1 fds + +let print_ans_struct ff name fields = + fprintf ff "@[@[public class %s {" name; + print_comps ff fields; + fprintf ff "@]@ }@]@ " + +let print_vd' ff vd = + fprintf ff "@["; + print_type ff vd.v_type; + fprintf ff "@ %s" (jname_of_name (name vd.v_ident)); + fprintf ff "@]" + +let rec print_in ff = function + | [] -> () + | [vd] -> print_vd' ff vd + | vd :: vds' -> + print_vd' ff vd; + fprintf ff ",@ "; + print_in ff vds' + +let rec print_mem ff = function + | [] -> () + | vd :: m' -> + print_vd ff vd; + fprintf ff "@ "; + print_mem ff m' + +let print_loc ff vds = print_mem ff vds + +let print_step ff n s objs ts single = + let n = jname_of_name n in + fprintf ff "@[@ @[public "; + if single then print_type ff (List.hd s.m_outputs).v_type + else fprintf ff "%s" (n ^ "Answer"); + fprintf ff " step(@["; + print_in ff s.m_inputs; + fprintf ff "@]) {@ "; + let loc = if single then (List.hd s.m_outputs) :: s.m_body.b_locals else s.m_body.b_locals in + if loc = [] then () else (print_loc ff loc; fprintf ff "@ "); + if single then fprintf ff "@ " + else fprintf ff "%sAnswer step_ans = new %sAnswer();@ @ " n n; + print_act ff s.bd objs + (List.map (fun vd -> vd.v_ident) s.out) ts single; + fprintf ff "@ @ return "; + if single + then fprintf ff "%s" (jname_of_name (Idents.name (List.hd s.out).v_ident)) + else fprintf ff "step_ans"; + fprintf ff ";@]@ }@ @]" + +let print_reset ff r ts = + fprintf ff "@[@ @[public void reset() {@ "; + print_act ff r [] [] ts false; + fprintf ff "@]@ }@ @]" + +let print_class ff headers ts single opened_mod cl = + let clid = jname_of_name cl.cl_id in + List.iter (fprintf ff "%s") headers; + (* fprintf ff "@[package %s;@\n@\n" headers; *) + (* import opened modules *) + List.iter + (fun m -> + fprintf ff "import %s.*;@\n" (String.uncapitalize m)) + opened_mod; + + fprintf ff "@\n@[public class %s {@ " clid; + if cl.mem = [] then () + else fprintf ff "@[@ "; print_mem ff cl.mem; fprintf ff "@]"; + if cl.objs = [] then () + else fprintf ff "@[@ "; print_objs ff cl.objs; fprintf ff "@]"; + print_reset ff cl.reset ts; + print_step ff clid cl.step cl.objs ts single; + fprintf ff "@]@ }@]" + +let print_class_and_answer_to_file java_dir headers ts opened_mod cl = + let clid = jname_of_name cl.cl_id in + let print_class_to_file single = + let out_ch = open_out (java_dir ^ "/" ^ clid ^ ".java") in + let ff = formatter_of_out_channel out_ch in + Misc.print_header_info ff "/*" "*/"; + print_class ff headers ts single opened_mod cl; + fprintf ff "@."; + close_out out_ch + in + match cl.step.out with + | [_] -> print_class_to_file true + | _ -> + let out_ch = open_out (java_dir ^ "/" ^ clid ^ "Answer.java") in + let ff = formatter_of_out_channel out_ch in + Misc.print_header_info ff "/*" "*/"; + List.iter (fprintf ff "%s") headers; + (* fprintf ff "@[package %s;@\n@\n" headers; *) + List.iter + (fun m -> + fprintf ff "import %s.*;@\n" (String.uncapitalize m)) + opened_mod; + print_ans_struct ff (clid ^ "Answer") cl.step.out; + fprintf ff "@."; + close_out out_ch; + print_class_to_file false + +let print_classes java_dir headers ts opened_mod cls = + List.iter + (print_class_and_answer_to_file java_dir headers ts opened_mod) + cls + +(******************************) +let print java_dir p = + let headers = + List.map snd + (List.filter + (fun (tag,_) -> tag = "java") + p.o_pragmas) in + print_types java_dir headers p.o_types; + o_types := p.o_types; + print_classes + java_dir headers + (List.flatten + (List.map + (function + | { t_desc = Type_abs } -> [] + | { t_name = tn; t_desc = Type_enum tgs } -> [tn, tgs] + | { t_name = tn; t_desc = Type_struct fields } -> + [tn, (List.map fst fields)]) + p.o_types)) + p.o_opened + p.o_defs + +(******************************) diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index 7b7107a..fd14d1a 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -16,12 +16,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 } @@ -56,8 +56,8 @@ and exp_desc = | Ebang of exp 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 @@ -80,10 +80,10 @@ and var_dec = 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 = @@ -147,6 +147,17 @@ let rec vd_find n = function | 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.p_type) p_l) + let lhs_of_exp e = match e.e_desc with | Elhs l -> l | _ -> assert false diff --git a/compiler/obc/obc_printer.ml b/compiler/obc/obc_printer.ml index 4d7c8e5..19188fe 100644 --- a/compiler/obc/obc_printer.ml +++ b/compiler/obc/obc_printer.ml @@ -14,7 +14,7 @@ let print_vd ff vd = fprintf ff "@]" let print_obj ff o = - fprintf ff "@["; print_name ff o.o_name; + fprintf ff "@["; print_ident ff o.o_ident; fprintf ff " : "; print_qualname ff o.o_class; fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "<<"","">>") o.o_params; (match o.o_size with @@ -67,10 +67,10 @@ 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 @@ -90,7 +90,7 @@ let rec print_act ff a = print_tag_act_list ff tag_act_list; fprintf ff "@]@,}@]" | Afor(x, i1, i2, act_list) -> - fprintf ff "@[@[for %s = %a to %a {@, %a @]@,}@]" + fprintf ff "@[@[for %s = %a to %a {@ %a @]@,}@]" (name x) print_static_exp i1 print_static_exp i2 diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index 553a28c..e82a18d 100644 --- a/compiler/utilities/misc.ml +++ b/compiler/utilities/misc.ml @@ -112,7 +112,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) diff --git a/todo.txt b/todo.txt index a8e0378..f60a48f 100644 --- a/todo.txt +++ b/todo.txt @@ -1,6 +1,8 @@ Plus ou moins ordonné du plus urgent au moins urgent. +*- 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. From 09419a77a5ab3605b7d97dee2e87d949f0fce55d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 24 Jan 2011 16:07:26 +0100 Subject: [PATCH 07/24] again --- compiler/global/global_printer.ml | 1 + compiler/global/initial.ml | 10 +- compiler/global/types.ml | 5 + compiler/main/mls2obc.ml | 214 +++++++++++++++--------------- compiler/minils/main/mls2seq.ml | 2 +- compiler/minils/mls_utils.ml | 7 +- compiler/obc/c/cgen.ml | 4 +- compiler/obc/control.ml | 4 +- compiler/obc/java/java.ml | 12 +- compiler/obc/java/java_main.ml | 8 +- compiler/obc/java/java_printer.ml | 35 +++-- compiler/obc/java/obc2java.ml | 174 +++++++++++++++--------- compiler/obc/java/old_java.ml | 2 +- compiler/obc/obc.ml | 40 ++++-- compiler/obc/obc_mapfold.ml | 4 +- compiler/obc/obc_printer.ml | 6 +- compiler/utilities/misc.ml | 11 ++ compiler/utilities/misc.mli | 6 + test/check | 24 ++-- test/good/t5.ept | 1 - todo.txt | 2 + 21 files changed, 346 insertions(+), 226 deletions(-) diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index e4145ec..cd2f1cc 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -48,6 +48,7 @@ and print_static_exp_tuple ff l = fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l and print_type ff = function + | Tprod [] -> fprintf ff "INVALID TYPE" | Tprod ty_list -> fprintf ff "@[%a@]" (print_list_r print_type "(" " *" ")") ty_list | Tid id -> print_qualname ff id diff --git a/compiler/global/initial.ml b/compiler/global/initial.ml index 000fec4..b5d5f87 100644 --- a/compiler/global/initial.ml +++ b/compiler/global/initial.ml @@ -15,22 +15,26 @@ let tglobal = [] let cglobal = [] 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_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) diff --git a/compiler/global/types.ml b/compiler/global/types.ml index 53b3aea..036e99f 100644 --- a/compiler/global/types.ml +++ b/compiler/global/types.ml @@ -42,6 +42,11 @@ let prod = function | [ty] -> ty | ty_list -> Tprod ty_list +let unprod = function + | Tprod l -> l + | t -> [t] + + let asyncify async ty_list = match async with | None -> ty_list | Some a -> List.map (fun ty -> Tasync (a,ty)) ty_list diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 161c03d..d2709e6 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -19,21 +19,29 @@ open Obc_mapfold open Initial -let fresh_it () = Idents.gen_var "mls2obc" "i" +let fresh_it () = + let id = Idents.gen_var "mls2obc" "i" in + id, mk_var_dec id Initial.tint let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst") let op_from_string op = { qual = "Pervasives"; name = op; } -let rec lhs_of_idx_list e = function - | [] -> e | idx :: l -> mk_lhs (Larray (lhs_of_idx_list e l, idx)) +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] @@ -41,15 +49,11 @@ let array_elt_of_exp idx e = e1 <= n1 && .. && ep <= np *) 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, []) @@ -70,7 +74,7 @@ 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 (Control.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 -> @@ -85,17 +89,17 @@ 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) + 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 @@ -105,11 +109,12 @@ let rec translate map e = | 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@." + (*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 + 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 @@ -124,54 +129,53 @@ and translate_act map pat | pat, Minils.Ewhen (e, _, _) -> translate_act map pat e | pat, Minils.Emerge (x, c_act_list) -> - let lhs = Control.var_from_name map x in - [Acase (mk_exp (Elhs lhs), translate_c_act_list map pat c_act_list)] + 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 = fresh_it () in - let cpt2 = fresh_it () in + 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 t (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 t (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 + 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 (Control.var_from_name map x, mk_evar cpt)), e) ]) ] + let x = Control.var_from_name map x in + [ Afor (cptd, mk_static_int 0, n, mk_block [Aassgn (mk_pattern x.pat_ty (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 = fresh_it () in + 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 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 (Control.var_from_name map x, mk_evar cpt)), - mk_lhs_exp (Larray (lhs_of_exp e, idx)))] ) ] + [ 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 x.pat_ty (Larray (x, mk_evar_int cpt)), + mk_pattern_exp e.e_ty (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]; pfalse, mk_block [false_act] ]) ] @@ -179,7 +183,7 @@ and translate_act map pat let x = Control.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 @@ -190,8 +194,8 @@ and translate_act map pat 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 + [copy; action] | Minils.Evarpat n, _ -> [Aassgn (Control.var_from_name map n, translate map act)] @@ -233,7 +237,7 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } 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 + | 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 @@ -258,12 +262,10 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } pfalse, mk_block ~locals:vf false_act]) in 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 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 _ -> @@ -275,12 +277,10 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } | pat, Minils.Eiterator (it, app, n, 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 = Some { oa_index = mk_lhs (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 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 xd 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 @@ -299,18 +299,18 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } 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 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 @@ -346,61 +346,66 @@ and mk_node_call map call_context app loc name_list args = [], 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 - let array_of_input c_list = - List.map (array_elt_of_exp (mk_lhs (Lvar x))) c_list in - +and translate_iterator map call_context it name_list app loc n x xd 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.map (fun l -> mk_pattern ty (Larray (l, mk_evar_int x))) name_list (* TODO not ty, but Tprod (ti...) -> ti *) + in + let array_of_input c_list = 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 v, si, j, action = mk_node_call map call_context - app loc name_list c_list in + let ty_list = Types.unprod ty in + let name_list = array_of_output name_list ty_list in + let node_out_ty = Types.prod (List.map unarray ty_list) in + let v, si, j, action = mk_node_call map call_context app loc name_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) ] + si, 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 ty_list = Types.unprod ty 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 name_list = array_of_output name_list ty_list in + let node_out_ty = Types.prod (Misc.map_butlast unarray ty_list) in + let v, si, j, action = mk_node_call map call_context app loc (name_list @ [ acc_out ]) + (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)] + si, 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 (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) ] + si, 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 + (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) ] + si, 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 @@ -408,23 +413,22 @@ 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 ({ @@ -438,15 +442,15 @@ let translate_node Minils.n_loc = loc; } as n) = Idents.enter_node f; - 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 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_vars contract 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 + (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 = Control.joinlist (si @ si') in diff --git a/compiler/minils/main/mls2seq.ml b/compiler/minils/main/mls2seq.ml index 519ff6e..bb6614d 100644 --- a/compiler/minils/main/mls2seq.ml +++ b/compiler/minils/main/mls2seq.ml @@ -39,7 +39,7 @@ let write_obc_file p = comment "Generation of Obc code" let targets = [ (*"c", Obc_no_params Cmain.program;*) - "java", Obc_no_params 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 ] diff --git a/compiler/minils/mls_utils.ml b/compiler/minils/mls_utils.ml index 39a0fb0..8870651 100644 --- a/compiler/minils/mls_utils.ml +++ b/compiler/minils/mls_utils.ml @@ -135,10 +135,15 @@ struct | _ -> [] end +(* Assumes normal form, all fby are solo rhs *) let node_memory_vars n = let eq _ acc ({ eq_lhs = pat; eq_rhs = e } as eq) = match e.e_desc with - | Efby(_, _) -> eq, Vars.vars_pat acc pat + | Efby(_, _) -> + let v_l = Vars.vars_pat [] pat in + let t_l = Types.unprod e.e_ty in + let acc = (List.combine v_l t_l) @ acc in + eq, acc | _ -> eq, acc in let funs = { Mls_mapfold.defaults with eq = eq } in diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 9c68c4c..2c904ad 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -274,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 -> @@ -338,7 +338,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" diff --git a/compiler/obc/control.ml b/compiler/obc/control.ml index c0a86df..8bb2a5c 100644 --- a/compiler/obc/control.ml +++ b/compiler/obc/control.ml @@ -38,12 +38,12 @@ let rec control map ck s = | Cvar { contents = Clink ck } -> control map ck s | Con(ck, c, n) -> let x = var_from_name map n in - control map ck (Acase(mk_exp (Elhs x), [(c, mk_block [s])])) + control map ck (Acase(mk_exp x.pat_ty (Epattern x), [(c, mk_block [s])])) let is_deadcode = function | Aassgn (lhs, e) -> (match e.e_desc with - | Elhs l -> l = lhs + | Epattern l -> l = lhs | _ -> false ) | Acase (_, []) -> true diff --git a/compiler/obc/java/java.ml b/compiler/obc/java/java.ml index 21c76b2..62b3261 100644 --- a/compiler/obc/java/java.ml +++ b/compiler/obc/java/java.ml @@ -68,15 +68,15 @@ and act = Anewvar of var_dec * exp | Aif of exp * block | Aifelse of exp * block * block | Ablock of block - | Afor of var_ident * exp * exp * block + | Afor of var_dec * exp * exp * block (* TODO var_dec *) | Areturn of exp and exp = Eval of pattern | Efun of op_name * exp list | Emethod_call of pattern * method_name * exp list | Enew of ty * exp list + | Enew_array of ty * exp list | Evoid (*printed as nothing*) - | Earray of exp list | Svar of const_name | Sint of int | Sfloat of float @@ -90,6 +90,14 @@ and pattern = Pfield of pattern * field_name type program = classe list +let mk_var x = Eval (Pvar x) + +let mk_var_dec x ty = + { vd_type = ty; vd_ident = x } + +let mk_block ?(locals=[]) b = + { b_locals = locals; b_body = b; } + let mk_methode ?(protection=Ppublic) ?(static=false) ?(args=[]) ?(returns=Tunit) body name = { m_protection = protection; m_static = static; m_name = name; m_args = args; m_returns = returns; m_body = body; } diff --git a/compiler/obc/java/java_main.ml b/compiler/obc/java/java_main.ml index 402c4ef..1581f86 100644 --- a/compiler/obc/java/java_main.ml +++ b/compiler/obc/java/java_main.ml @@ -2,10 +2,12 @@ open Java open Java_printer open Obc2java +open Compiler_utils let program p = - let filename = filename_of_module p in - let dirname = build_path filename in + let filename = filename_of_name p.Obc.p_modname in + let dirname = build_path (filename ^ "_java") in let dir = clean_dir dirname in - Java.print dir o + let p_java = Obc2java.program p in + output_program dir p_java \ No newline at end of file diff --git a/compiler/obc/java/java_printer.ml b/compiler/obc/java/java_printer.ml index be0a6ca..b512f20 100644 --- a/compiler/obc/java/java_printer.ml +++ b/compiler/obc/java/java_printer.ml @@ -13,6 +13,8 @@ open Java open Pp_tools open Format +(* TODO java faire des vrais qualname recursifs, bare_constructor doit être vraiment bare *) + let class_name = Global_printer.print_shortname let obj_ident = Global_printer.print_ident let constructor_name = Global_printer.print_qualname @@ -54,22 +56,22 @@ let rec field ff f = final f.f_final ty f.f_type field_ident f.f_name - (print_opt2 exp " =@ ") f.f_value + (print_opt2 exp " = ") f.f_value and exp ff = function | Eval p -> pattern ff p | Efun (f,e_l) -> fprintf ff "%a@[%a@]" op_name f args e_l | Emethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" pattern o method_name m args e_l | Enew (c,e_l) -> fprintf ff "new %a%a" ty c args e_l + | Enew_array (t,e_l) -> fprintf ff "new %a@[<2>%a@]" ty t (print_list_r exp "{"",""}") e_l | Evoid -> () - | Earray e_l -> fprintf ff "@[<2>%a@]" (print_list_r exp "{"",""}") e_l | 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 -and args ff e_l = fprintf ff "@[%a@]" (print_list_r exp "("","")") 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 @@ -100,29 +102,37 @@ and act ff = function block bf | Ablock b -> fprintf ff "@[<2>{@ %a@ }]" block b | Afor (x, i1, i2, b) -> - fprintf ff "@[<2>for %a = %a to %a {@ %a@ }@]" - var_ident x + fprintf ff "@[<2>for (%a = %a; %a<%a; %a++) {@ %a@ }@]" + var_dec 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 "@[<4>%a%a%a %a @[<2>%a@] {@\n%a@]@\n}" + fprintf ff "@[<4>%a%a%a %a @[<2>(%a)@] {@\n%a@]@\n}" protection m.m_protection static m.m_static ty m.m_returns method_name m.m_name - (vd_list "("","")") m.m_args + (vd_list """,""") m.m_args + block m.m_body + +let constructor ff m = + fprintf ff "@[<4>%a%a @[<2>(%a)@] {@\n%a@]@\n}" + protection m.m_protection + method_name m.m_name + (vd_list """,""") m.m_args block m.m_body let rec class_desc ff cd = - let pm = print_list methode """""" in fprintf ff "@[%a@ %a@ %a@ %a@]" (print_list_r field """;"";") cd.cd_fields (print_list_r classe """""") cd.cd_classs - pm cd.cd_constructors - pm cd.cd_methodes + (print_list constructor """""") cd.cd_constructors + (print_list methode """""") cd.cd_methodes and classe ff c = match c.c_kind with | Cenum c_l -> @@ -143,8 +153,11 @@ let output_classe dir c = let file_name = file_name ^ ".java" in let oc = open_out (Filename.concat dir file_name) in let ff = Format.formatter_of_out_channel oc in - fprintf ff "package %s;@\n" package_name; + fprintf ff "package %s;@\n" (String.lowercase package_name); classe ff c; pp_print_flush ff (); close_out oc +let output_program dir (p:Java.program) = + List.iter (output_classe dir) p + diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index a6894c6..bee6509 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -24,6 +24,16 @@ open Obc open Java +let fresh_it () = + let id = Idents.gen_var "obc2java" "i" in + id, mk_var_dec id Tint + +(** 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, id = fresh_it () in + Afor (id, Sint 0, size, mk_block (body i)) + + (** a [Module] becomes a [package] *) let translate_qualname q = match q with | { qual = "Pervasives" } -> q @@ -33,9 +43,9 @@ let translate_qualname q = match q with | _ -> { q with qual = String.lowercase q.qual } (** a [Module.const] becomes a [module.CONSTANTES.CONST] *) -let translate_const_name q = - let q = translate_qualname q in - { qual = q.qual ^ ".CONSTANTES"; name = String.uppercase q.name } +let translate_const_name q = match q with + | { qual = m } when m = local_qualname -> { q with name = String.uppercase q.name } + | _ -> { q with qual = (String.lowercase q.qual)^ ".CONSTANTES"; name = String.uppercase q.name } (** a [Module.name] becomes a [module.Name] used for type_names, class_names, fun_names *) @@ -44,17 +54,19 @@ let qualname_to_class_name q = { q with name = String.capitalize q.name } (** a [Module.Constr] of an [Module.enum] type becomes a [module.Enum.CONSTR] of the [module.Enum] class *) -let _translate_constructor_name q q_ty = +let _translate_constructor_name q q_ty = (* TODO java recursive qualname ! *) let classe = qualname_to_class_name q_ty in - let classe_name = classe.qual ^ "." ^ classe.name in - let constr = { qual = classe_name; name = q |> shortname |> String.uppercase } in - constr + let q = qualname_to_class_name q in + { q with name = classe.name ^ "." ^ q.name } let translate_constructor_name q = - match Modules.find_constrs c with - | Tid c_ty -> _translate_constructor_name q q_ty + 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 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_class_name @@ -68,16 +80,17 @@ let rec static_exp param_env se = match se.Types.se_desc with | 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 -> assert false; - | Types.Stuple t -> assert false; (* TODO java ?? not too dificult if needed, return Tuplen<..>() *) - | Types.Sarray_power _ -> assert false; (* TODO java array *) - | Types.Sarray se_l -> Earray (List.map (static_exp param_env) se_l) - | Types.Srecord _ -> assert false; (* TODO java *) + | Types.Sfield f -> eprintf "ojSfield @."; assert false; + | Types.Stuple t -> eprintf "ojStuple@."; assert false; + (* TODO java ?? not too difficult if needed, return Tuplen<..>() *) + | Types.Sarray_power _ -> eprintf "ojSarray_power@."; assert false; (* TODO java array *) + | 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 -> - let ln = ty_l |> List.length |> Pervasives.char_of_int |> (String.make 1) in + let ln = ty_l |> List.length |> Pervasives.string_of_int in Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_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") @@ -89,7 +102,7 @@ and boxed_ty param_env t = match t with and ty param_env t :Java.ty = match t with | Types.Tprod ty_l -> - let ln = ty_l |> List.length |> Pervasives.char_of_int |> (String.make 1) in + let ln = ty_l |> List.length |> Pervasives.string_of_int in Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l) | Types.Tid t when t = Initial.pbool -> Tbool | Types.Tid t when t = Initial.pint -> Tint @@ -99,42 +112,80 @@ and ty param_env t :Java.ty = match t with | Types.Tasync _ -> assert false; (* TODO async *) | Types.Tunit -> Tunit +let var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident } -let var_dec_list param_env vd_l = - let _vd vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident } in - List.map _vd vd_l +let var_dec_list param_env vd_l = List.map (var_dec param_env) vd_l -let act_list param_env act_l = - let _act acts act = match act with +let rec 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) + | Obc.Ebang _ -> eprintf "ojEbang@."; assert false (* TODO java async *) + +and exp_list param_env e_l = List.map (exp param_env) e_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 -> Pvar id + | Oarray (id,p) -> 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, call) in + let assgn = Aassgn (pattern param_env p, ecall) in assgn::acts - | Obc.Acall (p_l, obj, _, 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 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 copies = Misc.mapi (fun i p -> Aassgn (p, Eval (Pfield (return_id, "c"^(string_of_int i))))) p_l in + let copy_return_to_var i p = + Aassgn (pattern param_env p, 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, "step", []) in + let acall = Amethod_call (obj_ref param_env obj, "reset", []) in acall::acts - | Obc.Async_call _ -> assert false (* TODO java async *) + | Obc.Aasync_call _ -> assert false (* TODO java async *) + | 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,b) -> c = Initial.ptrue) c_b_l in + let _, _else = List.find (fun (c,b) -> 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 - Aswitch (exp param_env e, + 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 + in + List.fold_right _act act_l acts -let block param_env ?(locals=[]) ?(end_acts=[]) ob = +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 bacts = act_list param_env ob.Obc.b_body in - let acts = end_acts @ bacts in + let acts = act_list param_env ob.Obc.b_body end_acts in { b_locals = locals; b_body = acts } let class_def_list classes cd_l = @@ -144,7 +195,7 @@ let class_def_list classes cd_l = (* [param_env] is an env mapping local param name to ident *) let constructeur, param_env = let param_to_arg param_env p = - let p_ident = Idents.gen_var "obc2java" p.Signature.p_name in + 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 @@ -156,11 +207,16 @@ let class_def_list classes cd_l = let obj_init_act acts od = let params = List.map (static_exp param_env) od.o_params in let act = match od.o_size with - | None -> Aassgn (Pthis od.o_ident, Enew (Tclass od.o_class, params)) - | Some size -> assert false; (* TODO java : - Aassgn (Pthis od.o_ident, Enew ( Tarray, Earray [Enew (Tclass, params)... ] ) ) cf node.java*) + | None -> [ Aassgn (Pthis od.o_ident, Enew (Tclass od.o_class, params)) ] + | Some size -> + let size = static_exp param_env size in + let assgn_elem i = + [ Aassgn (Parray_elem (Pthis od.o_ident, mk_var i), Enew (Tclass od.o_class, params)) ] + in + [ Aassgn (Pthis od.o_ident, Enew (Tarray (Tclass od.o_class,size), [])); + fresh_for size assgn_elem ] in - act::acts + act@acts in let acts = List.map final_field_init_act args in let acts = List.fold_left obj_init_act acts cd.cd_objs in @@ -170,7 +226,7 @@ let class_def_list classes cd_l = 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 = (* TODO [o_params] are treated in the [reset] code *) + let obj_to_field fields od = let jty = match od.o_size with | None -> Tclass (qualname_to_class_name od.o_class) | Some size -> Tarray (Tclass (qualname_to_class_name od.o_class), static_exp param_env size) @@ -194,61 +250,53 @@ let class_def_list classes cd_l = | [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.m_body in - mk_methode ~args:(var_dec_list ostep.m_inputs) ~returns:jreturn_ty body "step" + 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 reset = let oreset = find_reset_method cd in - let body = block param_env oreset.m_body in + let body = block param_env oreset.Obc.m_body in mk_methode body "reset" in - let classe = mk_classe ~fields=fields ~constrs=[constructeur] ~methodes=[step;reset] class_name in + let classe = mk_classe ~fields:fields ~constrs:[constructeur] ~methodes:[step;reset] class_name in classe::classes in - List.fold_left classe_def classes cd_l + 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 = td.t_name |> qualname_to_class_name |> Names.shortname in - let classe, jty = match td.t_desc with - | Type_abs -> eprintf "Abstract types not supported in Java backend"; assert false (* TODO java *) - | Type_alias ot -> classes + let classe_name = qualname_to_class_name td.t_name in + match td.t_desc with + | Type_abs -> Misc.unsupported "obc2java" 1 (* TODO java *) + | Type_alias ot -> classes (* TODO java alias ?? *) | Type_enum c_l -> - let mk_constr_enum oc = - let jc = _translate_constructor_name oc td.t_name in - add_constr_name oc jc; - jc - in - (mk_enum (List.map mk_constr_enum oc_l) classe_name) :: classes + let mk_constr_enum c = _translate_constructor_name 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 { f_name = oname; f_type = oty } = + let mk_field_jfield { Signature.f_name = oname; Signature.f_type = oty } = let jty = ty param_env oty in - let name = oname |> Names.shortname |> String.lowercase in - add_Field_name oname name; - mk_field jty name + let field = Idents.ident_of_name (translate_field_name oname) in (* TODO java pretty ugly *) + mk_field jty field in (mk_classe ~fields:(List.map mk_field_jfield f_l) classe_name) :: classes - in - add_type_name td.t_name jty; - classes in - List.fold_left classes _td + List.fold_left _td classes td_l let const_dec_list cd_l = 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 in - let value = static_exp ovalue in + let name = oname |> translate_const_name |> shortname |> Idents.ident_of_name in (* TODO java pretty ugly*) + 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 match cd_l with | [] -> [] | _ -> - let classe_name = "CONSTANTES" |> name_to_classe_name |> shortname in + let classe_name = "CONSTANTES" |> name_to_classe_name in let fields = List.map mk_const_field cd_l in [mk_classe ~fields:fields classe_name] diff --git a/compiler/obc/java/old_java.ml b/compiler/obc/java/old_java.ml index 57c2517..149ced0 100644 --- a/compiler/obc/java/old_java.ml +++ b/compiler/obc/java/old_java.ml @@ -202,7 +202,7 @@ let rec print_lhs ff e avs single = let rec print_exp ff e p avs ts single = match e.e_desc with - | Elhs l -> print_lhs ff l avs single + | 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) -> diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index fd14d1a..f07dca6 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -48,7 +48,7 @@ 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 @@ -68,7 +68,7 @@ type act = | 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_ident * static_exp * static_exp * block + | Afor of var_dec * static_exp * static_exp * block and block = { b_locals : var_dec list; @@ -107,21 +107,33 @@ type program = 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_var_dec ?(loc=no_location) ident ty = + { v_ident = ident; v_type = ty; v_loc = loc } -let mk_exp ?(ty=invalid_type) ?(loc=no_location) desc = (* TODO master : remove the invalid_type *) +let mk_exp ?(loc=no_location) ty desc = { 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 *) +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_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_pattern_int ?(loc=no_location) desc = + { pat_desc = desc; pat_ty = Initial.tint; pat_loc = loc } -let mk_evar id = - mk_exp (Elhs (mk_lhs (Lvar id))) +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; @@ -156,10 +168,10 @@ let vd_list_to_type vd_l = match vd_l with let pattern_list_to_type p_l = match p_l with | [] -> Types.Tunit | [p] -> p.pat_ty - | _ -> Tprod (List.map (fun p -> p.p_type) p_l) + | _ -> Tprod (List.map (fun p -> p.pat_ty) p_l) -let lhs_of_exp e = match e.e_desc with - | Elhs l -> l +let pattern_of_exp e = match e.e_desc with + | Epattern l -> l | _ -> assert false let find_step_method cd = diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml index a0c8dd6..9d131a6 100644 --- a/compiler/obc/obc_mapfold.ml +++ b/compiler/obc/obc_mapfold.ml @@ -44,9 +44,9 @@ and edesc_it funs acc ed = try funs.edesc funs acc ed with Fallback -> edesc funs acc ed and edesc funs acc ed = match ed with - | Elhs l -> + | Epattern l -> let l, acc = lhs_it funs acc l in - Elhs l, acc + Epattern l, acc | Econst se -> let se, acc = static_exp_it funs.global_funs acc se in Econst se, acc diff --git a/compiler/obc/obc_printer.ml b/compiler/obc/obc_printer.ml index 19188fe..3688386 100644 --- a/compiler/obc/obc_printer.ml +++ b/compiler/obc/obc_printer.ml @@ -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) -> @@ -90,8 +90,8 @@ let rec print_act ff a = print_tag_act_list ff tag_act_list; fprintf ff "@]@,}@]" | Afor(x, i1, i2, act_list) -> - fprintf ff "@[@[for %s = %a to %a {@ %a @]@,}@]" - (name x) + fprintf ff "@[@[for %a = %a to %a {@ %a @]@,}@]" + print_vd x print_static_exp i1 print_static_exp i2 print_block act_list diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index e82a18d..ea8c0eb 100644 --- a/compiler/utilities/misc.ml +++ b/compiler/utilities/misc.ml @@ -199,3 +199,14 @@ let split_string s separator = Str.split (separator |> Str.quote |> Str.regexp) let file_extension s = split_string s "." |> last_element +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 + + diff --git a/compiler/utilities/misc.mli b/compiler/utilities/misc.mli index c9aba5a..6f305e9 100644 --- a/compiler/utilities/misc.mli +++ b/compiler/utilities/misc.mli @@ -90,3 +90,9 @@ val (|>) : 'a -> ('a -> 'b) -> 'b (** Return the extension of a filename string *) val file_extension : string -> string + +(** Internal error : Is used when an assertion wrong *) +val internal_error : string -> int -> 'a + +(** Unsupported : Is used when something should work but is not currently supported *) +val unsupported : string -> int -> 'a diff --git a/test/check b/test/check index 341a867..a0467b3 100755 --- a/test/check +++ b/test/check @@ -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 diff --git a/test/good/t5.ept b/test/good/t5.ept index 53688b4..460e007 100644 --- a/test/good/t5.ept +++ b/test/good/t5.ept @@ -1,6 +1,5 @@ (* pour debugger set arguments -v test/good/t1.mls *) -type t node f(x,z:int) returns (o1:int) var o: int; diff --git a/todo.txt b/todo.txt index f60a48f..c0d9cde 100644 --- a/todo.txt +++ b/todo.txt @@ -1,6 +1,8 @@ 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. + *- 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" ... From 8f4411e145483e4e8ee1e2c09aaaad35c4ea2ce0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 7 Feb 2011 14:24:17 +0100 Subject: [PATCH 08/24] Recursives Qualnames. In order to have a correct handling of inner classes in Java, and to prepare for modules inside modules. --- compiler/global/global_printer.ml | 31 +- compiler/global/initial.ml | 18 +- compiler/global/modules.ml | 57 +-- compiler/global/names.ml | 62 ++- compiler/global/static.ml | 12 +- compiler/heptagon/hept_printer.ml | 2 +- compiler/heptagon/heptagon.ml | 6 +- compiler/heptagon/main/hept_parser_scoper.ml | 2 + compiler/heptagon/main/heptcheck.ml | 6 +- compiler/heptagon/parsing/hept_parser.mly | 21 +- compiler/heptagon/parsing/hept_parsetree.ml | 9 +- compiler/heptagon/parsing/hept_scoping.ml | 6 +- .../heptagon/parsing/hept_static_scoping.ml | 4 +- compiler/main/heptc.ml | 4 +- compiler/main/mls2obc.ml | 30 +- compiler/minils/main/mls2seq.ml | 4 +- compiler/minils/minils.ml | 6 +- compiler/minils/mls_printer.ml | 2 +- compiler/minils/mls_utils.ml | 2 +- compiler/minils/transformations/callgraph.ml | 38 +- compiler/obc/c/c.ml | 2 +- compiler/obc/c/cgen.ml | 4 +- compiler/obc/java/java.ml | 54 ++- compiler/obc/java/java_main.ml | 7 +- compiler/obc/java/java_printer.ml | 165 +++++--- compiler/obc/java/obc2java.ml | 366 +++++++++++++----- compiler/obc/ml/misc.ml | 2 +- compiler/obc/obc.ml | 7 +- compiler/obc/obc_printer.ml | 4 +- compiler/obc/obc_utils.ml | 2 +- compiler/utilities/global/compiler_options.ml | 2 +- compiler/utilities/global/compiler_utils.ml | 11 +- compiler/utilities/misc.ml | 32 +- lib/java/jeptagon.jar | Bin 0 -> 5291 bytes lib/java/jeptagon/Pervasives.java | 98 +++++ test/async/java_m | 6 + test/async/obc_m | 6 + test/async/pipline.ept | 25 ++ test/async/pipline_a.ept | 20 + test/async/pipline_b.ept | 25 ++ test/bad/t11-initialization.ept | 4 +- test/check | 3 +- test/good/bad_updown.ept | 8 +- test/good/flatten.ept | 6 +- test/good/statics2.ept | 4 +- test/good/t1.ept | 16 +- test/good/t2.ept | 6 +- test/good/t9.ept | 4 +- test/good/test.ept | 4 +- test/good/when_merge1.ept | 16 +- 50 files changed, 866 insertions(+), 365 deletions(-) create mode 100644 lib/java/jeptagon.jar create mode 100644 lib/java/jeptagon/Pervasives.java create mode 100755 test/async/java_m create mode 100755 test/async/obc_m create mode 100644 test/async/pipline.ept create mode 100644 test/async/pipline_a.ept create mode 100644 test/async/pipline_b.ept diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index cd2f1cc..91b1f7a 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -7,11 +7,27 @@ 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 _print_modul ff m = match m with + | Pervasives -> () + | LocalModule -> () + | _ when m = g_env.current_mod -> () + | Module m -> fprintf ff "%a." print_name m + | QualModule { qual = m; name = n } -> fprintf ff "%a%a." _print_modul m print_name n + +(** Prints a [modul] with a [.] at the end when not empty *) +let print_modul ff m = match m with + | Pervasives -> () + | LocalModule -> () + | _ when m = g_env.current_mod -> () + | Module m -> fprintf ff "%a" print_name m + | QualModule { qual = m; name = n } -> fprintf ff "%a%a" _print_modul m print_name n + +let print_qualname ff { qual = q; name = n} = match q with + | Pervasives -> print_name ff n + | LocalModule -> print_name ff n + | _ when q = g_env.current_mod -> print_name ff n + | _ -> fprintf ff "%a%a" _print_modul q print_name n let print_shortname ff {name = n} = print_name ff n @@ -29,9 +45,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 diff --git a/compiler/global/initial.ml b/compiler/global/initial.ml index b5d5f87..11244ad 100644 --- a/compiler/global/initial.ml +++ b/compiler/global/initial.ml @@ -14,18 +14,18 @@ open Types let tglobal = [] let cglobal = [] -let pbool = { qual = "Pervasives"; name = "bool" } +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 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 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:tint (Sop (op,args)) @@ -39,7 +39,7 @@ let mk_static_bool b = (* build the initial environment *) -let initialize modname = - Modules.initialize modname; +let initialize modul = + Modules.initialize modul; List.iter (fun (f, ty) -> Modules.add_type f ty) tglobal; List.iter (fun (f, ty) -> Modules.add_constrs f ty) cglobal diff --git a/compiler/global/modules.ml b/compiler/global/modules.ml index 1b2b8aa..807f3e1 100644 --- a/compiler/global/modules.ml +++ b/compiler/global/modules.ml @@ -23,7 +23,7 @@ exception Already_defined interface_format_version in signature.ml should be incremented. *) (** Object serialized in compiled interfaces. *) type module_object = - { m_name : string; + { m_name : Names.modul; m_values : node NamesEnv.t; m_types : type_def NamesEnv.t; m_consts : const_def NamesEnv.t; @@ -33,11 +33,11 @@ type module_object = type env = { (** Current module name *) - mutable current_mod : module_name; + mutable current_mod : modul; (** Modules opened and loaded into the env *) - mutable opened_mod : module_name list; + mutable opened_mod : modul list; (** Modules loaded into the env *) - mutable loaded_mod : module_name list; + mutable loaded_mod : modul list; (** Node definitions *) mutable values : node QualEnv.t; (** Type definitions *) @@ -53,12 +53,12 @@ type env = { (** The global environnement *) let g_env = - { current_mod = ""; + { current_mod = Module ""; opened_mod = []; loaded_mod = []; values = QualEnv.empty; types = QualEnv.empty; - constrs = QualEnv.empty; + constrs = QualEnv.empty; fields = QualEnv.empty; consts = QualEnv.empty; format_version = interface_format_version } @@ -86,23 +86,28 @@ let _append_module mo = g_env.fields <- QualEnv.append (qualify_all mo.m_fields) g_env.fields; g_env.consts <- QualEnv.append (qualify mo.m_consts) g_env.consts -(** Load a module into the global environnement unless already loaded *) -let _load_module modname = - if is_loaded modname then () +(** Load a module into the global environment unless already loaded *) +let _load_module modul = + if is_loaded modul then () else + let modname = match modul with + | Names.Pervasives -> "Pervasives" + | Names.Module n -> n + | Names.LocalModule -> Misc.internal_error "modules" 0 + | Names.QualModule _ -> Misc.unsupported "modules" 0 + in let name = String.uncapitalize modname in try let filename = Compiler_utils.findfile (name ^ ".epci") in let ic = open_in_bin filename in let mo:module_object = - try - input_value ic - with - | End_of_file | Failure _ -> - close_in ic; - Format.eprintf "Corrupted compiled interface file %s.@\n\ - Please recompile %s.ept first.@." filename name; - raise Errors.Error in + try input_value ic + with End_of_file | Failure _ -> + close_in ic; + Format.eprintf "Corrupted compiled interface file %s.@\n\ + Please recompile %s.ept first.@." filename name; + raise Errors.Error + in if mo.m_format_version <> interface_format_version then ( Format.eprintf "The file %s was compiled with an older version \ @@ -118,20 +123,20 @@ let _load_module modname = (** Opens a module unless already opened - by loading it into the global environnement and seting it as opened *) -let open_module modname = - if is_opened modname then () + by loading it into the global environment and setting it as opened *) +let open_module modul = + if is_opened modul then () else - _load_module modname; - g_env.opened_mod <- modname::g_env.opened_mod + _load_module modul; + g_env.opened_mod <- modul::g_env.opened_mod -(** Initialize the global environnement : +(** Initialize the global environment : set current module and open default modules *) -let initialize modname = - g_env.current_mod <- modname; +let initialize modul = + g_env.current_mod <- modul; g_env.opened_mod <- []; - g_env.loaded_mod <- [modname]; + g_env.loaded_mod <- [modul]; List.iter open_module !default_used_modules diff --git a/compiler/global/names.ml b/compiler/global/names.ml index dd31ee7..e747922 100644 --- a/compiler/global/names.ml +++ b/compiler/global/names.ml @@ -3,25 +3,38 @@ [fullname] longname -> Module.name *) type name = string +type module_name = name -and qualname = { qual: string; name: string } +type modul = + | Pervasives + | LocalModule + | Module of module_name + | QualModule of qualname + +and qualname = { qual: modul; name: name } type type_name = qualname type fun_name = qualname type field_name = qualname type constructor_name = qualname type constant_name = qualname -type module_name = name -let local_qualname = "$$%local_current_illegal_module_name%$$" -let local_qn name = { qual = local_qualname; name = name } +let pervasives_qn name = { qual = Pervasives; name = name } + +let local_qn name = { qual = LocalModule; name = name } + module NamesEnv = struct include (Map.Make(struct type t = name let compare = compare end)) let append env0 env = fold (fun key v env -> add key v env) env0 env end +module ModulEnv = struct + include (Map.Make(struct type t = modul let compare = compare end)) + let append env0 env = fold (fun key v env -> add key v env) env0 env +end + module QualEnv = struct include (Map.Make(struct type t = qualname let compare = compare end)) @@ -34,18 +47,32 @@ module S = Set.Make (struct type t = string let compare = compare end) let shortname { name = n; } = n -let qualname { qual = 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] @@ -58,7 +85,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 @@ -70,13 +97,6 @@ let print_name ff n = else n in fprintf ff "%s" n -let print_raw_qualname ff {qual = q; name = n} = - fprintf ff "%s.%a" q print_name n - -let opname qn = match qn with - | { qual = "Pervasives"; name = m; } -> m - | { qual = qual; name = n; } -> qual ^ "." ^ n - (** Use a printer to generate a string compatible with a name *) let print_pp_to_name p x = Misc.sanitize_string (Misc.print_pp_to_string p x) diff --git a/compiler/global/static.ml b/compiler/global/static.ml index 6886e72..23ce68c 100644 --- a/compiler/global/static.ml +++ b/compiler/global/static.ml @@ -28,22 +28,22 @@ let partial_apply_op 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 = "/" } -> + | { qual = Pervasives; name = "/" } -> let n = if n2 = 0 then raise Instanciation_failed else n1 / n2 in Sint n - | { qual = "Pervasives"; name = "=" } -> + | { 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) diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index f845937..e471ad9 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -286,7 +286,7 @@ let print_node ff (print_local_vars "") nb.b_local print_eq_list nb.b_equs -let print_open_module ff name = fprintf ff "open %a@." print_name name +let print_open_module ff name = fprintf ff "open %s@." (modul_to_string name) let print oc { p_opened = po; p_types = pt; p_nodes = pn; p_consts = pc } = let ff = Format.formatter_of_out_channel oc in diff --git a/compiler/heptagon/heptagon.ml b/compiler/heptagon/heptagon.ml index dec2663..ec217c5 100644 --- a/compiler/heptagon/heptagon.ml +++ b/compiler/heptagon/heptagon.ml @@ -158,8 +158,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 } @@ -179,7 +179,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 diff --git a/compiler/heptagon/main/hept_parser_scoper.ml b/compiler/heptagon/main/hept_parser_scoper.ml index 013e814..d4cb3fd 100644 --- a/compiler/heptagon/main/hept_parser_scoper.ml +++ b/compiler/heptagon/main/hept_parser_scoper.ml @@ -32,6 +32,7 @@ let parse_program modname lexbuf = let p = do_silent_pass "Parsing" (parse Hept_parser.program) lexbuf in let p = { p with Hept_parsetree.p_modname = modname } in + (* Fuse static exps together *) let p = do_silent_pass "Static Scoping" Hept_static_scoping.program p in @@ -43,6 +44,7 @@ let parse_program modname lexbuf = let parse_interface modname lexbuf = (* Parsing of the file *) let i = do_silent_pass "Parsing" (parse Hept_parser.interface) lexbuf in + (* TODO ? let i = { i with Hept_parsetree.=i_modname = modname } in *) diff --git a/compiler/heptagon/main/heptcheck.ml b/compiler/heptagon/main/heptcheck.ml index 6ca9460..ce15b58 100644 --- a/compiler/heptagon/main/heptcheck.ml +++ b/compiler/heptagon/main/heptcheck.ml @@ -15,7 +15,7 @@ open Hept_compiler open Location -let check_implementation modname filename = +let check_implementation modul filename = (* input and output files *) let source_name = filename ^ ".ept" in @@ -25,11 +25,11 @@ let check_implementation modname filename = in try - Initial.initialize modname; + Initial.initialize modul; add_include (Filename.dirname filename); (* Parsing of the file *) - let p = do_silent_pass "Parsing" (parse_implementation modname) lexbuf in + let p = do_silent_pass "Parsing" (parse_implementation modul) lexbuf in (* Fuse static exps together *) let p = do_silent_pass "Static Scoping" diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index 3462aaa..fbd6e8d 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -127,7 +127,7 @@ pragma_headers: open_modules: | /* empty */ { [] } - | open_modules OPEN Constructor { $3 :: $1 } + | open_modules OPEN modul { $3 :: $1 } ; const_decs: @@ -537,14 +537,21 @@ 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} } + | q=qualified(Constructor) { q } ; qualname: - | ident { ToQ $1 } - | Constructor DOT ident { Q {qual = $1; name = $3} } + | i=ident { ToQ i } + | q=qualified(ident) { q } ; @@ -554,8 +561,8 @@ _const: | FLOAT { Sfloat $1 } | BOOL { Sbool $1 } | constructor { Sconstructor $1 } - | Constructor DOT ident - { Svar (Q {qual = $1; name = $3}) } + | q=qualified (ident) + { Svar q } ; tuple_exp: @@ -612,7 +619,7 @@ 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; diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index 444d1d1..5a43790 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -17,6 +17,8 @@ type var_name = Names.name (** dec_names are locally declared qualified names *) type dec_name = Names.name +type module_name = Names.modul + (** state_names, [automata] translate them in constructors with a fresh type. *) type state_name = Names.name @@ -182,7 +184,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; } @@ -206,7 +208,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 @@ -223,8 +225,7 @@ 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) diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index 064d69a..695d3ad 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -172,8 +172,8 @@ let translate_iterator_type = function op (a3) == op (a2,a3) == op (a1,a2,a3) *) let static_app_from_app app args= match app.a_op with - | Efun (Q ({ qual = "Pervasives" } as q)) - | Enode (Q ({ qual = "Pervasives" } as q)) -> + | Efun (Q ({ qual = Pervasives } as q)) + | Enode (Q ({ qual = Pervasives } as q)) -> q, (app.a_params @ args) | _ -> raise Not_static @@ -457,7 +457,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; diff --git a/compiler/heptagon/parsing/hept_static_scoping.ml b/compiler/heptagon/parsing/hept_static_scoping.ml index e4c9cac..d6f2cc4 100644 --- a/compiler/heptagon/parsing/hept_static_scoping.ml +++ b/compiler/heptagon/parsing/hept_static_scoping.ml @@ -17,8 +17,8 @@ let assert_se e = match e.e_desc with op (a3) == op (a2,a3) == op (a1,a2,a3) *) let static_app_from_app app args = match app.a_op with - | Efun ((Q { Names.qual = "Pervasives" }) as q) - | Enode ((Q { Names.qual = "Pervasives" }) as q) -> + | Efun ((Q { Names.qual = Names.Pervasives }) as q) + | Enode ((Q { Names.qual = Names.Pervasives }) as q) -> q, (app.a_params @ args) | _ -> raise Not_static diff --git a/compiler/main/heptc.ml b/compiler/main/heptc.ml index e037c6d..33aa914 100644 --- a/compiler/main/heptc.ml +++ b/compiler/main/heptc.ml @@ -72,8 +72,8 @@ let compile_program modname source_f = let compile source_f = let modname = source_f |> Filename.basename |> Filename.chop_extension |> String.capitalize in - - Initial.initialize modname; + let modul = Names.modul_of_string modname in + Initial.initialize modul; source_f |> Filename.dirname |> add_include; match Misc.file_extension source_f with diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index d2709e6..792840b 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -25,7 +25,7 @@ let fresh_it () = let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst") -let op_from_string op = { qual = "Pervasives"; name = op; } +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 @@ -335,6 +335,7 @@ 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 _ -> [] @@ -352,33 +353,36 @@ and translate_iterator map call_context it name_list app loc n x xd c_list ty = | _ -> Format.eprintf "%a" Global_printer.print_type ty; internal_error "mls2obc" 6 in let array_of_output name_list ty_list = - List.map (fun l -> mk_pattern ty (Larray (l, mk_evar_int x))) name_list (* TODO not ty, but Tprod (ti...) -> ti *) + 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_pattern_int (Lvar x))) c_list in match it with | Minils.Imap -> let c_list = array_of_input c_list in - let ty_list = Types.unprod ty 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 (List.map unarray 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 node_out_ty in let v = translate_var_dec v in let b = mk_block ~locals:v action in - si, j, [ Afor (xd, 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 ty_list = Types.unprod ty in - let (name_list, acc_out) = split_last name_list in - let name_list = array_of_output name_list ty_list in - let node_out_ty = Types.prod (Misc.map_butlast unarray ty_list) 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 ]) (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 (xd, 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 @@ -389,7 +393,8 @@ and translate_iterator map call_context it name_list app loc n x xd c_list 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 (xd, 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 @@ -400,7 +405,8 @@ and translate_iterator map call_context it name_list app loc n x xd c_list 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 (xd, 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 diff --git a/compiler/minils/main/mls2seq.ml b/compiler/minils/main/mls2seq.ml index bb6614d..8246590 100644 --- a/compiler/minils/main/mls2seq.ml +++ b/compiler/minils/main/mls2seq.ml @@ -24,7 +24,7 @@ type target = (** 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,7 +32,7 @@ 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; diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index 4ecebcc..6b0e9f3 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -125,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 } @@ -171,7 +171,7 @@ let mk_app ?(params=[]) ?(async=None) ?(unsafe=false) op = (** The modname field has to be set when known, TODO LG : format_version *) let mk_program o n t c = - { p_modname = ""; p_format_version = ""; + { p_modname = Module ""; p_format_version = ""; p_opened = o; p_nodes = n; p_types = t; p_consts = c } let void = mk_exp ~ty:Types.Tunit (Eapp (mk_app Etuple, [], None)) diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index 0fb87f3..70549f9 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -179,7 +179,7 @@ and print_eqs ff = function | [] -> () | l -> fprintf ff "@[let@ %a@]@\ntel" (print_list_r print_eq """;""") l -let print_open_module ff name = fprintf ff "open %a@." print_name name +let print_open_module ff name = fprintf ff "open %s@." (modul_to_string name) let rec print_type_dec ff { t_name = name; t_desc = tdesc } = let print_type_desc ff = function diff --git a/compiler/minils/mls_utils.ml b/compiler/minils/mls_utils.ml index 8870651..5fbd79a 100644 --- a/compiler/minils/mls_utils.ml +++ b/compiler/minils/mls_utils.ml @@ -53,7 +53,7 @@ let is_record_type ty = match ty with | _ -> false let is_op = function - | { qual = "Pervasives"; name = _ } -> true | _ -> false + | { qual = Pervasives; name = _ } -> true | _ -> false let exp_list_of_static_exp_list se_list = let mk_one_const se = diff --git a/compiler/minils/transformations/callgraph.ml b/compiler/minils/transformations/callgraph.ml index 61fddf6..5139331 100644 --- a/compiler/minils/transformations/callgraph.ml +++ b/compiler/minils/transformations/callgraph.ml @@ -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 @@ -201,18 +199,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 +230,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 +246,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,7 +262,7 @@ 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 @@ -303,9 +307,9 @@ let program p = (* Find the nodes without static parameters *) let main_nodes = List.filter (fun n -> is_empty n.n_params) p.p_nodes in let main_nodes = List.map (fun n -> n.n_name, []) main_nodes in - info.opened <- NamesEnv.add p.p_modname p NamesEnv.empty; + info.opened <- ModulEnv.add p.p_modname p ModulEnv.empty; (* Creates the list of instances starting from these nodes *) List.iter call_node main_nodes; - let p_list = NamesEnv.fold (fun _ p l -> p::l) info.opened [] in + let p_list = ModulEnv.fold (fun _ p l -> p::l) info.opened [] in (* Generate all the needed instances *) List.map Param_instances.Instantiate.program p_list diff --git a/compiler/obc/c/c.ml b/compiler/obc/c/c.ml index e5e5bb8..6142d1b 100644 --- a/compiler/obc/c/c.ml +++ b/compiler/obc/c/c.ml @@ -158,7 +158,7 @@ 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 + if q.qual = Pervasives or q.qual = Names.local_qualname then q.name else (q.qual ^ "__" ^ q.name) diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 2c904ad..523a593 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -296,7 +296,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) @@ -354,7 +354,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 = diff --git a/compiler/obc/java/java.ml b/compiler/obc/java/java.ml index 62b3261..fe85372 100644 --- a/compiler/obc/java/java.ml +++ b/compiler/obc/java/java.ml @@ -28,6 +28,8 @@ type ty = Tclass of class_name 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 } and class_kind = Cenum of constructor_name list @@ -47,7 +49,7 @@ and field = { f_protection : protection; f_static : bool; f_final : bool; f_type : ty; - f_name : field_ident; + f_ident : field_ident; f_value : exp option } and methode = { m_protection : protection; @@ -55,6 +57,7 @@ and methode = { m_protection : protection; m_name : method_name; m_args : var_dec list; m_returns : ty; + m_throws : class_name list; m_body : block; } @@ -63,33 +66,47 @@ and block = { b_locals : var_dec list; and act = Anewvar of var_dec * exp | Aassgn of pattern * exp - | Amethod_call of pattern * method_name * exp list + | 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 | Ablock of block - | Afor of var_dec * exp * exp * block (* TODO var_dec *) + | Afor of var_dec * exp * exp * block | Areturn of exp and exp = Eval of pattern | Efun of op_name * exp list - | Emethod_call of pattern * method_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 + | Enew_array of ty * exp list (** [ty] is the array base type *) | Evoid (*printed as nothing*) | Svar of const_name | Sint of int | Sfloat of float | Sbool of bool | Sconstructor of constructor_name + | Snull and pattern = Pfield of pattern * field_name + | Pclass of class_name | Pvar of var_ident | Parray_elem of pattern * exp | Pthis of field_ident type program = classe list + +let default_value ty = match ty with + | Tclass _ -> Snull + | Tgeneric _ -> Snull + | Tbool -> Sbool true + | Tint -> Sint 0 + | Tfloat -> Sfloat 0.0 + | Tunit -> Evoid + | Tarray _ -> Enew_array (ty,[]) + let mk_var x = Eval (Pvar x) let mk_var_dec x ty = @@ -98,20 +115,29 @@ let mk_var_dec x ty = let mk_block ?(locals=[]) b = { b_locals = locals; b_body = b; } -let mk_methode ?(protection=Ppublic) ?(static=false) ?(args=[]) ?(returns=Tunit) - body name = - { m_protection = protection; m_static = static; m_name = name; m_args = args; m_returns = returns; m_body = body; } -let mk_classe ?(protection=Ppublic) ?(static=false) ?(fields=[]) ?(classes=[]) ?(constrs=[]) ?(methodes=[]) +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 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_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 mk_enum ?(protection=Ppublic) ?(static=false) +let mk_enum ?(protection=Ppublic) ?(static=false) ?(imports=[]) ?(implements=[]) constructor_names class_name = - { c_protection = protection; c_static = static; c_name = class_name; c_kind = Cenum(constructor_names) } + { c_protection = protection; c_static = static; c_name = class_name; c_imports = imports; c_implements = implements; + c_kind = Cenum(constructor_names) } let mk_field ?(protection = Ppublic) ?(static = false) ?(final = false) ?(value = None) - ty name = - { f_protection = protection; f_static = static; f_final = final; f_type = ty; f_name = name; f_value = value } + ty ident = + { f_protection = protection; f_static = static; f_final = final; f_type = ty; f_ident = ident; f_value = value } + +let vds_to_exps vd_l = List.map (fun { vd_ident = x } -> mk_var x) vd_l + +let vds_to_fields ?(protection=Ppublic) vd_l = + List.map (fun { vd_ident = x; vd_type = t } -> mk_field ~protection:protection t x) vd_l diff --git a/compiler/obc/java/java_main.ml b/compiler/obc/java/java_main.ml index 1581f86..485d29e 100644 --- a/compiler/obc/java/java_main.ml +++ b/compiler/obc/java/java_main.ml @@ -1,13 +1,10 @@ open Java open Java_printer -open Obc2java -open Compiler_utils let program p = - let filename = filename_of_name p.Obc.p_modname in - let dirname = build_path (filename ^ "_java") in - let dir = clean_dir dirname in let p_java = Obc2java.program p in + let dir = Compiler_utils.build_path "java" in + Compiler_utils.ensure_dir dir; output_program dir p_java \ No newline at end of file diff --git a/compiler/obc/java/java_printer.ml b/compiler/obc/java/java_printer.ml index b512f20..7c6d30e 100644 --- a/compiler/obc/java/java_printer.ml +++ b/compiler/obc/java/java_printer.ml @@ -12,119 +12,174 @@ open Java open Pp_tools open Format +open Misc -(* TODO java faire des vrais qualname recursifs, bare_constructor doit être vraiment bare *) - -let class_name = Global_printer.print_shortname +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 op_name = Global_printer.print_qualname (* TODO java fix this for infix etc... see others is_infix and old_java *) let var_ident = Global_printer.print_ident let const_name = Global_printer.print_qualname -let rec ty 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,_) -> fprintf ff "%a[]" ty t - | Tunit -> pp_print_string ff "void" - let protection ff = function | Ppublic -> fprintf ff "public " | Pprotected -> fprintf ff "protected " | Pprivate -> fprintf ff "private " | Ppackage -> () -let var_dec ff vd = fprintf ff "%a %a" ty vd.vd_type var_ident vd.vd_ident - -let vd_list s1 s2 s3 ff vd_l = print_list_r var_dec s1 s2 s3 ff vd_l - let static ff s = if s then fprintf ff "static " else () let final ff f = if f then fprintf ff "final " else () -let rec field ff f = +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]" ty t exp s else fprintf ff "%a[]" ty t + | Tunit -> pp_print_string ff "void" + +and full_ty ff t = _ty true ff t + +and ty ff t = _ty false ff t + +and var_dec init ff vd = + if init then + fprintf ff "%a %a = %a" ty vd.vd_type var_ident vd.vd_ident exp (Java.default_value vd.vd_type) + else + fprintf ff "%a %a" ty vd.vd_type var_ident vd.vd_ident + +and vd_list s1 s2 s3 ff vd_l = match vd_l with + | [] -> () + | _ -> fprintf ff "@[%a@]@\n" (print_list_r (var_dec true) s1 s2 s3) vd_l + +and field ff f = fprintf ff "@[<2>%a%a%a%a %a%a;@]" protection f.f_protection static f.f_static final f.f_final ty f.f_type - field_ident f.f_name + field_ident f.f_ident (print_opt2 exp " = ") f.f_value and exp ff = function | Eval p -> pattern ff p - | Efun (f,e_l) -> fprintf ff "%a@[%a@]" op_name f args e_l - | Emethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" pattern o method_name m args e_l - | Enew (c,e_l) -> fprintf ff "new %a%a" ty c args e_l - | Enew_array (t,e_l) -> fprintf ff "new %a@[<2>%a@]" ty t (print_list_r exp "{"",""}") e_l + | 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 + | [] -> fprintf ff "new %a" full_ty t + | _ -> fprintf ff "new %a@[<2>%a@]" ty t (print_list_r exp "{"",""}") e_l ) | Evoid -> () | 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 + | 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 + | _ -> Misc.unsupported "java_printer" 1) + | _ -> 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@]" + fprintf ff "%a%a" (vd_list """;"";") b.b_locals (print_list_r act """;"";") b.b_body +and switch_hack ff c_b_l = + fprintf ff "@[ default :\\Dead code. Hack to prevent \"may not be initialized\" java error.@ %a@ break;@]" + block (c_b_l |> List.hd |> snd) + and act ff = function - | Anewvar (vd,e) -> fprintf ff "%a = %a" var_dec vd exp e - | Aassgn (p,e) -> fprintf ff "%a = %a" pattern p exp e - | Amethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" pattern o method_name m args e_l + | Anewvar (vd,e) -> fprintf ff "@[<2>%a =@ %a@]" (var_dec false) vd exp e + | Aassgn (p,e) -> fprintf ff "@[<2>%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 "@[case %a:@ %a@ break;@]" bare_constructor_name c block b in + let pcb ff (c,b) = fprintf ff "@[case %a:@ %a@ break;@]" bare_constructor_name c block b in + (* let switch_hack ff c_b_l = (* TODO java : better thing to do ? *) + fprintf ff "@[<2>default ://Dead code. Hack to prevent \ + \"may not be initialized\" java error.@ %a@ break;@]" block (c_b_l |> List.hd |> snd) + in*) fprintf ff "@[switch (%a) {@ %a@]@\n}" exp e (print_list_r pcb """""") c_b_l | Aif (e,bt) -> - fprintf ff "@[<2>if (%a) {@ %a@ }@]" exp e block bt + fprintf ff "@[if (%a) {@ %a@ }@]" exp e block bt | Aifelse (e,bt,bf) -> - fprintf ff "@[<2>if (%a) {@ %a@ }@]@\n@[<2>else {@ %a@ }@]" + fprintf ff "@[if (%a) {@ %a@ }@]@\n@[else {@ %a@ }@]" exp e block bt block bf - | Ablock b -> fprintf ff "@[<2>{@ %a@ }]" block b + | Ablock b -> fprintf ff "@[{@ %a@ }]" block b | Afor (x, i1, i2, b) -> - fprintf ff "@[<2>for (%a = %a; %a<%a; %a++) {@ %a@ }@]" - var_dec x - exp i1 - var_ident x.vd_ident - exp i2 - var_ident x.vd_ident - block b + fprintf ff "@[for (%a = %a; %a<%a; %a++) {@ %a@ }@]" + (var_dec false) x + exp i1 + var_ident x.vd_ident + exp i2 + var_ident x.vd_ident + block b | Areturn e -> fprintf ff "return %a" exp e let methode ff m = - fprintf ff "@[<4>%a%a%a %a @[<2>(%a)@] {@\n%a@]@\n}" + fprintf ff "@[%a%a%a %a @[<2>(%a)@] @[%a@]{@ %a@]@\n}" protection m.m_protection static m.m_static ty m.m_returns method_name m.m_name - (vd_list """,""") m.m_args + (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 "@[<4>%a%a @[<2>(%a)@] {@\n%a@]@\n}" + fprintf ff "@[%a%a @[<2>(%a)@] {@\n%a@]@\n}" protection m.m_protection method_name m.m_name - (vd_list """,""") m.m_args + (print_list_r (var_dec false) """,""") m.m_args block m.m_body let rec class_desc ff cd = @@ -139,23 +194,33 @@ and classe ff c = match c.c_kind with fprintf ff "@[<4>%a%aenum %a {@\n%a@]@\n}" protection c.c_protection static c.c_static - class_name c.c_name + bare_class_name c.c_name (print_list_r bare_constructor_name """,""") c_l | Cgeneric cd -> - fprintf ff "@[<4>%a%aclass %a {@\n%a@]@\n}" + fprintf ff "@[<4>%a%aclass %a @[%a@]{@\n%a@]@\n}" protection c.c_protection static c.c_static - class_name c.c_name + bare_class_name c.c_name + (print_list_r class_name "implements "",""") c.c_implements class_desc cd -let output_classe dir c = - let { Names.name = file_name; Names.qual = package_name } = c.c_name in +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 - fprintf ff "package %s;@\n" (String.lowercase package_name); - classe ff c; - pp_print_flush ff (); + pp_set_margin ff 120; + fprintf ff "package %a;@\n@[%a@]@\n%a@." + Global_printer.print_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) = diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index bee6509..a7e3d24 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -23,109 +23,132 @@ open Signature open Obc open Java +let java_pervasives = Names.modul_of_string "jeptagon.Pervasives" +let java_pervasives_class = Names.qualname_of_string "jeptagon.Pervasives" -let fresh_it () = - let id = Idents.gen_var "obc2java" "i" in - id, mk_var_dec id Tint +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"] + + +(** 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, id = fresh_it () in + 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)) - -(** a [Module] becomes a [package] *) -let translate_qualname q = match q with - | { qual = "Pervasives" } -> q - | { qual = m } when m = g_env.current_mod -> q (* current module is not translated to keep track, - there is no issue since printed without the qualifier *) - | { qual = m } when m = local_qualname -> q - | _ -> { q with qual = String.lowercase q.qual } + (* current module is not translated to keep track, there is no issue since printed without the qualifier *) +let rec translate_modul ?(full=false) m = match m with + | Pervasives + | LocalModule -> m + | _ when m = g_env.current_mod && not full -> 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 q = match q with - | { qual = m } when m = local_qualname -> { q with name = String.uppercase q.name } - | _ -> { q with qual = (String.lowercase q.qual)^ ".CONSTANTES"; name = String.uppercase q.name } +let translate_const_name { qual = m; name = n } = + { qual = QualModule { qual = translate_modul m; name = "CONSTANTES"}; name = String.uppercase n } (** a [Module.name] becomes a [module.Name] used for type_names, class_names, fun_names *) let qualname_to_class_name q = - let q = translate_qualname q in - { q with name = String.capitalize q.name } + { 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 ~full:true 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 q q_ty = (* TODO java recursive qualname ! *) +let translate_constructor_name_2 q q_ty = let classe = qualname_to_class_name q_ty in - let q = qualname_to_class_name q in - { q with name = classe.name ^ "." ^ q.name } + { 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 q q_ty + | 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_class_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 -> - if shortname c = local_qualname - then let n = NamesEnv.find (shortname c) param_env in Svar (n |> Idents.name |> local_qn) - else Svar (translate_const_name 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 t -> eprintf "ojStuple@."; assert false; - (* TODO java ?? not too difficult if needed, return Tuplen<..>() *) + | Types.Stuple se_l -> tuple param_env se_l | Types.Sarray_power _ -> eprintf "ojSarray_power@."; assert false; (* TODO java array *) | 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 -> - let ln = ty_l |> List.length |> Pervasives.string_of_int in - Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l) + | 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.Tasync _ -> assert false; (* TODO async *) + | Types.Tasync (_,t) -> Tgeneric (Names.pervasives_qn "Future", [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 + Tgeneric ({ qual = java_pervasives; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l) + and ty param_env t :Java.ty = match t with - | Types.Tprod ty_l -> - let ln = ty_l |> List.length |> Pervasives.string_of_int in - Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l) + | 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.Tasync _ -> assert false; (* TODO async *) + | Types.Tasync (_,t) -> Tgeneric (Names.pervasives_qn "Future", [boxed_ty param_env t]) | Types.Tunit -> Tunit -let var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident } +and var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident } -let var_dec_list param_env vd_l = List.map (var_dec param_env) vd_l +and var_dec_list param_env vd_l = List.map (var_dec param_env) vd_l -let rec exp param_env e = match e.e_desc with +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) - | Obc.Ebang _ -> eprintf "ojEbang@."; assert false (* TODO java async *) + | Obc.Ebang e -> Emethod_call (exp param_env e,"get",[]) 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 @@ -133,20 +156,23 @@ and pattern param_env p = match p.pat_desc with | 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 -> Pvar id - | Oarray (id,p) -> Parray_elem (Pvar id, Eval (pattern param_env p)) + | 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) -> + | Obc.Acall ([], obj, Mstep, e_l) + | Obc.Aasync_call (_,[], 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.Acall ([p], obj, Mstep, e_l) + | Obc.Aasync_call (_,[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.Acall (p_l, obj, Mstep, e_l) + | Obc.Aasync_call (_,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 @@ -157,10 +183,10 @@ 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.Acall (_, obj, Mreset, _) + | Obc.Aasync_call (_,_, obj, Mreset, _) -> let acall = Amethod_call (obj_ref param_env obj, "reset", []) in acall::acts - | Obc.Aasync_call _ -> assert false (* TODO java async *) | Obc.Acase (e, c_b_l) when e.e_ty = Types.Tid Initial.pbool -> (match c_b_l with | [] -> acts @@ -169,8 +195,8 @@ let rec act_list param_env act_l 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,b) -> c = Initial.ptrue) c_b_l in - let _, _else = List.find (fun (c,b) -> c = Initial.pfalse) c_b_l in + 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 @@ -188,58 +214,193 @@ and block param_env ?(locals=[]) ?(end_acts=[]) ob = 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 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 java_pervasives_class, "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 ~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 ~imports:import_async ~fields:fields ~constrs:[constructor] + ~methodes:[step;reset] ~classes:[callable_class] classe_name + + let class_def_list classes cd_l = let class_def classes cd = Idents.enter_node cd.cd_name; - let class_name = qualname_to_class_name cd.cd_name in - (* [param_env] is an env mapping local param name to ident *) - let constructeur, param_env = - 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 + 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 + (* [obj_env] gives the type of an [obj_ident], needed in async because we change the classe for async obj *) + let constructeur, param_env, 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 + in Idents.Env.add od.o_ident t obj_env + in List.fold_left aux Idents.Env.empty cd.cd_objs in - let args, param_env = Misc.mapfold param_to_arg NamesEnv.empty cd.cd_params in let body = (* TODO java array : also initialize arrays with [ new int[3] ] *) - let final_field_init_act arg = Aassgn (Pthis arg.vd_ident, Eval (Pvar arg.vd_ident)) in + (* Initialize the objects *) let obj_init_act acts od = let params = List.map (static_exp param_env) od.o_params in let act = match od.o_size with - | None -> [ Aassgn (Pthis od.o_ident, Enew (Tclass od.o_class, params)) ] + | None -> + let t = Idents.Env.find od.o_ident obj_env in + [ Aassgn (Pthis od.o_ident, Enew (t, params)) ] | Some size -> let size = static_exp param_env size in - let assgn_elem i = - [ Aassgn (Parray_elem (Pthis od.o_ident, mk_var i), Enew (Tclass od.o_class, params)) ] - in - [ Aassgn (Pthis od.o_ident, Enew (Tarray (Tclass od.o_class,size), [])); + 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 ] - in - act@acts + in act@acts in - let acts = List.map final_field_init_act args in - let acts = List.fold_left obj_init_act acts cd.cd_objs in + let acts_init_params = copy_to_this vds_params in + let acts = List.fold_left obj_init_act acts_init_params cd.cd_objs in { b_locals = []; b_body = acts } in - mk_methode ~args:args body (shortname class_name), param_env + mk_methode ~args:vds_params body (shortname class_name), param_env, 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 -> Tclass (qualname_to_class_name od.o_class) - | Some size -> Tarray (Tclass (qualname_to_class_name od.o_class), static_exp param_env size) + | 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 params_to_field fields p = - let p_ident = NamesEnv.find p.p_name param_env in - (mk_field ~protection:Pprotected ~final:true (ty param_env p.p_type) p_ident) :: fields - in - let fields = List.fold_left mem_to_field [] cd.cd_mems in - let fields = List.fold_left obj_to_field fields cd.cd_objs in - List.fold_left params_to_field fields cd.cd_params + 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 @@ -251,14 +412,15 @@ 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 ~args:(var_dec_list param_env ostep.Obc.m_inputs) ~returns:return_ty body "step" + mk_methode ~throws:throws_async ~args:(var_dec_list param_env ostep.Obc.m_inputs) ~returns:return_ty body "step" in let reset = let oreset = find_reset_method cd in let body = block param_env oreset.Obc.m_body in mk_methode body "reset" in - let classe = mk_classe ~fields:fields ~constrs:[constructeur] ~methodes:[step;reset] class_name in + let classe = mk_classe ~imports:import_async ~fields:fields + ~constrs:[constructeur] ~methodes:[step;reset] class_name in classe::classes in List.fold_left class_def classes cd_l @@ -267,17 +429,20 @@ let class_def_list 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_class_name td.t_name in + 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" 1 (* TODO java *) - | Type_alias ot -> classes (* TODO java alias ?? *) + | 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 c td.t_name in + 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 (* TODO java pretty ugly *) + 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 @@ -285,27 +450,30 @@ let type_dec_list classes td_l = List.fold_left _td classes td_l -let const_dec_list cd_l = - 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 (* TODO java pretty ugly*) - 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 - match cd_l with - | [] -> [] - | _ -> - let classe_name = "CONSTANTES" |> name_to_classe_name in - let fields = List.map mk_const_field cd_l in - [mk_classe ~fields:fields classe_name] +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_defs in - p + get_classes()@p diff --git a/compiler/obc/ml/misc.ml b/compiler/obc/ml/misc.ml index ec719ac..3b0b07d 100644 --- a/compiler/obc/ml/misc.ml +++ b/compiler/obc/ml/misc.ml @@ -15,7 +15,7 @@ let version = "3.0b" let date = DATE (* standard module *) -let pervasives_module = "Pervasives" +let pervasives_module = Pervasives let standard_lib = STDLIB (* variable creation *) diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index f07dca6..235dc9c 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -76,11 +76,12 @@ 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_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 *) @@ -101,8 +102,8 @@ type class_def = 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 } diff --git a/compiler/obc/obc_printer.ml b/compiler/obc/obc_printer.ml index 3688386..4dbe75f 100644 --- a/compiler/obc/obc_printer.ml +++ b/compiler/obc/obc_printer.ml @@ -179,9 +179,7 @@ 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 diff --git a/compiler/obc/obc_utils.ml b/compiler/obc/obc_utils.ml index d9c767f..aa37f04 100644 --- a/compiler/obc/obc_utils.ml +++ b/compiler/obc/obc_utils.ml @@ -67,5 +67,5 @@ struct 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) + S.remove p.p_modname (S.remove Pervasives deps) end diff --git a/compiler/utilities/global/compiler_options.ml b/compiler/utilities/global/compiler_options.ml index 78b5f29..1a0a3ac 100644 --- a/compiler/utilities/global/compiler_options.ml +++ b/compiler/utilities/global/compiler_options.ml @@ -15,7 +15,7 @@ let version = "0.4" let date = "DATE" (* standard module *) -let pervasives_module = "Pervasives" +let pervasives_module = Pervasives let standard_lib = "STDLIB" let standard_lib = try Sys.getenv "HEPTLIB" with Not_found -> standard_lib diff --git a/compiler/utilities/global/compiler_utils.ml b/compiler/utilities/global/compiler_utils.ml index fc0f567..c407cb0 100644 --- a/compiler/utilities/global/compiler_utils.ml +++ b/compiler/utilities/global/compiler_utils.ml @@ -58,14 +58,13 @@ let silent_pass d enabled f p = then do_silent_pass d f p else p + + 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 +73,12 @@ let clean_dir dir = end else Unix.mkdir dir 0o740; dir +let ensure_dir dir = + if not (Sys.file_exists dir && Sys.is_directory dir) + then Unix.mkdir dir 0o740 + + + exception Cannot_find_file of string let findfile filename = diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index ea8c0eb..089e08b 100644 --- a/compiler/utilities/misc.ml +++ b/compiler/utilities/misc.ml @@ -158,16 +158,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,14 +209,4 @@ let split_string s separator = Str.split (separator |> Str.quote |> Str.regexp) let file_extension s = split_string s "." |> last_element -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 - diff --git a/lib/java/jeptagon.jar b/lib/java/jeptagon.jar new file mode 100644 index 0000000000000000000000000000000000000000..8845563780f8de722b45715ac9810b327c1dd7cf GIT binary patch literal 5291 zcmbW5cQjnv+s8+5lVEg$nJ`9lq6@(&V;IpAB@$hTUP6d2(W6|67M-Y9v?w8>jH{FA z#ML{|iIU)*`6cg-Soh|S>{(~6Gi&YrIs2UNv-f_UuZAifJ~e=tm>A&bFE0Z)(?|gL z0F+Cg=7s;Tnw z^pXC@wGiYpvo&#XvD4^8qGhS2V_RCXOPA3{OX`l4+5%xx zyyMjP8F?S3d_cj`6fkJuKv1$EkXEp``h_Dyjk^y|z)YB&ky6H-Vj@XU+#+Rvs*(_wC6MjWxZ`$1dQZQy z*6naa*w}VEU1IC;>|!#E zs$LfKq8ddZ2DHE?X46Xrq&LwX1TGx>8mUb2D)-`rmYz6E&I$N}+(M3(?&zV`Op1GZ zW$8`vkIAqR(sp`KdKm`*Xu@2-`Mrg{fA5$vB(5fP(5ZA*A_(`sS%g!^jD3-_k3+wWn?BNa15v05b?$r1iuz0ZlRyI8{jvxBVE|-ayeN{<9#(^r?0@i*=`+3h zO5yro&oZ0DmvUIZJkcv^_ud`E!9`Y&f%ZWfBd0;V;?>u$bV<}7p~|b)=Y||<56zrr zx!g|V4g|^n*2AZ}KNR#7kBNa^l!u=1B13_;Ao-y=$BTM&tGe)hGxW}`@<^2yY5m3) zm;whreQHTq_o~Op01ki3B8|G9VWPT52p7#)D=51DAdlaqWRrPp-mqTK{5AcmX*`>z+&kNDMZ;W2ri2`jl-d?UTP!GD7)))c|^iwS?*u9yJ1+p zR+lOyOfh7|XhnKZpOE|rm4(qWJk5*HORC~#n|qzW z&>oGn)t52$7m@pQkc}IwK<8olgdqT2s1fg!g*vam@o`3i4PJ}!&zhzF9s6ZPd7ja$e_4Zyt?5!Q=fa0CK(1Yd3FW}P=NooQs9iW0ho5&)%S z#p`a|tf_sszWcuuNN9kwNiR&cQAjn&;)%s`3shrJfE|ue7C5^4{xY8QfO5s9ga6Na`PVDqZ!t13%(y@z1xG&QsxW$sta?! zvC|_J^_ZbvNX=v1w?I|3f7Na!yG*U8S*_!-TFdQJ8-wZH4QqqmLjCRgadk;FQ45K~ zJ4zdp-h~i;U`xa#(k6YZMfT&Dx1vD|=4K&aMzpwUvPBp)G%p~z!AsTck!QKtg70U0 zt7H4yEFaLmFGgNkBUj%Rja9xT;P4G3J}Cdns1ns*f@FoNrCmY9k`UmUJ@YdDV=LyG zoP^9Duq!v7&f&kDL!@%RmV(OXv%_>}iNh|Oe&{x9ED9gV>|iGyDh+L;!zw-7O<|af zQJNp`w>MeQZ%S8S7VWGo^`GkU5pXa>0BABvV%aVejN>GSi)#{7BJSuS&+SZo$sBeV zeHbgD$L2JJw~$4#Q6Z~0#a*UTTrhB4lUjRPe@z;X(~KX7SyeKqw5z14q@$#zq^BeU zl527s+{Z&~zG7!%JTDd3-(e*3v21jV?t{apIJ3Q@SJWYimL_R*bTs^2ceUPTKh)nU zo1yuOJ4~0R7!<`i5;-nKy|nNy^|N=+5HD1GWul)Vzh+=0e;0qb-S0%slPld9 zL?!GNcL0=d*AXdTYPn8qHm2M>vPCK4=G`1&+tnH!!@Nx?R_4U|(a1pMy`STgZQRz7 z>Br7#S}lwz-b&u@OG6}woVMI%E@e8{vXB+{P^Z;t-;Yf=vz_dK)=Wqz5B#M-*Cf#maBsm2Bm$usu0z%v7atpWS-CO)6Z@lg zK_X;ip#-cA%8+$t8WYXp(d0)xy?ZH-EWhpy@3R7utn^AsESs7o(S&FYw04jXnl?~a zLr{aJZPx}@bv#3Cr+|&0UMK1id@$`3NdoKyyvfn8K{97pRoUA8pnEk*OxVF{V&HAQ zhw4t;f?fAmlDqH*#rusf{?{ca4h-MFi2JS9 zbXWM-#4xuv!!6PSwtxHCWi^zvX_)I->X|qiGo>#YF&A`(iqR7d)@u)qFV7>Svx1M| zpW@}xo6s?Iid-PQ19zyuZK6X-g3yJiWul5DcTp=!15#Wu6${63S4ajOf}dj-ly53O z$x)a5!5vY|zI&%nUA`DZ?;Sx-^eub z-3-r39H_$E5yOT_)EWS16cZ-%zYG(Gf3Hiv#m7^vJ2$B0sHNezgZQ`=3q$g#Uz?IO zwNx5sHpeT0K)9%n2lsROUzBxAs(#MetRg0-VEKx3!r8Re(GhOn#<8FLx669U=%dB` z?md10%2uD#cvPN%TXC+GYfEXSNa3b&4PDy9U6qCjv7ms;+@@&xQ1|@TY^8DAcA@)M z98?ChCZ6TxzJ-*gZb#ulCE1vjeKz6T-fDRM6@f8~+^|T)_r33WohYJ1lO5dO@e!Em z_S3DGt}==paYYvn)|1VRo%mHx``auDoQ&qC=N_@#vvjL)UwmETbIIzX3+zxU_;&sW zX669^f4pwd5Fu;p=~Mp zS8{Ngc|*+6-Vz1z?)*P(`50o`-QSi?#_CJTHk7yF#RkbD8P_>)Epx@y?jbML95j; z;1tu|P6x3JLi$b#u;dWt5V;$CDaMLeDQ6Vsi#^&g{(^=o4lXs|XV2vS4H2wo@^kyg z1i?Be=ZBs(FtCovk0y<|{b%SI{{%}Q1^l|c z?B8vWv#)`rovki^rWs*A%#TT&qkS*(&(qG { + public final T c0; + public Tuple1(T v) { + c0 = v; + } + } + + public static class Tuple2 { + public final T0 c0; + public final T1 c1; + public Tuple2(T0 v0, T1 v1) { + c0 = v0; + c1 = v1; + } + } + + public static class Tuple3 { + public final T0 c0; + public final T1 c1; + public final T2 c2; + public Tuple3(T0 v0, T1 v1, T2 v2) { + c0 = v0; + c1 = v1; + c2 = v2; + } + } + + public static class Tuple4 { + public final T0 c0; + public final T1 c1; + public final T2 c2; + public final T3 c3; + public Tuple4(T0 v0, T1 v1, T2 v2, T3 v3) { + c0 = v0; + c1 = v1; + c2 = v2; + c3 = v3; + } + } + + public static class Tuple5 { + public final T0 c0; + public final T1 c1; + public final T2 c2; + public final T3 c3; + public final T4 c4; + public Tuple5(T0 v0, T1 v1, T2 v2, T3 v3, T4 v4) { + c0 = v0; + c1 = v1; + c2 = v2; + c3 = v3; + c4 = v4; + } + } + + public static class Tuple6 { + public final T0 c0; + public final T1 c1; + public final T2 c2; + public final T3 c3; + public final T4 c4; + public final T5 c5; + public Tuple6(T0 v0, T1 v1, T2 v2, T3 v3, T4 v4, T5 v5) { + c0 = v0; + c1 = v1; + c2 = v2; + c3 = v3; + c4 = v4; + c5 = v5; + } + } + + public static class Tuple7 { + public final T0 c0; + public final T1 c1; + public final T2 c2; + public final T3 c3; + public final T4 c4; + public final T5 c5; + public final T6 c6; + public Tuple7(T0 v0, T1 v1, T2 v2, T3 v3, T4 v4, T5 v5, T6 v6) { + c0 = v0; + c1 = v1; + c2 = v2; + c3 = v3; + c4 = v4; + c5 = v5; + c6 = v6; + } + } +} diff --git a/test/async/java_m b/test/async/java_m new file mode 100755 index 0000000..ff6477a --- /dev/null +++ b/test/async/java_m @@ -0,0 +1,6 @@ +#!/bin/bash +cp $@ build/ +cd build +../../../heptc -target java $@ +cd .. + diff --git a/test/async/obc_m b/test/async/obc_m new file mode 100755 index 0000000..4a00eee --- /dev/null +++ b/test/async/obc_m @@ -0,0 +1,6 @@ +#!/bin/bash +cp $@ build/ +cd build +../../../heptc -target obc $@ +cd .. + diff --git a/test/async/pipline.ept b/test/async/pipline.ept new file mode 100644 index 0000000..08f4ac7 --- /dev/null +++ b/test/async/pipline.ept @@ -0,0 +1,25 @@ + +fun sum (x,m: int) returns (s: int) +let + s = x + m +tel + +fun substr (x,m: int) returns (d: int; m2:int) +let + d = x - m; + m2 = m; +tel + +fun mean<> (i: int^n) returns (m: int) +let + m = fold sum <> (i,0) +tel + + +node normalized_movie<> (i: int^n) returns (im: int^n) +var m: int; trash: int; +let + m = mean<>(i); + (im,trash) = mapfold substr <> (i,m) +tel + diff --git a/test/async/pipline_a.ept b/test/async/pipline_a.ept new file mode 100644 index 0000000..72c3319 --- /dev/null +++ b/test/async/pipline_a.ept @@ -0,0 +1,20 @@ + +fun substr (x,m: int) returns (d: int; m2:int) +let + d = x - m; + m2 = m; +tel + +fun mean<> (i: int^n) returns (m: int) +let + m = (fold (+) <> (i,0) )/n +tel + + +node normalized_movie<> (i: int^n) returns (im: int^n) +var m: async int; trash: int; +let + m = async mean<>(i); + (im,trash) = mapfold substr <> (i fby i, 0 -> !(pre m)) +tel + diff --git a/test/async/pipline_b.ept b/test/async/pipline_b.ept new file mode 100644 index 0000000..544783c --- /dev/null +++ b/test/async/pipline_b.ept @@ -0,0 +1,25 @@ + +fun sum (x,m: int) returns (s: int) +let + s = x + m +tel + +fun substr (x,m: int) returns (d: int; m2:int) +let + d = x - m; + m2 = m; +tel + +fun mean<> (i: int^n) returns (m: int) +let + m = fold sum <> (i,0) +tel + + +node normalized_movie<> (i: int^n) returns (im: int^n) +var m: int; trash: int; +let + m = mean<>(i); + (im,trash) = mapfold substr <> (i fby i, 0 -> (pre m)) +tel + diff --git a/test/bad/t11-initialization.ept b/test/bad/t11-initialization.ept index 76ece05..ac66d36 100644 --- a/test/bad/t11-initialization.ept +++ b/test/bad/t11-initialization.ept @@ -1,4 +1,4 @@ -node mmm(x: int) returns (o': int) +node mmm(x: int) returns (o2: int) var last m: int; o: int; let automaton @@ -7,5 +7,5 @@ node mmm(x: int) returns (o': int) state J do m = last m + 1; o = 0 end; - o' = 1 -> pre o + o2 = 1 -> pre o tel diff --git a/test/check b/test/check index a0467b3..37bbf3c 100755 --- a/test/check +++ b/test/check @@ -91,7 +91,7 @@ launch_check () { score=`expr $score + 1`; fi done - + echo echo "Tests goods" for f in ../good/*.ept; do echec=0 @@ -235,6 +235,7 @@ while [ $# -gt 0 ]; do "-h" ) echo "usage : $0 " echo "options : " + echo "-clean : clean build dir" echo "-java : test of code generation (java code)" echo "-c : test of code generation (c code)" echo "-all : test all" diff --git a/test/good/bad_updown.ept b/test/good/bad_updown.ept index 771ed38..30ee967 100644 --- a/test/good/bad_updown.ept +++ b/test/good/bad_updown.ept @@ -1,12 +1,12 @@ node updown(b : bool) returns (o : bool) -var o',on_off:bool; +var o2,on_off:bool; let on_off = true; automaton state Down - do o' = false until on_off then Up + do o2 = false until on_off then Up state Up - do o' = true until on_off then Down + do o2 = true until on_off then Down end; - o = merge b (true-> o') (false -> false) + o = merge b (true-> o2) (false -> false) tel diff --git a/test/good/flatten.ept b/test/good/flatten.ept index e9c656f..d78765e 100644 --- a/test/good/flatten.ept +++ b/test/good/flatten.ept @@ -3,12 +3,12 @@ node f(x,y : int; b : bool) returns (z : int) var t : int; let do - var t2,t2' : int; in - t2 = if b then 0 else t2'; + var t2,t22 : int; in + t2 = if b then 0 else t22; do var t3 : int; in t3 = y + t; - t2' = t3; + t22 = t3; done; t = x + t2; done; diff --git a/test/good/statics2.ept b/test/good/statics2.ept index 22b5768..fd13fb9 100644 --- a/test/good/statics2.ept +++ b/test/good/statics2.ept @@ -24,9 +24,9 @@ let o = f<>(); tel -fun h() returns (y,y':int) +fun h() returns (y,y2:int) let y = c2 + g<>() + i<>(); - y' = c2 + Statics.g<>() + Statics.i<>(); + y2 = c2 + Statics.g<>() + Statics.i<>(); tel diff --git a/test/good/t1.ept b/test/good/t1.ept index d078cf8..a5aec34 100644 --- a/test/good/t1.ept +++ b/test/good/t1.ept @@ -17,7 +17,7 @@ node mm(x: int) returns (o: int) end tel -node mmm(x: int) returns (o': int) +node mmm(x: int) returns (o2: int) var last m: int = 1; o: int; let automaton @@ -26,21 +26,21 @@ node mmm(x: int) returns (o': int) state J do m = last m + 1; o = 0 end; - o' = 1 -> pre o + o2 = 1 -> pre o tel node m(x: int) returns (o: int) - var last o' : int = 1; + var last o2 : int = 1; let automaton state I - do o' = 1 - unless (last o' = 2) then J + do o2 = 1 + unless (last o2 = 2) then J state J - do o' = 3 - unless (last o' = 1) then I + do o2 = 3 + unless (last o2 = 1) then I end; - o = o'; + o = o2; tel node h(z: int; x, y: int) returns (o2: int) diff --git a/test/good/t2.ept b/test/good/t2.ept index c4a695e..d770bb8 100644 --- a/test/good/t2.ept +++ b/test/good/t2.ept @@ -32,13 +32,13 @@ node g(x: bool) returns (o: bool) tel node hhh() returns () - var last o' : int = 0; + var last o2 : int = 0; let automaton state S1 var r: int; - do o' = 1; r = 2 - unless last o' = 0 then S1 + do o2 = 1; r = 2 + unless last o2 = 0 then S1 end tel diff --git a/test/good/t9.ept b/test/good/t9.ept index ea95ed0..b2902f7 100644 --- a/test/good/t9.ept +++ b/test/good/t9.ept @@ -4,8 +4,8 @@ node f(x,z:int) returns (o1,o2:int) let switch (x = z) - | true var o'1: int; o'2: int; - do (o'1, o'2) = (1, 2); o1 = o'1; o2 = o'2; + | true var o12: int; o22: int; + do (o12, o22) = (1, 2); o1 = o12; o2 = o22; | false do (o2, o1) = (3, 3); end tel diff --git a/test/good/test.ept b/test/good/test.ept index 1fd9d38..5e04bc2 100644 --- a/test/good/test.ept +++ b/test/good/test.ept @@ -11,12 +11,12 @@ let tel -node updown'() returns (y:int) +node updown2() returns (y:int) let y = (0 fby y) + 1 tel node main() returns (y:int) let - y = updown'(); + y = updown2(); tel diff --git a/test/good/when_merge1.ept b/test/good/when_merge1.ept index eeedb0c..2449542 100644 --- a/test/good/when_merge1.ept +++ b/test/good/when_merge1.ept @@ -25,7 +25,7 @@ node mm(x: int) returns (o: int) end tel -node mmm(x: int) returns (o': int) +node mmm(x: int) returns (o2: int) var last m: int = 1; o: int; let automaton @@ -34,21 +34,21 @@ node mmm(x: int) returns (o': int) state J do m = last m + 1; o = 0 end; - o' = 1 -> pre o + o2 = 1 -> pre o tel node m(x: int) returns (o: int) - var last o' : int = 1; + var last o2 : int = 1; let automaton state I - do o' = 1 - unless (last o' = 2) then J + do o2 = 1 + unless (last o2 = 2) then J state J - do o' = 3 - unless (last o' = 1) then I + do o2 = 3 + unless (last o2 = 1) then I end; - o = o'; + o = o2; tel node h(z: int; x, y: int) returns (o2: int) From d9ed1de9c5fc37c90e8277e0fd736b489f630962 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 7 Feb 2011 14:25:57 +0100 Subject: [PATCH 09/24] java exemple --- test/async/Wanted_Normalized_movie.java | 106 ++++++++++++++++++++++++ 1 file changed, 106 insertions(+) create mode 100644 test/async/Wanted_Normalized_movie.java diff --git a/test/async/Wanted_Normalized_movie.java b/test/async/Wanted_Normalized_movie.java new file mode 100644 index 0000000..650ea73 --- /dev/null +++ b/test/async/Wanted_Normalized_movie.java @@ -0,0 +1,106 @@ +package pipline_b; + +import java.util.concurrent.Callable; +import java.util.concurrent.ExecutionException; +import java.util.concurrent.Future; + +public class Wanted_Normalized_movie { + protected final int N;; + protected Async_mean_factory mean_factory;; + protected Substr[] substr_inst;; + protected Future v;; + protected boolean v_2;; + protected int[] v_4;; + protected boolean v_5;; + + + + public Wanted_Normalized_movie (int N) { + this.mean_factory = new Async_mean_factory(N); + this.substr_inst = new Substr[N]; + for (int i_3 = 0; i_3 m = null; + if (this.v_2) { v_3 = 0; } + else { v_3 = this.v.get(); }; + if (this.v_5) { v_6 = i; } + else { v_6 = this.v_4; }; + this.v_5 = false; + trash = v_3; + for (int i_2 = 0; i_2 out = substr_inst[i_2].step(v_6[i_2], trash); + im[i_2] = out.c0; + trash = out.c1; + }; + this.v_2 = false; + m = mean_factory.step(i); + this.v_4 = i; + this.v = m; + return im; + } + + + //params, class, step_result_type, step_args + public class Async_mean_factory { + Mean mean_inst; + int N; + Future result; + + public Async_mean_factory(int N) { + this.N = N; + this.mean_inst = new Mean(N); + } + + public void reset () { + this.mean_inst = new Mean(N); + this.result = null; + } + + public Future step(int[] i) { + if (null != result) // Wait for the last result to be completed, null if nothing to wait for. + try { + result.get(); + } catch (InterruptedException e1) { + // TODO Auto-generated catch block + e1.printStackTrace(); + } catch (ExecutionException e1) { + // TODO Auto-generated catch block + e1.printStackTrace(); + } + result = jeptagon.Pervasives.executor_cached.submit(new Async_mean_step(mean_inst, i)); + return result; + } + + class Async_mean_step implements Callable{ + int[] i; + Mean mean_inst; + public Async_mean_step(Mean mean_inst, int[] i) { + this.i = i; + this.mean_inst = mean_inst; + } + public Integer call () { + return mean_inst.step(i); + } + } + + + + } + + + + public static void main() { + + } + + public void reset () { + this.v_5 = true; + this.v_2 = true; + } +} \ No newline at end of file From c677f760098cbf33694ec9f5f81b5bef0c2eea9d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 7 Feb 2011 16:06:52 +0100 Subject: [PATCH 10/24] Fixes --- compiler/obc/java/java_printer.ml | 10 +++++----- compiler/obc/java/obc2java.ml | 7 ++++--- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/compiler/obc/java/java_printer.ml b/compiler/obc/java/java_printer.ml index 7c6d30e..1025f8b 100644 --- a/compiler/obc/java/java_printer.ml +++ b/compiler/obc/java/java_printer.ml @@ -59,7 +59,7 @@ and vd_list s1 s2 s3 ff vd_l = match vd_l with | _ -> fprintf ff "@[%a@]@\n" (print_list_r (var_dec true) s1 s2 s3) vd_l and field ff f = - fprintf ff "@[<2>%a%a%a%a %a%a;@]" + fprintf ff "@[<2>%a%a%a%a %a%a@]" protection f.f_protection static f.f_static final f.f_final @@ -148,15 +148,15 @@ and act ff = function exp e (print_list_r pcb """""") c_b_l | Aif (e,bt) -> - fprintf ff "@[if (%a) {@ %a@ }@]" exp e block bt + fprintf ff "@[@[if (%a) {@ %a@]@ }@]" exp e block bt | Aifelse (e,bt,bf) -> - fprintf ff "@[if (%a) {@ %a@ }@]@\n@[else {@ %a@ }@]" + fprintf ff "@[@[if (%a) {@ %a@ @]}@\n@[else {@ %a@]@ }@]" exp e block bt block bf | Ablock b -> fprintf ff "@[{@ %a@ }]" block b | Afor (x, i1, i2, b) -> - fprintf ff "@[for (%a = %a; %a<%a; %a++) {@ %a@ }@]" + fprintf ff "@[@[for (%a = %a; %a<%a; %a++) {@ %a@]@ }@]" (var_dec false) x exp i1 var_ident x.vd_ident @@ -172,7 +172,7 @@ let methode ff m = 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 + (print_list_r class_name "throws "","" ") m.m_throws block m.m_body let constructor ff m = diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index a7e3d24..8b12701 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -33,6 +33,7 @@ let import_async = [Names.qualname_of_string "java.util.concurrent.Future"; let throws_async = [Names.qualname_of_string "InterruptedException"; Names.qualname_of_string "ExecutionException"] +let mk_classe = mk_classe ~imports:import_async (** Additional classes created during the translation *) @@ -335,12 +336,12 @@ let create_async_classe async base_classe = let body = let act = Areturn (Emethod_call (Eval (Pthis id_inst), "step", exps_step)) in mk_block [act] - in mk_methode ~returns:ty_result body "call" + 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 ~imports:import_async ~fields:fields ~constrs:[constructor] + mk_classe ~fields:fields ~constrs:[constructor] ~methodes:[step;reset] ~classes:[callable_class] classe_name @@ -419,7 +420,7 @@ let class_def_list classes cd_l = let body = block param_env oreset.Obc.m_body in mk_methode body "reset" in - let classe = mk_classe ~imports:import_async ~fields:fields + let classe = mk_classe ~fields:fields ~constrs:[constructeur] ~methodes:[step;reset] class_name in classe::classes in From 86f743318b824d00b759ec55a1a7e5bb58f37fc0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 14 Feb 2011 15:21:57 +0100 Subject: [PATCH 11/24] Fixes and basic Java main. --- compiler/global/global_printer.ml | 22 ++-- compiler/main/mls2obc.ml | 7 +- compiler/obc/control.ml | 1 + compiler/obc/java/java.ml | 16 +++ compiler/obc/java/java_main.ml | 63 +++++++++++- compiler/obc/java/java_printer.ml | 45 ++++---- compiler/obc/java/obc2java.ml | 55 +++++----- compiler/obc/obc.ml | 77 -------------- compiler/obc/obc_utils.ml | 97 ++++++++++++++++++ compiler/utilities/global/compiler_options.ml | 4 +- lib/java/jeptagon.jar | Bin 5291 -> 0 bytes test/async/java_m | 4 +- test/async/pipline_a.ept | 10 ++ test/good/t13.ept | 2 +- 14 files changed, 259 insertions(+), 144 deletions(-) delete mode 100644 lib/java/jeptagon.jar diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index 91b1f7a..dd4aee3 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -8,26 +8,30 @@ open Format open Pp_tools -let rec _print_modul ff m = match m with +let rec _aux_print_modul ?(full=false) ff m = match m with | Pervasives -> () | LocalModule -> () - | _ when m = g_env.current_mod -> () + | _ 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." _print_modul m print_name n + | 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 ff m = match m with +let _print_modul ?(full=false) ff m = match m with | Pervasives -> () | LocalModule -> () - | _ when m = g_env.current_mod -> () + | _ 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" _print_modul m print_name n + | 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 ff { qual = q; name = n} = match q with +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 -> print_name ff n - | _ -> fprintf ff "%a%a" _print_modul q print_name 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 diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 792840b..7c2248d 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -13,9 +13,10 @@ open Names open Idents open Signature open Obc +open Obc_utils +open Obc_mapfold open Types open Static -open Obc_mapfold open Initial @@ -225,9 +226,9 @@ let size_from_call_context c = match c with let empty_call_context = None -(** [si] is the initialization actions used in the reset method. +(** [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) = diff --git a/compiler/obc/control.ml b/compiler/obc/control.ml index 8bb2a5c..28319a6 100644 --- a/compiler/obc/control.ml +++ b/compiler/obc/control.ml @@ -14,6 +14,7 @@ open Minils open Idents open Misc open Obc +open Obc_utils open Clocks let var_from_name map x = diff --git a/compiler/obc/java/java.ml b/compiler/obc/java/java.ml index fe85372..734c7de 100644 --- a/compiler/obc/java/java.ml +++ b/compiler/obc/java/java.ml @@ -76,6 +76,7 @@ and act = Anewvar of var_dec * exp | Areturn of exp 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 @@ -87,8 +88,10 @@ and exp = Eval of pattern | Sfloat of float | Sbool of bool | Sconstructor of constructor_name + | Sstring of string | Snull + and pattern = Pfield of pattern * field_name | Pclass of class_name | Pvar of var_ident @@ -107,6 +110,19 @@ let default_value ty = match ty with | Tunit -> Evoid | Tarray _ -> Enew_array (ty,[]) + +let java_pervasives = Names.modul_of_string "jeptagon.Pervasives" +let java_pervasives_class = 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) let mk_var_dec x ty = diff --git a/compiler/obc/java/java_main.ml b/compiler/obc/java/java_main.ml index 485d29e..776e2aa 100644 --- a/compiler/obc/java/java_main.ml +++ b/compiler/obc/java/java_main.ml @@ -1,10 +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; - output_program dir p_java \ No newline at end of file + + (* 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] ~throws:throws_async body "main" + in + let c = mk_classe ~imports:import_async ~fields:[field_step_dnb] ~methodes:[main_methode] class_name in + output_program dir [c] + ) + + + + + + + + diff --git a/compiler/obc/java/java_printer.ml b/compiler/obc/java/java_printer.ml index 1025f8b..ca5fdb7 100644 --- a/compiler/obc/java/java_printer.ml +++ b/compiler/obc/java/java_printer.ml @@ -68,6 +68,7 @@ and field ff f = (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 @@ -83,6 +84,7 @@ and exp ff = function | 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) = @@ -101,18 +103,19 @@ and op ff (f, e_l) = | 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 + |"+." | "-." | "*." | "/." + | "=" | "<>" | "<" | "<=" + | ">" | ">=" | "&" | "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 - | _ -> Misc.unsupported "java_printer" 1) + | 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 @@ -127,16 +130,18 @@ and pattern ff = function let rec block ff b = fprintf ff "%a%a" (vd_list """;"";") b.b_locals - (print_list_r act """;"";") b.b_body + (print_list_r act """""") b.b_body +(* and switch_hack ff c_b_l = fprintf ff "@[ default :\\Dead code. Hack to prevent \"may not be initialized\" java error.@ %a@ break;@]" block (c_b_l |> List.hd |> snd) +*) and act ff = function - | Anewvar (vd,e) -> fprintf ff "@[<2>%a =@ %a@]" (var_dec false) vd exp e - | Aassgn (p,e) -> fprintf ff "@[<2>%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 + | 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 "@[case %a:@ %a@ break;@]" bare_constructor_name c block b in @@ -148,25 +153,25 @@ and act ff = function exp e (print_list_r pcb """""") c_b_l | Aif (e,bt) -> - fprintf ff "@[@[if (%a) {@ %a@]@ }@]" exp e block bt + fprintf ff "@[if (%a) {@ %a }@]" exp e block bt | Aifelse (e,bt,bf) -> - fprintf ff "@[@[if (%a) {@ %a@ @]}@\n@[else {@ %a@]@ }@]" + fprintf ff "@[@[if (%a) {@ %a@]@ @[} else {@ %a@]@ }@]" exp e block bt block bf - | Ablock b -> fprintf ff "@[{@ %a@ }]" block b + | Ablock b -> if (List.length b.b_body > 0) then fprintf ff "@[@[{@ %a@]@ }@]" block b | Afor (x, i1, i2, b) -> - fprintf ff "@[@[for (%a = %a; %a<%a; %a++) {@ %a@]@ }@]" + fprintf ff "@[@[for (%a = %a; %a<%a; %a++) {@ %a@]@ }@]" (var_dec false) x exp i1 var_ident x.vd_ident exp i2 var_ident x.vd_ident block b - | Areturn e -> fprintf ff "return %a" exp e + | Areturn e -> fprintf ff "return %a;" exp e let methode ff m = - fprintf ff "@[%a%a%a %a @[<2>(%a)@] @[%a@]{@ %a@]@\n}" + fprintf ff "@[%a%a%a %a @[<4>(%a)@] @[%a@]{@ %a@]@\n}" protection m.m_protection static m.m_static ty m.m_returns @@ -176,7 +181,7 @@ let methode ff m = block m.m_body let constructor ff m = - fprintf ff "@[%a%a @[<2>(%a)@] {@\n%a@]@\n}" + fprintf ff "@[%a%a @[<4>(%a)@] {@\n%a@]@\n}" protection m.m_protection method_name m.m_name (print_list_r (var_dec false) """,""") m.m_args @@ -191,13 +196,13 @@ let rec class_desc ff cd = and classe ff c = match c.c_kind with | Cenum c_l -> - fprintf ff "@[<4>%a%aenum %a {@\n%a@]@\n}" + 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 "@[<4>%a%aclass %a @[%a@]{@\n%a@]@\n}" + fprintf ff "@\n@[<4>%a%aclass %a @[%a@]{@\n%a@]@\n}" protection c.c_protection static c.c_static bare_class_name c.c_name @@ -218,7 +223,7 @@ let output_classe base_dir c = let ff = Format.formatter_of_out_channel oc in pp_set_margin ff 120; fprintf ff "package %a;@\n@[%a@]@\n%a@." - Global_printer.print_modul package + 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 diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index 8b12701..aac12f4 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -21,18 +21,9 @@ open Names open Modules open Signature open Obc +open Obc_utils open Java -let java_pervasives = Names.modul_of_string "jeptagon.Pervasives" -let java_pervasives_class = 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_classe = mk_classe ~imports:import_async @@ -49,10 +40,10 @@ let fresh_for size body = 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 ?(full=false) m = match m with +let rec translate_modul m = match m with | Pervasives | LocalModule -> m - | _ when m = g_env.current_mod && not full -> 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 } @@ -67,7 +58,7 @@ let qualname_to_class_name q = (** a [Module.name] becomes a [module.Name] even on current_mod *) let qualname_to_package_classe q = - { qual = translate_modul ~full:true q.qual; name = String.capitalize q.name } + { 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 @@ -356,9 +347,18 @@ let class_def_list classes cd_l = 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 = + 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 in (* [obj_env] gives the type of an [obj_ident], needed in async because we change the classe for async obj *) - let constructeur, param_env, obj_env = + 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 @@ -367,28 +367,32 @@ let class_def_list classes cd_l = in Idents.Env.add od.o_ident t obj_env in List.fold_left aux Idents.Env.empty cd.cd_objs in + let body = (* TODO java array : also initialize arrays with [ new int[3] ] *) (* Initialize the objects *) let obj_init_act acts od = let params = List.map (static_exp param_env) od.o_params in - let act = match od.o_size with + 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)) ] + (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 ] - in act@acts + (Aassgn (Pthis od.o_ident, Enew_array (Tarray (t,size), []))) + :: (fresh_for size assgn_elem) + :: acts in - let acts_init_params = copy_to_this vds_params in - let acts = List.fold_left obj_init_act acts_init_params cd.cd_objs in + (* 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 + (* init static params *) + let acts = (copy_to_this vds_params)@acts in { b_locals = []; b_body = acts } - in - mk_methode ~args:vds_params body (shortname class_name), param_env, obj_env + 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 @@ -415,11 +419,6 @@ let class_def_list classes cd_l = 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" in - let reset = - let oreset = find_reset_method cd in - let body = block param_env oreset.Obc.m_body in - mk_methode body "reset" - in let classe = mk_classe ~fields:fields ~constrs:[constructeur] ~methodes:[step;reset] class_name in classe::classes diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index 235dc9c..aa8ab0f 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -108,80 +108,3 @@ type program = p_consts : const_dec list; p_defs : class_def list } -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 - diff --git a/compiler/obc/obc_utils.ml b/compiler/obc/obc_utils.ml index aa37f04..b9c2348 100644 --- a/compiler/obc/obc_utils.ml +++ b/compiler/obc/obc_utils.ml @@ -8,12 +8,108 @@ (**************************************************************************) 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 @@ -69,3 +165,4 @@ struct let (_, deps) = Obc_mapfold.program funs S.empty p in S.remove p.p_modname (S.remove Pervasives deps) end +*) \ No newline at end of file diff --git a/compiler/utilities/global/compiler_options.ml b/compiler/utilities/global/compiler_options.ml index 1a0a3ac..adcd62b 100644 --- a/compiler/utilities/global/compiler_options.ml +++ b/compiler/utilities/global/compiler_options.ml @@ -54,10 +54,10 @@ let assert_nodes : name list ref = ref [] let add_assert nd = assert_nodes := nd :: !assert_nodes let simulation = ref false -let simulation_node : name option ref = ref None +let simulation_node : name ref = ref "" let set_simulation_node s = simulation := true; - simulation_node := Some s + simulation_node := s let create_object_file = ref false diff --git a/lib/java/jeptagon.jar b/lib/java/jeptagon.jar deleted file mode 100644 index 8845563780f8de722b45715ac9810b327c1dd7cf..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 5291 zcmbW5cQjnv+s8+5lVEg$nJ`9lq6@(&V;IpAB@$hTUP6d2(W6|67M-Y9v?w8>jH{FA z#ML{|iIU)*`6cg-Soh|S>{(~6Gi&YrIs2UNv-f_UuZAifJ~e=tm>A&bFE0Z)(?|gL z0F+Cg=7s;Tnw z^pXC@wGiYpvo&#XvD4^8qGhS2V_RCXOPA3{OX`l4+5%xx zyyMjP8F?S3d_cj`6fkJuKv1$EkXEp``h_Dyjk^y|z)YB&ky6H-Vj@XU+#+Rvs*(_wC6MjWxZ`$1dQZQy z*6naa*w}VEU1IC;>|!#E zs$LfKq8ddZ2DHE?X46Xrq&LwX1TGx>8mUb2D)-`rmYz6E&I$N}+(M3(?&zV`Op1GZ zW$8`vkIAqR(sp`KdKm`*Xu@2-`Mrg{fA5$vB(5fP(5ZA*A_(`sS%g!^jD3-_k3+wWn?BNa15v05b?$r1iuz0ZlRyI8{jvxBVE|-ayeN{<9#(^r?0@i*=`+3h zO5yro&oZ0DmvUIZJkcv^_ud`E!9`Y&f%ZWfBd0;V;?>u$bV<}7p~|b)=Y||<56zrr zx!g|V4g|^n*2AZ}KNR#7kBNa^l!u=1B13_;Ao-y=$BTM&tGe)hGxW}`@<^2yY5m3) zm;whreQHTq_o~Op01ki3B8|G9VWPT52p7#)D=51DAdlaqWRrPp-mqTK{5AcmX*`>z+&kNDMZ;W2ri2`jl-d?UTP!GD7)))c|^iwS?*u9yJ1+p zR+lOyOfh7|XhnKZpOE|rm4(qWJk5*HORC~#n|qzW z&>oGn)t52$7m@pQkc}IwK<8olgdqT2s1fg!g*vam@o`3i4PJ}!&zhzF9s6ZPd7ja$e_4Zyt?5!Q=fa0CK(1Yd3FW}P=NooQs9iW0ho5&)%S z#p`a|tf_sszWcuuNN9kwNiR&cQAjn&;)%s`3shrJfE|ue7C5^4{xY8QfO5s9ga6Na`PVDqZ!t13%(y@z1xG&QsxW$sta?! zvC|_J^_ZbvNX=v1w?I|3f7Na!yG*U8S*_!-TFdQJ8-wZH4QqqmLjCRgadk;FQ45K~ zJ4zdp-h~i;U`xa#(k6YZMfT&Dx1vD|=4K&aMzpwUvPBp)G%p~z!AsTck!QKtg70U0 zt7H4yEFaLmFGgNkBUj%Rja9xT;P4G3J}Cdns1ns*f@FoNrCmY9k`UmUJ@YdDV=LyG zoP^9Duq!v7&f&kDL!@%RmV(OXv%_>}iNh|Oe&{x9ED9gV>|iGyDh+L;!zw-7O<|af zQJNp`w>MeQZ%S8S7VWGo^`GkU5pXa>0BABvV%aVejN>GSi)#{7BJSuS&+SZo$sBeV zeHbgD$L2JJw~$4#Q6Z~0#a*UTTrhB4lUjRPe@z;X(~KX7SyeKqw5z14q@$#zq^BeU zl527s+{Z&~zG7!%JTDd3-(e*3v21jV?t{apIJ3Q@SJWYimL_R*bTs^2ceUPTKh)nU zo1yuOJ4~0R7!<`i5;-nKy|nNy^|N=+5HD1GWul)Vzh+=0e;0qb-S0%slPld9 zL?!GNcL0=d*AXdTYPn8qHm2M>vPCK4=G`1&+tnH!!@Nx?R_4U|(a1pMy`STgZQRz7 z>Br7#S}lwz-b&u@OG6}woVMI%E@e8{vXB+{P^Z;t-;Yf=vz_dK)=Wqz5B#M-*Cf#maBsm2Bm$usu0z%v7atpWS-CO)6Z@lg zK_X;ip#-cA%8+$t8WYXp(d0)xy?ZH-EWhpy@3R7utn^AsESs7o(S&FYw04jXnl?~a zLr{aJZPx}@bv#3Cr+|&0UMK1id@$`3NdoKyyvfn8K{97pRoUA8pnEk*OxVF{V&HAQ zhw4t;f?fAmlDqH*#rusf{?{ca4h-MFi2JS9 zbXWM-#4xuv!!6PSwtxHCWi^zvX_)I->X|qiGo>#YF&A`(iqR7d)@u)qFV7>Svx1M| zpW@}xo6s?Iid-PQ19zyuZK6X-g3yJiWul5DcTp=!15#Wu6${63S4ajOf}dj-ly53O z$x)a5!5vY|zI&%nUA`DZ?;Sx-^eub z-3-r39H_$E5yOT_)EWS16cZ-%zYG(Gf3Hiv#m7^vJ2$B0sHNezgZQ`=3q$g#Uz?IO zwNx5sHpeT0K)9%n2lsROUzBxAs(#MetRg0-VEKx3!r8Re(GhOn#<8FLx669U=%dB` z?md10%2uD#cvPN%TXC+GYfEXSNa3b&4PDy9U6qCjv7ms;+@@&xQ1|@TY^8DAcA@)M z98?ChCZ6TxzJ-*gZb#ulCE1vjeKz6T-fDRM6@f8~+^|T)_r33WohYJ1lO5dO@e!Em z_S3DGt}==paYYvn)|1VRo%mHx``auDoQ&qC=N_@#vvjL)UwmETbIIzX3+zxU_;&sW zX669^f4pwd5Fu;p=~Mp zS8{Ngc|*+6-Vz1z?)*P(`50o`-QSi?#_CJTHk7yF#RkbD8P_>)Epx@y?jbML95j; z;1tu|P6x3JLi$b#u;dWt5V;$CDaMLeDQ6Vsi#^&g{(^=o4lXs|XV2vS4H2wo@^kyg z1i?Be=ZBs(FtCovk0y<|{b%SI{{%}Q1^l|c z?B8vWv#)`rovki^rWs*A%#TT&qkS*(&(qG> (i fby i, 0 -> !(pre m)) tel + +node main () returns (r:int) +var f: int^100; nf: int^100; x: int; +let + x = 0 fby x+1; + f = x^100; + nf = normalized_movie<<100>>(f); + r = mean<<100>>(nf) +tel + diff --git a/test/good/t13.ept b/test/good/t13.ept index 499cffb..7b64049 100644 --- a/test/good/t13.ept +++ b/test/good/t13.ept @@ -1,6 +1,6 @@ node count(c : int; r : bool) returns (res : int) let -(* res = c fby (if r then 0 else res + c);*) + res = c fby (if r then 0 else res + c); res = 0; tel From 979a6cfbd549765f5858c83d3446f2a3f2857075 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 14 Feb 2011 15:22:13 +0100 Subject: [PATCH 12/24] Do stuff in pervasives. --- lib/java/jeptagon/Pervasives.java | 10 ++++++++++ lib/pervasives.epi | 2 +- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/lib/java/jeptagon/Pervasives.java b/lib/java/jeptagon/Pervasives.java index 69d1e77..2c1b6bb 100644 --- a/lib/java/jeptagon/Pervasives.java +++ b/lib/java/jeptagon/Pervasives.java @@ -95,4 +95,14 @@ public class Pervasives { c6 = v6; } } + + public static int do_stuff(int coeff) { + int x = 13; + for (int i = 0; i < coeff; i++) { + for (int j = 0; j < 1000000; j++) { + x = (x + j) % (x + j/x) + 13; + } + } + return x; + } } diff --git a/lib/pervasives.epi b/lib/pervasives.epi index 2e76e49..0b66f7c 100644 --- a/lib/pervasives.epi +++ b/lib/pervasives.epi @@ -27,4 +27,4 @@ val fun (or)(bool;bool) returns (bool) val fun (xor)(bool;bool) returns (bool) val fun (~-)(int) returns (int) val fun (~-.)(float) returns (float) - +val fun do_stuff(int) returns (int) From 3aea2dc6fbfc6c1c862b19cf46aa20494b928460 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 14 Feb 2011 15:32:56 +0100 Subject: [PATCH 13/24] gitignore and todo. --- .gitignore | 6 +++++- todo.txt | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index 21fc555..d78b817 100644 --- a/.gitignore +++ b/.gitignore @@ -18,8 +18,12 @@ _build *.c *.h *.o +*.java +*.class +*.log *. *.epci *.epo *.dot -test/*.ml \ No newline at end of file +test/*.ml +test/_check_builds diff --git a/todo.txt b/todo.txt index c0d9cde..fb8a486 100644 --- a/todo.txt +++ b/todo.txt @@ -17,4 +17,4 @@ Plus ou moins ordonné du plus urgent au moins urgent. *- Permettre la définition de constantes locales. -*- Optimiser le reset en utilisant un memcopy ? +*- Optimiser le reset en utilisant un memcopy ? ou autre chose ? From 9631d9b3110170e033a82bae2582ba402851da13 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 14 Feb 2011 16:28:50 +0100 Subject: [PATCH 14/24] Typing bug fix. --- compiler/global/global_printer.ml | 2 +- compiler/global/types.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index dd4aee3..674a9d0 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -73,7 +73,7 @@ and print_type ff = function | Tid id -> print_qualname ff id | Tarray (ty, n) -> fprintf ff "@[%a^%a@]" print_type ty print_static_exp n - | Tunit -> fprintf ff "()" + | Tunit -> fprintf ff "unit" | Tasync (a, t) -> fprintf ff "%a%a" print_async (Some a) print_type t let print_field ff field = diff --git a/compiler/global/types.ml b/compiler/global/types.ml index 036e99f..d9105ab 100644 --- a/compiler/global/types.ml +++ b/compiler/global/types.ml @@ -38,7 +38,7 @@ and ty = let invalid_type = Tprod [] (** Invalid type given to untyped expression etc. *) let prod = function - | [] -> assert false + | [] -> Tunit | [ty] -> ty | ty_list -> Tprod ty_list From 159bab2a5578c38c09b6b2bd8bd3c32e5f44fbd6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Tue, 8 Mar 2011 13:41:28 +0100 Subject: [PATCH 15/24] async constants. --- compiler/global/global_compare.ml | 5 ++- compiler/global/global_mapfold.ml | 3 ++ compiler/global/global_printer.ml | 1 + compiler/global/modules.ml | 2 +- compiler/global/static.ml | 2 ++ compiler/global/types.ml | 1 + compiler/heptagon/analysis/typing.ml | 3 ++ compiler/heptagon/parsing/hept_parser.mly | 15 +++++---- compiler/heptagon/parsing/hept_parsetree.ml | 1 + .../parsing/hept_parsetree_mapfold.ml | 3 ++ compiler/heptagon/parsing/hept_scoping.ml | 1 + compiler/minils/main/mls2seq.ml | 12 +++++-- compiler/minils/transformations/tomato.ml | 4 +++ compiler/obc/_tags | 2 +- compiler/obc/java/java.ml | 4 +-- compiler/obc/java/obc2java.ml | 13 ++++++-- compiler/obc/obc.ml | 16 +++++++++ compiler/obc/obc_mapfold.ml | 3 ++ compiler/obc/obc_printer.ml | 2 ++ lib/java/jeptagon/Pervasives.java | 33 +++++++++++++++++-- test/async/lent.ept | 12 +++++++ test/async/rapide_lent.ept | 24 ++++++++++++++ test/async/rapide_lent_a.ept | 24 ++++++++++++++ test/async/tt.ept | 12 +++++++ test/async/ttt.ept | 18 ++++++++++ tools/debugger_script | 2 -- 26 files changed, 198 insertions(+), 20 deletions(-) create mode 100644 test/async/lent.ept create mode 100644 test/async/rapide_lent.ept create mode 100644 test/async/rapide_lent_a.ept create mode 100644 test/async/tt.ept create mode 100644 test/async/ttt.ept diff --git a/compiler/global/global_compare.ml b/compiler/global/global_compare.ml index d216388..3f3279f 100644 --- a/compiler/global/global_compare.ml +++ b/compiler/global/global_compare.ml @@ -83,7 +83,10 @@ let rec static_exp_compare se1 se2 = | Sfield _, (Svar _ | Sint _ | Sfloat _ | Sbool _ | Sconstructor _) -> -1 | Sfield _, _ -> 1 - | Stuple _, (Srecord _ | Sop _ | Sarray _ | Sarray_power _) -> 1 + | Sasync _, (Svar _ | Sint _ | Sfloat _ | Sbool _ | Sconstructor _ | Sfield _) -> -1 + | Sasync _, _ -> 1 + + | Stuple _, (Srecord _ | Sop _ | Sarray _ | Sarray_power _ ) -> 1 | Stuple _, _ -> -1 | Sarray_power _, (Srecord _ | Sop _ | Sarray _) -> -1 diff --git a/compiler/global/global_mapfold.ml b/compiler/global/global_mapfold.ml index c3e9cff..0feecef 100644 --- a/compiler/global/global_mapfold.ml +++ b/compiler/global/global_mapfold.ml @@ -49,6 +49,9 @@ 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 diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index 674a9d0..0c6181a 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -62,6 +62,7 @@ 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 diff --git a/compiler/global/modules.ml b/compiler/global/modules.ml index 807f3e1..0e67698 100644 --- a/compiler/global/modules.ml +++ b/compiler/global/modules.ml @@ -165,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 diff --git a/compiler/global/static.ml b/compiler/global/static.ml index 23ce68c..c4f6bb9 100644 --- a/compiler/global/static.ml +++ b/compiler/global/static.ml @@ -74,6 +74,8 @@ 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]. diff --git a/compiler/global/types.ml b/compiler/global/types.ml index d9105ab..cf8b819 100644 --- a/compiler/global/types.ml +++ b/compiler/global/types.ml @@ -27,6 +27,7 @@ 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 *) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 9edef47..4e45722 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -449,6 +449,9 @@ 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 diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index fbd6e8d..8ddcd4f 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -427,6 +427,7 @@ 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 } @@ -555,14 +556,14 @@ qualname: ; -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 } - | q=qualified (ident) - { Svar q } + | INT { Sint $1 } + | FLOAT { Sfloat $1 } + | BOOL { Sbool $1 } + | constructor { Sconstructor $1 } + | q=qualified(ident) { Svar q } ; tuple_exp: diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index 5a43790..f4240b6 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -49,6 +49,7 @@ 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 diff --git a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml index 7a8c3d0..566688b 100644 --- a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml +++ b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml @@ -104,6 +104,9 @@ 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 diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index 695d3ad..3fe1171 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -201,6 +201,7 @@ 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 diff --git a/compiler/minils/main/mls2seq.ml b/compiler/minils/main/mls2seq.ml index 8246590..962e1f6 100644 --- a/compiler/minils/main/mls2seq.ml +++ b/compiler/minils/main/mls2seq.ml @@ -18,6 +18,7 @@ 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) @@ -39,7 +40,7 @@ let write_obc_file p = comment "Generation of Obc code" let targets = [ (*"c", Obc_no_params Cmain.program;*) - "java", Obc Java_main.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 ] @@ -65,10 +66,17 @@ 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 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. *) let program p = diff --git a/compiler/minils/transformations/tomato.ml b/compiler/minils/transformations/tomato.ml index 9352d46..fbef80b 100644 --- a/compiler/minils/transformations/tomato.ml +++ b/compiler/minils/transformations/tomato.ml @@ -67,6 +67,10 @@ module PatEnv = type penv_t = (int * exp * ident list) P.t + + (* An environment used for automata minimization: holds both a pattern environment mapping patterns to equivalence + classes, and a [(pat * int list) Env.t] that maps variable [x] to a [(pat, pth)] tuple where [pat] is the pattern + holding [x] at path [pth] *) type t = penv_t * (pat * int list) Env.t let empty = (P.empty, Env.empty) diff --git a/compiler/obc/_tags b/compiler/obc/_tags index c1549be..387e977 100644 --- a/compiler/obc/_tags +++ b/compiler/obc/_tags @@ -1 +1 @@ - or :include \ No newline at end of file + or or :include diff --git a/compiler/obc/java/java.ml b/compiler/obc/java/java.ml index 734c7de..4a415b8 100644 --- a/compiler/obc/java/java.ml +++ b/compiler/obc/java/java.ml @@ -111,8 +111,8 @@ let default_value ty = match ty with | Tarray _ -> Enew_array (ty,[]) -let java_pervasives = Names.modul_of_string "jeptagon.Pervasives" -let java_pervasives_class = Names.qualname_of_string "jeptagon.Pervasives" +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" diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index aac12f4..99f5361 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -15,6 +15,9 @@ 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 @@ -97,6 +100,9 @@ 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 @@ -110,7 +116,7 @@ and boxed_ty param_env t = match t with and tuple_ty param_env ty_l = let ln = ty_l |> List.length |> Pervasives.string_of_int in - Tgeneric ({ qual = java_pervasives; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l) + Tgeneric (java_pervasive_class ("Tuple"^ln), List.map (boxed_ty param_env) ty_l) and ty param_env t :Java.ty = match t with | Types.Tprod ty_l -> tuple_ty param_env ty_l @@ -197,6 +203,9 @@ let rec act_list param_env act_l 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 @@ -304,7 +313,7 @@ let create_async_classe async base_classe = let act_result = let exp_call = let args = var_inst::exps_step in - let executor = Eval (Pfield (Pclass java_pervasives_class, "executor_cached")) 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 diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index aa8ab0f..bd67ce5 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -8,6 +8,21 @@ (**************************************************************************) (* Object code internal representation *) +(** { 3 Semantics } + Any variable is a reference to a constant memory. + Thus [p = e] is not the change of the reference, + but a recursive copy of what is referenced (deep copy). + As an example, [x = 3] but also [x = \[3; 4; 5\]] + and [t1 = t2] with the content of the array [t2] copied into the array [t1]. + Obc is also "SSA" in the sens that a variable is assigned a value only once per call of [step] etc. + Thus arguments are passed as constant references to a constant memory. + + One exception to the SSA rule is through the [mutable] variables. + Theses variables can be assigned multiple times. + Thus a [mutable] argument is passed as a reference to a constant memory. +*) + + open Misc open Names open Idents @@ -69,6 +84,7 @@ type act = | 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 and block = { b_locals : var_dec list; diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml index 9d131a6..27707d9 100644 --- a/compiler/obc/obc_mapfold.ml +++ b/compiler/obc/obc_mapfold.ml @@ -115,6 +115,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 = diff --git a/compiler/obc/obc_printer.ml b/compiler/obc/obc_printer.ml index 4dbe75f..9efc2fe 100644 --- a/compiler/obc/obc_printer.ml +++ b/compiler/obc/obc_printer.ml @@ -108,6 +108,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 | [] -> () diff --git a/lib/java/jeptagon/Pervasives.java b/lib/java/jeptagon/Pervasives.java index 2c1b6bb..607c052 100644 --- a/lib/java/jeptagon/Pervasives.java +++ b/lib/java/jeptagon/Pervasives.java @@ -1,17 +1,46 @@ 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 java.util.concurrent.ExecutorService executor_cached = java.util.concurrent.Executors.newCachedThreadPool(); + public static final ExecutorService executor_cached = Executors.newCachedThreadPool(); + public static class StaticFuture implements Future { + V v; + + public StaticFuture(V v) { this.v = v; } + + public boolean cancel(boolean mayInterruptIfRunning) { return false; } + + public boolean isCancelled() { return false; } + + public boolean isDone() { return true; } + + public V get() { return v; } + + public V get(long timeout, TimeUnit unit) { return v; } + } - public static class Tuple1 { + public static class Tuple1 { public final T c0; public Tuple1(T v) { c0 = v; } } + public static class Tuple22 { + public final Object c0; + public final Object c1; + public Tuple22(Object v0, Object v1) { + c0 = v0; + c1 = v1; + } + } + public static class Tuple2 { public final T0 c0; public final T1 c1; diff --git a/test/async/lent.ept b/test/async/lent.ept new file mode 100644 index 0000000..3b87307 --- /dev/null +++ b/test/async/lent.ept @@ -0,0 +1,12 @@ + +node g () returns (y : int) +let + y = 3 +tel + +node f (x : int; c : bool) returns (z : int) +let + z = merge c (true -> (0 fby (g(z when true(c))))) (false -> 0) +tel + + diff --git a/test/async/rapide_lent.ept b/test/async/rapide_lent.ept new file mode 100644 index 0000000..ac0aa53 --- /dev/null +++ b/test/async/rapide_lent.ept @@ -0,0 +1,24 @@ + + +node lent(coeff:int) returns (y:int) +let + y = do_stuff(coeff); +tel + + +node rapide<>() returns (z:int) +var y,cpt : int; big_step : bool; +let + big_step = cpt = 0; + cpt = size fby (if big_step then size else cpt - 1); + y = merge big_step + (true -> 0 -> (pre (lent(size)))) + (false -> 0 fby y when false(big_step)); + z = do_stuff(1) - y; +tel + + +node main() returns(r: int) +let + r = rapide<<1000>>(); +tel diff --git a/test/async/rapide_lent_a.ept b/test/async/rapide_lent_a.ept new file mode 100644 index 0000000..1c53a99 --- /dev/null +++ b/test/async/rapide_lent_a.ept @@ -0,0 +1,24 @@ + + +node lent(coeff:int) returns (y:int) +let + y = do_stuff(coeff); +tel + + +node rapide<>() returns (z:int) +var y : int; cpt : int; big_step : bool; +let + big_step = cpt = 0; + cpt = size fby (if big_step then size else cpt - 1); + y = merge big_step + (true -> 0 -> !(pre (async lent(size)))) + (false -> 0 fby y when false(big_step)); + z = do_stuff(1) - y; +tel + + +node main() returns(r: int) +let + r = rapide<<1000>>(); +tel diff --git a/test/async/tt.ept b/test/async/tt.ept new file mode 100644 index 0000000..e77a98c --- /dev/null +++ b/test/async/tt.ept @@ -0,0 +1,12 @@ +node counter(res: bool; tick: bool) returns (o: int) +let + o = if res then 0 else if tick then 1 -> pre o + 1 else 0 -> pre o; +tel + +node counter2() returns (b: bool) +var t : async int; +let + t = async 0 fby async counter(false,true); + b = counter(false,true) -1 = !t; +tel + diff --git a/test/async/ttt.ept b/test/async/ttt.ept new file mode 100644 index 0000000..95c4ae6 --- /dev/null +++ b/test/async/ttt.ept @@ -0,0 +1,18 @@ +node counter(res: bool; tick: bool) returns (o: int) +let + o = if res then 0 else if tick then 1 -> pre o + 1 else 0 -> pre o; +tel + +node counter3() returns (t: async bool) +var last async t: int; cpt: int; +let + cpt = counter(false,true); + automaton + state I do + t = async counter(false,true))); + until true continue III + state III do + until cpt/3 = 0 continue I + end; + b = 0 fby cpt - 1 = 0 -> !t ; +tel \ No newline at end of file diff --git a/tools/debugger_script b/tools/debugger_script index d6911ff..1caea16 100644 --- a/tools/debugger_script +++ b/tools/debugger_script @@ -1,5 +1,3 @@ -load_printer "/sw/lib/ocaml/menhirLib/menhirLib.cmo" -load_printer "/sw/lib/ocaml/str.cma" load_printer "_build/global/names.d.cmo" load_printer "_build/global/location.d.cmo" load_printer "_build/utilities/misc.d.cmo" From cab8bb706efda8ac830861e5024c372104603fbc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Le=CC=81onard=20Ge=CC=81rard?= Date: Wed, 9 Mar 2011 00:02:30 +0100 Subject: [PATCH 16/24] backport from async. --- compiler/global/clocks.ml | 2 +- compiler/global/global_compare.ml | 15 --- compiler/global/global_mapfold.ml | 4 - compiler/global/global_printer.ml | 5 - compiler/global/modules.ml | 1 - compiler/global/static.ml | 2 - compiler/global/types.ml | 8 -- compiler/heptagon/analysis/causality.ml | 1 - compiler/heptagon/analysis/typing.ml | 27 +--- compiler/heptagon/hept_printer.ml | 4 - compiler/heptagon/heptagon.ml | 13 +- compiler/heptagon/parsing/hept_lexer.mll | 2 - compiler/heptagon/parsing/hept_parser.mly | 7 - compiler/heptagon/parsing/hept_parsetree.ml | 18 +-- .../parsing/hept_parsetree_mapfold.ml | 4 - compiler/heptagon/parsing/hept_scoping.ml | 11 +- compiler/main/hept2mls.ml | 3 +- compiler/main/mls2obc.ml | 9 +- compiler/minils/analysis/clocking.ml | 3 - compiler/minils/main/mls2seq.ml | 9 +- compiler/minils/minils.ml | 7 +- compiler/minils/mls_compare.ml | 2 +- compiler/minils/mls_printer.ml | 4 - compiler/minils/transformations/normalize.ml | 4 - compiler/minils/transformations/tomato.ml | 2 +- compiler/obc/c/c.ml | 2 - compiler/obc/c/c.mli | 2 - compiler/obc/c/cgen.ml | 17 --- compiler/obc/c/cmain.ml | 5 +- compiler/obc/c/csubst.ml | 1 - compiler/obc/java/java.ml | 10 -- compiler/obc/java/java_main.ml | 4 +- compiler/obc/java/java_printer.ml | 2 - compiler/obc/java/obc2java.ml | 126 +----------------- compiler/obc/java/old_java.ml | 3 - compiler/obc/obc.ml | 3 - compiler/obc/obc_mapfold.ml | 7 - compiler/obc/obc_printer.ml | 9 -- test/good/t13.ept | 1 - 39 files changed, 36 insertions(+), 323 deletions(-) diff --git a/compiler/global/clocks.ml b/compiler/global/clocks.ml index dd372a5..db7e3e1 100644 --- a/compiler/global/clocks.ml +++ b/compiler/global/clocks.ml @@ -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 diff --git a/compiler/global/global_compare.ml b/compiler/global/global_compare.ml index 3f3279f..141621c 100644 --- a/compiler/global/global_compare.ml +++ b/compiler/global/global_compare.ml @@ -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 diff --git a/compiler/global/global_mapfold.ml b/compiler/global/global_mapfold.ml index 0feecef..1af3f94 100644 --- a/compiler/global/global_mapfold.ml +++ b/compiler/global/global_mapfold.ml @@ -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 diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index 0c6181a..1d3bebe 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -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 "@[%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 diff --git a/compiler/global/modules.ml b/compiler/global/modules.ml index 0e67698..60fe474 100644 --- a/compiler/global/modules.ml +++ b/compiler/global/modules.ml @@ -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] *) diff --git a/compiler/global/static.ml b/compiler/global/static.ml index c4f6bb9..23ce68c 100644 --- a/compiler/global/static.ml +++ b/compiler/global/static.ml @@ -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]. diff --git a/compiler/global/types.ml b/compiler/global/types.ml index cf8b819..7ddbc79 100644 --- a/compiler/global/types.ml +++ b/compiler/global/types.ml @@ -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 } diff --git a/compiler/heptagon/analysis/causality.ml b/compiler/heptagon/analysis/causality.ml index 48799ee..289b470 100644 --- a/compiler/heptagon/analysis/causality.ml +++ b/compiler/heptagon/analysis/causality.ml @@ -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) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 4e45722..429660b 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -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 diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index e471ad9..7085fc5 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -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 diff --git a/compiler/heptagon/heptagon.ml b/compiler/heptagon/heptagon.ml index ec217c5..d702cbf 100644 --- a/compiler/heptagon/heptagon.ml +++ b/compiler/heptagon/heptagon.ml @@ -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) diff --git a/compiler/heptagon/parsing/hept_lexer.mll b/compiler/heptagon/parsing/hept_lexer.mll index 18da7d3..9f035a9 100644 --- a/compiler/heptagon/parsing/hept_lexer.mll +++ b/compiler/heptagon/parsing/hept_lexer.mll @@ -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) diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index 8ddcd4f..caf13f6 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -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 diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index f4240b6..ad2e5c1 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -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 } diff --git a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml index 566688b..912fefc 100644 --- a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml +++ b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml @@ -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 diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index 3fe1171..9789696 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -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 diff --git a/compiler/main/hept2mls.ml b/compiler/main/hept2mls.ml index 0de28cb..8b8c313 100644 --- a/compiler/main/hept2mls.ml +++ b/compiler/main/hept2mls.ml @@ -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 diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 7c2248d..33ae13b 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -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 diff --git a/compiler/minils/analysis/clocking.ml b/compiler/minils/analysis/clocking.ml index 06978f2..b13cc27 100644 --- a/compiler/minils/analysis/clocking.ml +++ b/compiler/minils/analysis/clocking.ml @@ -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 diff --git a/compiler/minils/main/mls2seq.ml b/compiler/minils/main/mls2seq.ml index 962e1f6..d13103c 100644 --- a/compiler/minils/main/mls2seq.ml +++ b/compiler/minils/main/mls2seq.ml @@ -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. *) diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index 6b0e9f3..97aa073 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -61,7 +61,7 @@ and edesc = | Eiterator of iterator_type * app * static_exp * exp list * var_ident option (** map f <> (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 = diff --git a/compiler/minils/mls_compare.ml b/compiler/minils/mls_compare.ml index 9c07fde..3425abb 100644 --- a/compiler/minils/mls_compare.ml +++ b/compiler/minils/mls_compare.ml @@ -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 diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index 70549f9..2ac3761 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -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 diff --git a/compiler/minils/transformations/normalize.ml b/compiler/minils/transformations/normalize.ml index 9fcab15..31aa9c6 100644 --- a/compiler/minils/transformations/normalize.ml +++ b/compiler/minils/transformations/normalize.ml @@ -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*) diff --git a/compiler/minils/transformations/tomato.ml b/compiler/minils/transformations/tomato.ml index fbef80b..809d824 100644 --- a/compiler/minils/transformations/tomato.ml +++ b/compiler/minils/transformations/tomato.ml @@ -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. *) diff --git a/compiler/obc/c/c.ml b/compiler/obc/c/c.ml index 6142d1b..a08e435 100644 --- a/compiler/obc/c/c.ml +++ b/compiler/obc/c/c.ml @@ -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 *) (** 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 diff --git a/compiler/obc/c/c.mli b/compiler/obc/c/c.mli index 58d522c..ca3d97c 100644 --- a/compiler/obc/c/c.mli +++ b/compiler/obc/c/c.mli @@ -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 *) (** 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. *) diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 523a593..78c5e75 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -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 diff --git a/compiler/obc/c/cmain.ml b/compiler/obc/c/cmain.ml index c5bf85e..ac48398 100644 --- a/compiler/obc/c/cmain.ml +++ b/compiler/obc/c/cmain.ml @@ -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. *) diff --git a/compiler/obc/c/csubst.ml b/compiler/obc/c/csubst.ml index 4ac69af..71829ab 100644 --- a/compiler/obc/c/csubst.ml +++ b/compiler/obc/c/csubst.ml @@ -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) diff --git a/compiler/obc/java/java.ml b/compiler/obc/java/java.ml index 4a415b8..cf954a2 100644 --- a/compiler/obc/java/java.ml +++ b/compiler/obc/java/java.ml @@ -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) diff --git a/compiler/obc/java/java_main.ml b/compiler/obc/java/java_main.ml index 776e2aa..6dc8851 100644 --- a/compiler/obc/java/java_main.ml +++ b/compiler/obc/java/java_main.ml @@ -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] ) diff --git a/compiler/obc/java/java_printer.ml b/compiler/obc/java/java_printer.ml index ca5fdb7..f3b5601 100644 --- a/compiler/obc/java/java_printer.ml +++ b/compiler/obc/java/java_printer.ml @@ -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 "@[case %a:@ %a@ break;@]" bare_constructor_name c block b in (* let switch_hack ff c_b_l = (* TODO java : better thing to do ? *) diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index 99f5361..48f8392 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -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 diff --git a/compiler/obc/java/old_java.ml b/compiler/obc/java/old_java.ml index 149ced0..d42022e 100644 --- a/compiler/obc/java/old_java.ml +++ b/compiler/obc/java/old_java.ml @@ -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 = diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index bd67ce5..78cbc36 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -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 *) diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml index 27707d9..181552e 100644 --- a/compiler/obc/obc_mapfold.ml +++ b/compiler/obc/obc_mapfold.ml @@ -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 diff --git a/compiler/obc/obc_printer.ml b/compiler/obc/obc_printer.ml index 9efc2fe..c380ff0 100644 --- a/compiler/obc/obc_printer.ml +++ b/compiler/obc/obc_printer.ml @@ -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 diff --git a/test/good/t13.ept b/test/good/t13.ept index 7b64049..375db60 100644 --- a/test/good/t13.ept +++ b/test/good/t13.ept @@ -1,7 +1,6 @@ node count(c : int; r : bool) returns (res : int) let res = c fby (if r then 0 else res + c); - res = 0; tel node fourth() returns (res : bool) From 35775c41313bd1e50d7561d6becdfd5887bf3fc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?C=C3=A9dric=20Pasteur?= Date: Tue, 8 Mar 2011 09:22:02 +0100 Subject: [PATCH 17/24] C backend ported to recent API changes in Obc --- compiler/TODO.txt | 6 +++++ compiler/global/names.ml | 1 + compiler/minils/main/mls2seq.ml | 2 +- compiler/obc/c/c.ml | 19 ++++++++-------- compiler/obc/c/cgen.ml | 24 +++++++++++--------- compiler/obc/c/cmain.ml | 25 ++++++++++----------- compiler/obc/obc_utils.ml | 10 ++++----- compiler/utilities/global/compiler_utils.ml | 3 ++- 8 files changed, 51 insertions(+), 39 deletions(-) create mode 100755 compiler/TODO.txt diff --git a/compiler/TODO.txt b/compiler/TODO.txt new file mode 100755 index 0000000..a97125e --- /dev/null +++ b/compiler/TODO.txt @@ -0,0 +1,6 @@ +- Ne plus forcer l'ordre constantes puis types puis definitions de noeud. Il +faudra mettre à jour les phases du compilateur et modifier l'ast. +- Ajouter des constantes locales + +- supprimer pinst dans minils +- heptcheck diff --git a/compiler/global/names.ml b/compiler/global/names.ml index e747922..3f64dab 100644 --- a/compiler/global/names.ml +++ b/compiler/global/names.ml @@ -43,6 +43,7 @@ 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) diff --git a/compiler/minils/main/mls2seq.ml b/compiler/minils/main/mls2seq.ml index d13103c..d707659 100644 --- a/compiler/minils/main/mls2seq.ml +++ b/compiler/minils/main/mls2seq.ml @@ -38,7 +38,7 @@ let write_obc_file p = close_out obc; comment "Generation of Obc code" -let targets = [ (*"c", Obc_no_params Cmain.program;*) +let targets = [ "c", Obc_no_params Cmain.program; "java", Obc Java_main.program; "obc", Obc write_obc_file; "obc_np", Obc_no_params write_obc_file; diff --git a/compiler/obc/c/c.ml b/compiler/obc/c/c.ml index a08e435..716bb3c 100644 --- a/compiler/obc/c/c.ml +++ b/compiler/obc/c/c.ml @@ -75,7 +75,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. *) @@ -156,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) @@ -173,7 +175,6 @@ let rec pp_cty fmt cty = match cty with | Cty_ptr cty' -> fprintf fmt "%a*" pp_cty cty' | Cty_arr (n, cty') -> fprintf fmt "%a[%d]" pp_cty cty' n | Cty_void -> fprintf fmt "void" - | Cty_future cty' -> fprintf fmt "future<%a>" pp_cty cty' (** [pp_array_decl cty] returns the base type of a (multidimensionnal) array and the string of indices. *) @@ -243,8 +244,8 @@ 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 (* TODO master : 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 diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 78c5e75..9938641 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -13,6 +13,7 @@ open Misc open Names open Idents open Obc +open Obc_utils open Types open Modules @@ -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 @@ -364,10 +365,10 @@ let step_fun_call var_env sig_info objn out args = if sig_info.node_statefull 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,9 +466,12 @@ 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)] @@ -495,10 +499,10 @@ let rec cstm_of_act var_env obj_env act = (match obj.o_size with | None -> [Csexpr (Cfun_call (classn ^ "_reset", - [Caddrof (Cfield (Cderef (Cvar "self"), local_qn on))]))] + [Caddrof (Cfield (Cderef (Cvar "self"), local_qn (name on)))]))] | Some size -> let x = gen_symbol () in - let field = Cfield (Cderef (Cvar "self"), local_qn on) 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 ))] )] @@ -595,7 +599,7 @@ let mem_decl_of_class_def cd = 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 @@ -740,8 +744,8 @@ 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 diff --git a/compiler/obc/c/cmain.ml b/compiler/obc/c/cmain.ml index ac48398..7813311 100644 --- a/compiler/obc/c/cmain.ml +++ b/compiler/obc/c/cmain.ml @@ -13,6 +13,7 @@ open Misc open Names open Idents open Obc +open Obc_utils open Types open Modules open Signature @@ -258,9 +259,8 @@ 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 with Not_found -> @@ -275,18 +275,16 @@ let mk_main name p = (var @ var_l, res :: res_l, step :: step_l) in List.fold_right add a_classes ([], [], []) in - let (_, var_l, res_l, step_l) = - (match !Compiler_options.simulation_node with - | None -> (n_names, var_l, res_l, step_l) - | Some n -> - let (nvar_l, res, nstep_l) = - main_def_of_class_def (find_class n) in - (n :: n_names, nvar_l @ var_l, - res :: res_l, nstep_l @ step_l)) in + let n = !Compiler_options.simulation_node in + let (nvar_l, res, nstep_l) = main_def_of_class_def (find_class n) in + let (var_l, res_l, step_l) = + (nvar_l @ var_l, res :: res_l, nstep_l @ step_l) in [("_main.c", Csource [main_skel var_l res_l step_l]); ("_main.h", Cheader ([name], []))]; -;; + ) else + [] + (******************************) @@ -297,7 +295,8 @@ let translate name prog = (global_file_header modname prog) @ (mk_main name prog) let program p = - let filename = filename_of_name (cname_of_name p.p_modname) in + let filename = + filename_of_name (cname_of_name (modul_to_string p.p_modname)) in let dirname = build_path (filename ^ "_c") in let dir = clean_dir dirname in let c_ast = translate filename p in diff --git a/compiler/obc/obc_utils.ml b/compiler/obc/obc_utils.ml index b9c2348..b701605 100644 --- a/compiler/obc/obc_utils.ml +++ b/compiler/obc/obc_utils.ml @@ -109,11 +109,12 @@ let remove_resets b = 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 @@ -162,7 +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 -*) \ No newline at end of file diff --git a/compiler/utilities/global/compiler_utils.ml b/compiler/utilities/global/compiler_utils.ml index c407cb0..e496733 100644 --- a/compiler/utilities/global/compiler_utils.ml +++ b/compiler/utilities/global/compiler_utils.ml @@ -58,7 +58,8 @@ 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 From b1b8e103f2fb8a1ded5116b77c5d531a8f97500c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?C=C3=A9dric=20Pasteur?= Date: Mon, 21 Mar 2011 17:22:03 +0100 Subject: [PATCH 18/24] Added partial application for iterators For instance: ... = map<> (f<>)((t1, t1'))(t2, t3) is translated to: for(int i =...) ... = f(t1, t1', t2[i], t3[i]) --- compiler/heptagon/analysis/causality.ml | 4 +- compiler/heptagon/analysis/initialization.ml | 3 +- compiler/heptagon/analysis/typing.ml | 9 +++- compiler/heptagon/hept_mapfold.ml | 5 +- compiler/heptagon/hept_printer.ml | 5 +- compiler/heptagon/heptagon.ml | 6 ++- compiler/heptagon/parsing/hept_lexer.mll | 2 + compiler/heptagon/parsing/hept_parser.mly | 20 ++++--- compiler/heptagon/parsing/hept_parsetree.ml | 6 +-- .../parsing/hept_parsetree_mapfold.ml | 5 +- compiler/heptagon/parsing/hept_scoping.ml | 5 +- compiler/heptagon/transformations/every.ml | 5 +- compiler/heptagon/transformations/reset.ml | 4 +- compiler/main/hept2mls.ml | 3 +- compiler/main/mls2obc.ml | 52 +++++++++++++------ compiler/minils/analysis/clocking.ml | 8 ++- compiler/minils/minils.ml | 2 +- compiler/minils/mls_compare.ml | 8 +-- compiler/minils/mls_mapfold.ml | 5 +- compiler/minils/mls_printer.ml | 5 +- compiler/minils/mls_utils.ml | 2 +- compiler/minils/transformations/callgraph.ml | 12 +++-- compiler/minils/transformations/introvars.ml | 6 ++- compiler/minils/transformations/itfusion.ml | 6 +-- compiler/minils/transformations/normalize.ml | 6 ++- compiler/minils/transformations/schedule.ml | 4 +- .../minils/transformations/singletonvars.ml | 2 +- compiler/minils/transformations/tomato.ml | 21 ++++++-- compiler/utilities/misc.ml | 10 ++++ compiler/utilities/misc.mli | 5 ++ 30 files changed, 159 insertions(+), 77 deletions(-) diff --git a/compiler/heptagon/analysis/causality.ml b/compiler/heptagon/analysis/causality.ml index 289b470..f4582d1 100644 --- a/compiler/heptagon/analysis/causality.ml +++ b/compiler/heptagon/analysis/causality.ml @@ -106,8 +106,8 @@ let rec typing e = | Estruct(l) -> let l = List.map (fun (_, e) -> typing e) l in candlist l - | Eiterator (_, _, _, e_list, _) -> - ctuplelist (List.map typing e_list) + | Eiterator (_, _, _, pe_list, e_list, _) -> + ctuplelist (List.map typing (pe_list@e_list)) | Ewhen (e, c, ce) -> let t = typing e in let tc = typing ce in diff --git a/compiler/heptagon/analysis/initialization.ml b/compiler/heptagon/analysis/initialization.ml index 159b2ba..9232a1f 100644 --- a/compiler/heptagon/analysis/initialization.ml +++ b/compiler/heptagon/analysis/initialization.ml @@ -246,7 +246,8 @@ let rec typing h e = List.fold_left (fun acc (_, e) -> imax acc (itype (typing h e))) izero l in skeleton i e.e_ty - | Eiterator (_, _, _, e_list, _) -> + | Eiterator (_, _, _, pe_list, e_list, _) -> + List.iter (fun e -> initialized_exp h e) pe_list; List.iter (fun e -> initialized_exp h e) e_list; skeleton izero e.e_ty | Ewhen (e, _, ce) -> diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 429660b..e59f7b2 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -519,7 +519,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 +529,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 +545,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) -> diff --git a/compiler/heptagon/hept_mapfold.ml b/compiler/heptagon/hept_mapfold.ml index 3d730ea..65bde82 100644 --- a/compiler/heptagon/hept_mapfold.ml +++ b/compiler/heptagon/hept_mapfold.ml @@ -129,12 +129,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 diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index 7085fc5..7674de6 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -105,11 +105,12 @@ and print_exp_desc ff = function print_app (app, args) print_every reset | Estruct(f_e_list) -> print_record (print_couple print_qualname print_exp """ = """) ff f_e_list - | Eiterator (it, f, param, args, reset) -> - fprintf ff "@[<2>(%s (%a)<<%a>>)@,%a@]%a" + | Eiterator (it, f, param, pargs, args, reset) -> + fprintf ff "@[<2>(%s (%a)<<%a>>)@,(%a)%a@]%a" (iterator_to_string it) print_app (f, []) print_static_exp param + print_exp_tuple pargs print_exp_tuple args print_every reset | Ewhen (e, c, ec) -> diff --git a/compiler/heptagon/heptagon.ml b/compiler/heptagon/heptagon.ml index d702cbf..f18f793 100644 --- a/compiler/heptagon/heptagon.ml +++ b/compiler/heptagon/heptagon.ml @@ -36,7 +36,8 @@ and desc = | Econst of static_exp | Evar of var_ident | Elast of var_ident - | Epre of static_exp option * exp (* the static_exp purpose is the initialization of the mem_var *) + (* the static_exp purpose is the initialization of the mem_var *) + | Epre of static_exp option * exp | Efby of exp * exp | Estruct of (field_name * exp) list | Ewhen of exp * constructor_name * exp @@ -44,7 +45,8 @@ and desc = | Emerge of exp * (constructor_name * exp) list (** merge ident (Constructor -> exp)+ *) | Eapp of app * exp list * exp option - | Eiterator of iterator_type * app * static_exp * exp list * exp option + | Eiterator of iterator_type * app * static_exp + * exp list * exp list * exp option and app = { a_op : op; diff --git a/compiler/heptagon/parsing/hept_lexer.mll b/compiler/heptagon/parsing/hept_lexer.mll index 9f035a9..3c8dd74 100644 --- a/compiler/heptagon/parsing/hept_lexer.mll +++ b/compiler/heptagon/parsing/hept_lexer.mll @@ -121,7 +121,9 @@ rule token = parse | [' ' '\t'] + { token lexbuf } | "." {DOT} | "(" {LPAREN} + | "((" {LPARENLPAREN} | ")" {RPAREN} + | "))" {RPARENRPAREN} | "*" { STAR } | "{" {LBRACE} | "}" {RBRACE} diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index caf13f6..3a783d9 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -9,7 +9,7 @@ open Hept_parsetree %} -%token DOT LPAREN RPAREN LBRACE RBRACE COLON SEMICOL +%token DOT LPAREN LPARENLPAREN RPAREN RPARENRPAREN LBRACE RBRACE COLON SEMICOL %token EQUAL EQUALEQUAL LESS_GREATER BARBAR COMMA BAR ARROW LET TEL %token Constructor %token IDENT @@ -96,6 +96,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]} @@ -503,11 +507,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)))] diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index ad2e5c1..cac2ae4 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -72,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 @@ -222,8 +222,8 @@ let mk_call ?(params=[]) op exps = let mk_op_call ?(params=[]) 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 } diff --git a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml index 912fefc..afe872f 100644 --- a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml +++ b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml @@ -146,11 +146,12 @@ and edesc funs acc ed = match ed with let app, acc = app_it funs acc app in let args, acc = mapfold (exp_it funs) acc args in Eapp (app, args), acc - | Eiterator (i, app, param, args) -> + | Eiterator (i, app, param, pargs, args) -> let app, acc = app_it funs acc app in let param, acc = exp_it funs acc param in + let pargs, acc = mapfold (exp_it funs) acc pargs in let args, acc = mapfold (exp_it funs) acc args in - Eiterator (i, app, param, args), acc + Eiterator (i, app, param, pargs, args), acc and app_it funs acc a = funs.app funs acc a diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index 9789696..3d14b38 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -249,13 +249,14 @@ and translate_desc loc env = function 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_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 diff --git a/compiler/heptagon/transformations/every.ml b/compiler/heptagon/transformations/every.ml index bcf6ae0..836f9d9 100644 --- a/compiler/heptagon/transformations/every.ml +++ b/compiler/heptagon/transformations/every.ml @@ -18,9 +18,10 @@ let edesc funs (v,acc_eq_list) ed = | Eapp (op, e_list, Some re) when not (is_var re) -> 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) -> + | 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, e_list, Some re), (vre::v, eqre::acc_eq_list) + Eiterator(it, op, n, pe_list, e_list, Some re), + (vre::v, eqre::acc_eq_list) | _ -> ed, (v, acc_eq_list) let program p = diff --git a/compiler/heptagon/transformations/reset.ml b/compiler/heptagon/transformations/reset.ml index 8720a43..d000d0c 100644 --- a/compiler/heptagon/transformations/reset.ml +++ b/compiler/heptagon/transformations/reset.ml @@ -66,8 +66,8 @@ 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) diff --git a/compiler/main/hept2mls.ml b/compiler/main/hept2mls.ml index 8b8c313..e4548f8 100644 --- a/compiler/main/hept2mls.ml +++ b/compiler/main/hept2mls.ml @@ -237,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 _ diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 33ae13b..adafc5c 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -272,12 +272,15 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } | _, _ -> 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 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 xd c_list e.Minils.e_ty 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 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 @@ -303,7 +306,8 @@ and mk_node_call map call_context app loc name_list args ty = [], [], [], [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_pattern vd.Minils.v_type (Lvar vd.Minils.v_ident)) 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 @@ -341,26 +345,33 @@ and mk_node_call map call_context app loc name_list args ty = [], si, [obj], s | _ -> assert false -and translate_iterator map call_context it name_list app loc n x xd c_list ty = +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 + | _ -> + 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 + 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_pattern_int (Lvar x))) c_list in + let array_of_input c_list = + 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 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 node_out_ty in + let v, si, j, action = mk_node_call map call_context + 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 let bi = mk_block si in - [Afor (xd, mk_static_int 0, n, bi)], j, [Afor (xd, mk_static_int 0, n, b)] + [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 @@ -370,37 +381,44 @@ and translate_iterator map call_context it name_list app loc n x xd c_list ty = 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 ]) - (c_list @ [ mk_exp acc_out.pat_ty (Epattern acc_out) ]) node_out_ty + 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 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)] + [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 acc_out.pat_ty (Epattern acc_out) ]) ty + 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 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) ] + [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_int x; mk_exp acc_out.pat_ty (Epattern acc_out) ]) ty + (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 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) ] + [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 diff --git a/compiler/minils/analysis/clocking.ml b/compiler/minils/analysis/clocking.ml index b13cc27..981cf27 100644 --- a/compiler/minils/analysis/clocking.ml +++ b/compiler/minils/analysis/clocking.ml @@ -43,11 +43,15 @@ let rec typing h e = | None -> fresh_clock () | Some(reset) -> typ_of_name h reset in typing_op op args h e ck - | Eiterator (_, _, _, args, r) -> (* Typed exactly as a fun or a node... *) + (* Typed exactly as a fun or a node... *) + | Eiterator (_, _, _, pargs, args, r) -> let ck = match r with | None -> fresh_clock() | Some(reset) -> typ_of_name h reset - in (List.iter (expect h (Ck ck)) args; skeleton ck e.e_ty) + in + List.iter (expect h (Ck ck)) pargs; + List.iter (expect h (Ck ck)) args; + skeleton ck e.e_ty | Ewhen (e, c, n) -> let ck_n = typ_of_name h n in (expect h (skeleton ck_n e.e_ty) e; skeleton (Con (ck_n, c, n)) e.e_ty) diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index 97aa073..0daa021 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -58,7 +58,7 @@ and edesc = (** merge ident (Constructor -> exp)+ *) | Estruct of (field_name * exp) list (** { field=exp; ... } *) - | Eiterator of iterator_type * app * static_exp * exp list * var_ident option + | Eiterator of iterator_type * app * static_exp * exp list * exp list * var_ident option (** map f <> (exp, exp...) reset ident *) and app = { a_op: op; a_params: static_exp list; a_unsafe: bool } diff --git a/compiler/minils/mls_compare.ml b/compiler/minils/mls_compare.ml index 3425abb..b9b9a77 100644 --- a/compiler/minils/mls_compare.ml +++ b/compiler/minils/mls_compare.ml @@ -48,8 +48,8 @@ let rec exp_compare e1 e2 = let cr = compare fn1 fn2 in if cr <> 0 then cr else exp_compare e1 e2 in list_compare compare_fne fnel1 fnel2 - | Eiterator (it1, app1, se1, el1, vio1), - Eiterator (it2, app2, se2, el2, vio2) -> + | Eiterator (it1, app1, se1, pel1, el1, vio1), + Eiterator (it2, app2, se2, pel2, el2, vio2) -> let cr = compare it1 it2 in if cr <> 0 then cr else let cr = static_exp_compare se1 se2 in @@ -57,7 +57,9 @@ let rec exp_compare e1 e2 = let cr = app_compare app1 app2 in if cr <> 0 then cr else let cr = option_compare ident_compare vio1 vio2 in - if cr <> 0 then cr else list_compare exp_compare el1 el2 + if cr <> 0 then cr else + let cr = list_compare exp_compare pel1 pel2 in + if cr <> 0 then cr else list_compare exp_compare el1 el2 | Econst _, _ -> 1 diff --git a/compiler/minils/mls_mapfold.ml b/compiler/minils/mls_mapfold.ml index 314ff4b..d5e7aa2 100644 --- a/compiler/minils/mls_mapfold.ml +++ b/compiler/minils/mls_mapfold.ml @@ -73,11 +73,12 @@ and edesc funs acc ed = match ed with (n,e), acc in let n_e_list, acc = mapfold aux acc n_e_list in Estruct n_e_list, acc - | Eiterator (i, app, param, args, reset) -> + | Eiterator (i, app, param, pargs, args, reset) -> let app, acc = app_it funs acc app in let param, acc = static_exp_it funs.global_funs acc param in + let pargs, acc = mapfold (exp_it funs) acc pargs in let args, acc = mapfold (exp_it funs) acc args in - Eiterator (i, app, param, args, reset), acc + Eiterator (i, app, param, pargs, args, reset), acc and app_it funs acc a = funs.app funs acc a diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index 2ac3761..76bbe40 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -102,11 +102,12 @@ 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 diff --git a/compiler/minils/mls_utils.ml b/compiler/minils/mls_utils.ml index 5fbd79a..c58a57b 100644 --- a/compiler/minils/mls_utils.ml +++ b/compiler/minils/mls_utils.ml @@ -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 diff --git a/compiler/minils/transformations/callgraph.ml b/compiler/minils/transformations/callgraph.ml index 5139331..1563ade 100644 --- a/compiler/minils/transformations/callgraph.ml +++ b/compiler/minils/transformations/callgraph.ml @@ -156,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 @@ -269,7 +271,7 @@ let collect_node_calls ln = | 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 diff --git a/compiler/minils/transformations/introvars.ml b/compiler/minils/transformations/introvars.ml index f0c910b..e06f815 100644 --- a/compiler/minils/transformations/introvars.ml +++ b/compiler/minils/transformations/introvars.ml @@ -76,10 +76,12 @@ let rec exp e (eq_list, var_list) = match e.e_desc with intro_vars e_list (eq_list, var_list) in let fnel = List.combine (List.map fst fnel) e_list in Estruct fnel, eq_list, var_list - | Eiterator (it, app, se, e_list, vio) -> + | Eiterator (it, app, se, pe_list, e_list, vio) -> let (e_list, eq_list, var_list) = intro_vars e_list (eq_list, var_list) in - Eiterator (it, app, se, e_list, vio), eq_list, var_list in + let (pe_list, eq_list, var_list) = + intro_vars pe_list (eq_list, var_list) in + Eiterator (it, app, se, pe_list, e_list, vio), eq_list, var_list in ({ e with e_desc = e_desc; }, eq_list, var_list) and intro_vars e_list (eq_list, var_list) = diff --git a/compiler/minils/transformations/itfusion.ml b/compiler/minils/transformations/itfusion.ml index d36c3d6..4e4bcc7 100644 --- a/compiler/minils/transformations/itfusion.ml +++ b/compiler/minils/transformations/itfusion.ml @@ -89,7 +89,7 @@ let mk_call app acc_eq_list = let edesc funs acc ed = let ed, acc = Mls_mapfold.edesc funs acc ed in match ed with - | Eiterator(Imap, f, n, e_list, r) -> + | Eiterator(Imap, f, n, [], e_list, r) -> (** @return the list of inputs of the anonymous function, a list of created equations (the body of the function), the args for the call of f in the lambda, @@ -102,7 +102,7 @@ let edesc funs acc ed = o1, o2 = f (_v1, _v2, z') *) let mk_arg e (inp, acc_eq_list, largs, args, b) = match e.e_desc with - | Eiterator(Imap, g, m, local_args, _) when are_equal n m -> + | Eiterator(Imap, g, m, [], local_args, _) when are_equal n m -> let new_inp, e, acc_eq_list = mk_call g acc_eq_list in new_inp @ inp, acc_eq_list, e::largs, local_args @ args, true | _ -> @@ -122,7 +122,7 @@ let edesc funs acc ed = let eq = mk_equation (pat_of_vd_list outp) call in (* create the lambda *) let anon = mk_app (Enode (add_anon_node inp outp [] (eq::acc_eq_list))) in - Eiterator(Imap, anon, n, args, r), acc) + Eiterator(Imap, anon, n, [], args, r), acc) else ed, acc diff --git a/compiler/minils/transformations/normalize.ml b/compiler/minils/transformations/normalize.ml index 31aa9c6..e07cf94 100644 --- a/compiler/minils/transformations/normalize.ml +++ b/compiler/minils/transformations/normalize.ml @@ -199,7 +199,7 @@ let rec translate kind context e = | Eapp(app, e_list, r) -> let context, e_list = translate_app kind context app.a_op e_list in context, { e with e_desc = Eapp(app, e_list, r) } - | Eiterator (it, app, n, e_list, reset) -> + | Eiterator (it, app, n, pe_list, e_list, reset) -> (* normalize anonymous nodes *) (match app.a_op with | Enode f when Itfusion.is_anon_node f -> @@ -218,9 +218,11 @@ let rec translate kind context e = translate kind context e in Misc.mapfold_right add e_list context in + let context, pe_list = + translate_list function_args_kind context pe_list in let context, e_list = translate_iterator_arg_list context e_list in - context, { e with e_desc = Eiterator(it, app, n, + context, { e with e_desc = Eiterator(it, app, n, flatten_e_list pe_list, flatten_e_list e_list, reset) } in add context kind e diff --git a/compiler/minils/transformations/schedule.ml b/compiler/minils/transformations/schedule.ml index 10a4c94..6ccfc27 100644 --- a/compiler/minils/transformations/schedule.ml +++ b/compiler/minils/transformations/schedule.ml @@ -79,11 +79,11 @@ let eqs funs () eq_list = let edesc _ () = function | Eiterator(it, ({ a_op = Enode f } as app), - n, e_list, r) when Itfusion.is_anon_node f -> + n, [], e_list, r) when Itfusion.is_anon_node f -> let nd = Itfusion.find_anon_node f in let nd = { nd with n_equs = schedule nd.n_equs } in Itfusion.replace_anon_node f nd; - Eiterator(it, app, n, e_list, r), () + Eiterator(it, app, n, [], e_list, r), () | _ -> raise Errors.Fallback let program p = diff --git a/compiler/minils/transformations/singletonvars.ml b/compiler/minils/transformations/singletonvars.ml index 9e86558..0759da7 100644 --- a/compiler/minils/transformations/singletonvars.ml +++ b/compiler/minils/transformations/singletonvars.ml @@ -52,7 +52,7 @@ struct | Evar vi -> add_var_use vi use_counts | Emerge (vi, _) -> add_clock_use vi use_counts | Ewhen (_, _, vi) -> add_clock_use vi use_counts - | Eapp (_, _, Some vi) | Eiterator (_, _, _, _, Some vi) -> + | Eapp (_, _, Some vi) | Eiterator (_, _, _, _, _, Some vi) -> add_reset_use vi use_counts | _ -> use_counts in (edesc, use_counts) diff --git a/compiler/minils/transformations/tomato.ml b/compiler/minils/transformations/tomato.ml index 809d824..2873792 100644 --- a/compiler/minils/transformations/tomato.ml +++ b/compiler/minils/transformations/tomato.ml @@ -206,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 = @@ -425,11 +428,19 @@ let rec reconstruct input_type (env : PatEnv.t) = List.combine (List.map fst cnel) (List.tl e_list)) | Estruct fnel, e_list -> Estruct (List.combine (List.map fst fnel) e_list) - | Eiterator (it, app, se, [], rst), e_list -> + | Eiterator (it, app, se, [], [], rst), e_list -> + (* the first element is the number of partial arguments *) + let count, e_list = assert_1min e_list in + let c = (match count.e_desc with + | Econst { se_desc = Sint c } -> c + | _ -> assert false) + in + let pe_list, e_list = Misc.split_at c e_list in let rst, e_list = rst_of_e_list rst e_list in - Eiterator (it, app, se, e_list, rst) + Eiterator (it, app, se, pe_list, e_list, rst) - | (Eiterator (_, _, _, _ :: _, _) | Ewhen _ | Efby _ | Evar _ | Econst _) + | (Eiterator (_, _, _, _, _, _) | Ewhen _ + | Efby _ | Evar _ | Econst _) , _ -> assert false (* invariant *) in (mk_equation pat { head with e_desc = e_desc; } :: eq_list, mk_var_decs pat head.e_ty var_list) in diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index 089e08b..5c2d88c 100644 --- a/compiler/utilities/misc.ml +++ b/compiler/utilities/misc.ml @@ -64,6 +64,16 @@ let rec split_last = function let l, a = split_last l in v::l, a +exception List_too_short +(** [split_at n l] splits [l] in two after the [n]th value. + Raises List_too_short exception if the list is too short. *) +let rec split_at n l = match n, l with + | 0, l -> [], l + | _, [] -> raise List_too_short + | n, x::l -> + let l1, l2 = split_at (n-1) l in + x::l1, l2 + let remove x l = List.filter (fun y -> x <> y) l diff --git a/compiler/utilities/misc.mli b/compiler/utilities/misc.mli index 6f305e9..2daf31f 100644 --- a/compiler/utilities/misc.mli +++ b/compiler/utilities/misc.mli @@ -36,6 +36,11 @@ val last_element : 'a list -> 'a and the last element of the list .*) val split_last : 'a list -> ('a list * 'a) +exception List_too_short +(** [split_at n l] splits [l] in two after the [n]th value. + Raises List_too_short exception if the list is too short. *) +val split_at : int -> 'a list -> 'a list * 'a list + (** [remove x l] removes all occurrences of x from list l.*) val remove : 'a -> 'a list -> 'a list From ecc79c3a532e47d33de4c62debef324449c1584e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Thu, 17 Mar 2011 10:01:16 +0100 Subject: [PATCH 19/24] bug fix n-dimension arrays. --- compiler/obc/java/java_printer.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/obc/java/java_printer.ml b/compiler/obc/java/java_printer.ml index f3b5601..47ce9c4 100644 --- a/compiler/obc/java/java_printer.ml +++ b/compiler/obc/java/java_printer.ml @@ -41,7 +41,7 @@ let rec _ty size ff t = match t with | 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]" ty t exp s else fprintf ff "%a[]" ty t + | Tarray (t,s) -> if size then fprintf ff "%a[%a]" full_ty t exp s else fprintf ff "%a[]" ty t | Tunit -> pp_print_string ff "void" and full_ty ff t = _ty true ff t From c96d05b1eb689cf21ed9ccbf6db2ddfc673ec983 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Thu, 17 Mar 2011 10:02:35 +0100 Subject: [PATCH 20/24] updated todo and refactoring. --- compiler/global/static.ml | 13 ++++--------- todo.txt | 2 ++ 2 files changed, 6 insertions(+), 9 deletions(-) diff --git a/compiler/global/static.ml b/compiler/global/static.ml index 23ce68c..30cacc3 100644 --- a/compiler/global/static.ml +++ b/compiler/global/static.ml @@ -92,15 +92,10 @@ let rec eval env se = (** [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) + Partial_instanciation if it cannot be computed (if a var has no value).*) +let int_of_static_exp env se = match (eval_core env se).se_desc with + | Sint i -> i + | _ -> Misc.internal_error "static int_of_static_exp" 1 (** [is_true env constr] returns whether the constraint is satisfied in the environment (or None if this can be decided) diff --git a/todo.txt b/todo.txt index fb8a486..498fbf2 100644 --- a/todo.txt +++ b/todo.txt @@ -3,6 +3,8 @@ 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. +*- Functions in Obc should not be objetcs. + *- 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" ... From 02730b8a0baa43912687d0d5910e72011773067d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Le=CC=81onard=20Ge=CC=81rard?= Date: Thu, 17 Mar 2011 17:10:36 +0100 Subject: [PATCH 21/24] refactoring static evaluation. --- compiler/global/static.ml | 112 +++++++++++++------ compiler/minils/transformations/callgraph.ml | 8 +- 2 files changed, 81 insertions(+), 39 deletions(-) diff --git a/compiler/global/static.ml b/compiler/global/static.ml index 30cacc3..7e2011c 100644 --- a/compiler/global/static.ml +++ b/compiler/global/static.ml @@ -17,14 +17,50 @@ 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 @@ -35,8 +71,8 @@ let partial_apply_op op se_list = | { qual = Pervasives; name = "*" } -> Sint (n1 * n2) | { qual = Pervasives; name = "/" } -> - let n = if n2 = 0 then raise Instanciation_failed else n1 / n2 in - Sint n + 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*) @@ -46,54 +82,60 @@ let partial_apply_op op se_list = | { 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 eval_core partial env (QualEnv.find ln env) + with Not_found -> + 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 - Partial_instanciation if it cannot be computed (if a var has no value).*) -let int_of_static_exp env se = match (eval_core env se).se_desc with + [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 diff --git a/compiler/minils/transformations/callgraph.ml b/compiler/minils/transformations/callgraph.ml index 1563ade..54f0e69 100644 --- a/compiler/minils/transformations/callgraph.ml +++ b/compiler/minils/transformations/callgraph.ml @@ -14,7 +14,7 @@ module Error = struct type error = | Enode_unbound of qualname - | Epartial_instanciation of static_exp + | Epartial_evaluation of static_exp let message loc kind = begin match kind with @@ -22,7 +22,7 @@ struct Format.eprintf "%aUnknown node '%s'@." print_location loc (fullname ln) - | Epartial_instanciation se -> + | Epartial_evaluation se -> Format.eprintf "%aUnable to fully instanciate the static exp '%a'@." print_location se.se_loc print_static_exp se @@ -79,8 +79,8 @@ struct (** 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) + with Errors.Error se -> + Error.message no_location (Error.Epartial_evaluation se) (** @return the name of the node corresponding to the instance of [ln] with the static parameters [params]. *) From c602eca062d95e1432177c8b8f9c1e7bff5d6b72 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Thu, 17 Mar 2011 17:11:00 +0100 Subject: [PATCH 22/24] cgen todo. --- compiler/obc/c/cgen.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 9938641..ccee9f4 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -255,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 From 6428ff81f09108a2b229690164d3b03b5d308c13 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Thu, 17 Mar 2011 17:12:16 +0100 Subject: [PATCH 23/24] array1 testing. --- test/good/array1.ept | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/test/good/array1.ept b/test/good/array1.ept index 143ba5d..526ec44 100644 --- a/test/good/array1.ept +++ b/test/good/array1.ept @@ -1,5 +1,5 @@ -const n:int = 42 -const m:int = 52 +const n:int = 10 +const m:int = 10 node concatenate(a:int^n; b:int^m) returns (o1, o2: int^(n+m)) let @@ -41,3 +41,13 @@ node constant(a,b:int) returns (o:int^4) let o = [a,b,a,b]; tel + + +node test1() returns (r1,r2: int^3) +var x,y : int^10; z,t : int^20; +let + x = ten(3); + y = ten(4); + (z,t) = concatenate(x,y); + (r1,r2) = slicing(x); +tel From b8b16a7355f037ad2540a7f9a6b7e3edb757a1d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 21 Mar 2011 14:30:19 +0100 Subject: [PATCH 24/24] blop --- .gitignore | 2 + compiler/global/clocks.ml | 1 + compiler/global/global_compare.ml | 2 + compiler/global/global_mapfold.ml | 27 +++--- compiler/global/global_printer.ml | 2 + compiler/global/modules.ml | 1 + compiler/global/signature.ml | 6 +- compiler/global/static.ml | 10 ++- compiler/global/types.ml | 3 +- compiler/heptagon/analysis/statefull.ml | 67 +++++++++------ compiler/heptagon/analysis/typing.ml | 5 +- compiler/heptagon/hept_mapfold.ml | 63 +++++--------- compiler/heptagon/heptagon.ml | 26 +++--- compiler/heptagon/parsing/hept_parser.mly | 11 +-- compiler/heptagon/parsing/hept_parsetree.ml | 4 +- compiler/heptagon/parsing/hept_scoping.ml | 12 +-- compiler/heptagon/transformations/inline.ml | 4 +- compiler/heptagon/transformations/present.ml | 6 +- compiler/heptagon/transformations/reset.ml | 6 +- compiler/heptagon/transformations/switch.ml | 6 +- compiler/main/hept2mls.ml | 5 +- compiler/main/mls2obc.ml | 82 +++++++++--------- compiler/minils/main/mls2seq.ml | 7 +- compiler/minils/minils.ml | 11 +-- compiler/minils/transformations/callgraph.ml | 18 ++-- compiler/minils/transformations/checkpass.ml | 2 +- compiler/minils/transformations/tomato.ml | 2 +- compiler/obc/c/cgen.ml | 33 +++++--- compiler/obc/c/cmain.ml | 6 +- compiler/obc/java/java.ml | 5 +- compiler/obc/java/java_printer.ml | 2 + compiler/obc/java/obc2java.ml | 63 ++++++++++---- compiler/obc/obc.ml | 5 +- compiler/obc/obc_mapfold.ml | 8 +- compiler/obc/obc_printer.ml | 5 +- compiler/obc/transformations/scalarize.ml | 61 ++++++++++++++ heptc | 14 ++- lib/java/jeptagon/Pervasives.java | 89 +++++++++----------- test/async/pipline.ept | 2 +- test/async/scalarize.ept | 7 ++ test/good/array_fill.ept | 5 +- todo.txt | 2 +- tools/debugger_script | 46 +++++----- 43 files changed, 443 insertions(+), 301 deletions(-) create mode 100644 compiler/obc/transformations/scalarize.ml create mode 100644 test/async/scalarize.ept diff --git a/.gitignore b/.gitignore index d78b817..5a76d18 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,5 @@ _build *.dot test/*.ml test/_check_builds +lib/java/.classpath +test/async/build/* diff --git a/compiler/global/clocks.ml b/compiler/global/clocks.ml index db7e3e1..5028474 100644 --- a/compiler/global/clocks.ml +++ b/compiler/global/clocks.ml @@ -95,6 +95,7 @@ let rec skeleton ck = function assert false; | _ -> Cprod (List.map (skeleton ck) ty_list)) | 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 diff --git a/compiler/global/global_compare.ml b/compiler/global/global_compare.ml index 141621c..02cb472 100644 --- a/compiler/global/global_compare.ml +++ b/compiler/global/global_compare.ml @@ -107,4 +107,6 @@ and type_compare ty1 ty2 = match ty1, ty2 with | Tid _, _ -> 1 | Tarray _, (Tprod _ | Tid _) -> -1 | Tarray _, _ -> 1 + | Tmutable _, (Tprod _ | Tid _ | Tarray _) -> -1 + | Tmutable _, _ -> 1 | Tunit, _ -> -1 diff --git a/compiler/global/global_mapfold.ml b/compiler/global/global_mapfold.ml index 1af3f94..facb84a 100644 --- a/compiler/global/global_mapfold.ml +++ b/compiler/global/global_mapfold.ml @@ -5,19 +5,17 @@ open Types open Signature type 'a global_it_funs = { - static_exp : - 'a global_it_funs -> 'a -> static_exp -> static_exp * 'a; - static_exp_desc : - 'a global_it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a; - ty : 'a global_it_funs -> 'a -> ty -> ty * 'a; -(* ct : 'a global_it_funs -> 'a -> ct -> ct * 'a; - ck : 'a global_it_funs -> 'a -> ck -> ck * 'a; - link : 'a global_it_funs -> 'a -> link -> link * 'a; *) - param: 'a global_it_funs -> 'a -> param -> param * 'a; - arg: 'a global_it_funs -> 'a -> arg -> arg * 'a; - node : 'a global_it_funs -> 'a -> node -> node * 'a; - structure: 'a global_it_funs -> 'a -> structure -> structure * 'a; - field: 'a global_it_funs -> 'a -> field -> field * 'a; } + static_exp : 'a global_it_funs -> 'a -> static_exp -> static_exp * 'a; + static_exp_desc : 'a global_it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a; + ty : 'a global_it_funs -> 'a -> ty -> ty * 'a; +(* ct : 'a global_it_funs -> 'a -> ct -> ct * 'a; + ck : 'a global_it_funs -> 'a -> ck -> ck * 'a; + link : 'a global_it_funs -> 'a -> link -> link * 'a; *) + param : 'a global_it_funs -> 'a -> param -> param * 'a; + arg : 'a global_it_funs -> 'a -> arg -> arg * 'a; + node : 'a global_it_funs -> 'a -> node -> node * 'a; + structure : 'a global_it_funs -> 'a -> structure -> structure * 'a; + field : 'a global_it_funs -> 'a -> field -> field * 'a; } let rec static_exp_it funs acc se = funs.static_exp funs acc se and static_exp funs acc se = @@ -59,6 +57,9 @@ and ty funs acc t = match t with let t, acc = ty_it funs acc t in let se, acc = static_exp_it funs acc se in Tarray (t, se), acc + | Tmutable t -> + let t, acc = ty_it funs acc t in + Tmutable t, acc | Tunit -> t, acc (* and ct_it funs acc c = try funs.ct funs acc c with Fallback -> ct funs acc t diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index 1d3bebe..9306ae4 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -70,6 +70,8 @@ and print_type ff = function | Tid id -> print_qualname ff id | Tarray (ty, n) -> fprintf ff "@[%a^%a@]" print_type ty print_static_exp n + | Tmutable ty -> + fprintf ff "@[mutable %a@]" print_type ty | Tunit -> fprintf ff "unit" let print_field ff field = diff --git a/compiler/global/modules.ml b/compiler/global/modules.ml index 60fe474..6273f84 100644 --- a/compiler/global/modules.ml +++ b/compiler/global/modules.ml @@ -291,6 +291,7 @@ let rec unalias_type t = match t with with Not_found -> raise (Undefined_type ty_name)) | Tarray (ty, n) -> Tarray(unalias_type ty, n) | Tprod ty_list -> Tprod (List.map unalias_type ty_list) + | Tmutable t -> Tmutable (unalias_type t) | Tunit -> Tunit diff --git a/compiler/global/signature.ml b/compiler/global/signature.ml index 7adedc9..f3a6e41 100644 --- a/compiler/global/signature.ml +++ b/compiler/global/signature.ml @@ -30,7 +30,7 @@ type size_constraint = type node = { node_inputs : arg list; node_outputs : arg list; - node_statefull : bool; + node_stateful : bool; node_params : param list; node_params_constraints : size_constraint list } @@ -58,10 +58,10 @@ let mk_field n ty = { f_name = n; f_type = ty } let mk_const_def ty value = { c_type = ty; c_value = value } -let mk_node ?(constraints = []) ins outs statefull params = +let mk_node ?(constraints = []) ins outs stateful params = { node_inputs = ins; node_outputs = outs; - node_statefull = statefull; + node_stateful = stateful; node_params = params; node_params_constraints = constraints } diff --git a/compiler/global/static.ml b/compiler/global/static.ml index 7e2011c..b099779 100644 --- a/compiler/global/static.ml +++ b/compiler/global/static.ml @@ -96,8 +96,14 @@ let rec eval_core partial env se = match se.se_desc with let cd = find_const ln in eval_core partial env cd.c_value with Not_found -> (* then try to find in local env *) - (try eval_core partial env (QualEnv.find ln env) - with Not_found -> + (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)) ) diff --git a/compiler/global/types.ml b/compiler/global/types.ml index 7ddbc79..a5a4545 100644 --- a/compiler/global/types.ml +++ b/compiler/global/types.ml @@ -30,7 +30,8 @@ and static_exp_desc = 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] *) + | 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 [] (** Invalid type given to untyped expression etc. *) diff --git a/compiler/heptagon/analysis/statefull.ml b/compiler/heptagon/analysis/statefull.ml index a862492..6080539 100644 --- a/compiler/heptagon/analysis/statefull.ml +++ b/compiler/heptagon/analysis/statefull.ml @@ -6,7 +6,7 @@ (* Organization : Demons, LRI, University of Paris-Sud, Orsay *) (* *) (**************************************************************************) -(* Checks that a node declared stateless is stateless *) +(* Checks that a node declared stateless is stateless, and set possible nodes as stateless. *) open Names open Location open Signature @@ -21,7 +21,7 @@ type error = let message loc kind = begin match kind with | Eshould_be_a_node -> - Format.eprintf "%aThis node is statefull \ + Format.eprintf "%aThis node is stateful \ but was declared stateless.@." print_location loc | Eexp_should_be_stateless -> @@ -30,54 +30,73 @@ let message loc kind = end; raise Errors.Error -(** @returns whether the exp is statefull. Replaces node calls with +let last _ stateful l = match l with + | Var -> l, stateful + | Last _ -> l, true + +(** @returns whether the exp is stateful. Replaces node calls with the correct Efun or Enode depending on the node signature. *) -let edesc funs statefull ed = - (* do the recursion on function args *) - let ed, statefull = Hept_mapfold.edesc funs statefull ed in +let edesc funs stateful ed = + let ed, stateful = Hept_mapfold.edesc funs stateful ed in match ed with | Efby _ | Epre _ -> ed, true | Eapp({ a_op = Earrow }, _, _) -> ed, true | Eapp({ a_op = (Enode f | Efun f) } as app, e_list, r) -> let ty_desc = find_value f in - let op = if ty_desc.node_statefull then Enode f else Efun f in - Eapp({ app with a_op = op }, e_list, r), - ty_desc.node_statefull or statefull - | _ -> ed, statefull + let op = if ty_desc.node_stateful then Enode f else Efun f in + Eapp({ app with a_op = op }, e_list, r), ty_desc.node_stateful or stateful + | _ -> ed, stateful + +let eqdesc funs acc eqd = + let eqd, _ = Hept_mapfold.eqdesc funs acc eqd in + match eqd with + | Eautomaton st_h_l -> + let st_h_l, _ = Misc.mapfold (state_handler_it funs) acc st_h_l in + Eautomaton st_h_l, true + | _ -> raise Errors.Fallback let eq funs acc eq = - let eq, statefull = Hept_mapfold.eq funs acc eq in - { eq with eq_statefull = statefull }, statefull + let eq, stateful = Hept_mapfold.eq funs acc eq in + { eq with eq_stateful = stateful }, stateful let block funs acc b = - let b, statefull = Hept_mapfold.block funs false b in - { b with b_statefull = statefull }, acc or statefull + let b, stateful = Hept_mapfold.block funs false b in + { b with b_stateful = stateful }, acc or stateful +(** Strong preemption should be decided with stateless expressions *) let escape_unless funs acc esc = - let esc, statefull = Hept_mapfold.escape funs false esc in - if statefull then + let esc, stateful = Hept_mapfold.escape funs false esc in + if stateful then message esc.e_cond.e_loc Eexp_should_be_stateless; - esc, acc or statefull + esc, acc or stateful +(** Present conditions should be stateless *) let present_handler funs acc ph = - let p_cond, statefull = Hept_mapfold.exp_it funs false ph.p_cond in - if statefull then + let p_cond, stateful = Hept_mapfold.exp_it funs false ph.p_cond in + if stateful then message ph.p_cond.e_loc Eexp_should_be_stateless; let p_block, acc = Hept_mapfold.block_it funs acc ph.p_block in { ph with p_cond = p_cond; p_block = p_block }, acc + +(** Funs with states are rejected, nodes without state are set as funs *) let node_dec funs _ n = Idents.enter_node n.n_name; - let n, statefull = Hept_mapfold.node_dec funs false n in - if statefull & not (n.n_statefull) then - message n.n_loc Eshould_be_a_node; - n, false + let n, stateful = Hept_mapfold.node_dec funs false n in + if stateful & (not n.n_stateful) then message n.n_loc Eshould_be_a_node; + if not stateful & n.n_stateful (* update the global env if stateful is not necessary *) + then Modules.replace_value n.n_name { (Modules.find_value n.n_name) with Signature.node_stateful = false }; + { n with n_stateful = stateful }, false (* set stateful only if needed *) + let program p = let funs = - { Hept_mapfold.defaults with edesc = edesc; + { Hept_mapfold.defaults with + edesc = edesc; escape_unless = escape_unless; present_handler = present_handler; + eqdesc = eqdesc; + last = last; eq = eq; block = block; node_dec = node_dec } in let p, _ = Hept_mapfold.program_it funs false p in p diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index e59f7b2..d7d0d04 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -223,7 +223,7 @@ let unify t1 t2 = let kind f ty_desc = let ty_of_arg v = v.a_type in - let op = if ty_desc.node_statefull then Enode f else Efun f in + let op = if ty_desc.node_stateful then Enode f else Efun f in op, List.map ty_of_arg ty_desc.node_inputs, List.map ty_of_arg ty_desc.node_outputs @@ -250,6 +250,7 @@ let build_subst names values = let rec subst_type_vars m = function | Tarray(ty, e) -> Tarray(subst_type_vars m ty, simplify m e) | Tprod l -> Tprod (List.map (subst_type_vars m) l) + | Tmutable t -> Tmutable (subst_type_vars m t) | t -> t let add_distinct_env id ty env = @@ -384,6 +385,8 @@ let rec check_type const_env = function | Tid ty_name -> Tid ty_name (* TODO bug ? should check that ty_name exists ? *) | Tprod l -> Tprod (List.map (check_type const_env) l) + | Tmutable t -> + Tmutable (check_type const_env t) | Tunit -> Tunit and typing_static_exp const_env se = diff --git a/compiler/heptagon/hept_mapfold.ml b/compiler/heptagon/hept_mapfold.ml index 65bde82..be29712 100644 --- a/compiler/heptagon/hept_mapfold.ml +++ b/compiler/heptagon/hept_mapfold.ml @@ -54,46 +54,25 @@ open Global_mapfold open Heptagon type 'a hept_it_funs = { - app: - 'a hept_it_funs -> 'a -> Heptagon.app -> Heptagon.app * 'a; - block: - 'a hept_it_funs -> 'a -> Heptagon.block -> Heptagon.block * 'a; - edesc: - 'a hept_it_funs -> 'a -> Heptagon.desc -> Heptagon.desc * 'a; - eq: - 'a hept_it_funs -> 'a -> Heptagon.eq -> Heptagon.eq * 'a; - eqdesc: - 'a hept_it_funs -> 'a -> Heptagon.eqdesc -> Heptagon.eqdesc * 'a; - escape_unless : - 'a hept_it_funs -> 'a -> Heptagon.escape -> Heptagon.escape * 'a; - escape_until: - 'a hept_it_funs -> 'a -> Heptagon.escape -> Heptagon.escape * 'a; - exp: - 'a hept_it_funs -> 'a -> Heptagon.exp -> Heptagon.exp * 'a; - pat: - 'a hept_it_funs -> 'a -> pat -> Heptagon.pat * 'a; - present_handler: - 'a hept_it_funs -> 'a -> Heptagon.present_handler - -> Heptagon.present_handler * 'a; - state_handler: - 'a hept_it_funs -> 'a -> Heptagon.state_handler - -> Heptagon.state_handler * 'a; - switch_handler: - 'a hept_it_funs -> 'a -> Heptagon.switch_handler - -> Heptagon.switch_handler * 'a; - var_dec: - 'a hept_it_funs -> 'a -> Heptagon.var_dec -> Heptagon.var_dec * 'a; - last: - 'a hept_it_funs -> 'a -> Heptagon.last -> Heptagon.last * 'a; - contract: - 'a hept_it_funs -> 'a -> Heptagon.contract -> Heptagon.contract * 'a; - node_dec: - 'a hept_it_funs -> 'a -> Heptagon.node_dec -> Heptagon.node_dec * 'a; - const_dec: - 'a hept_it_funs -> 'a -> Heptagon.const_dec -> Heptagon.const_dec * 'a; - program: - 'a hept_it_funs -> 'a -> Heptagon.program -> Heptagon.program * 'a; - global_funs: 'a Global_mapfold.global_it_funs } + app : 'a hept_it_funs -> 'a -> app -> app * 'a; + block : 'a hept_it_funs -> 'a -> block -> block * 'a; + edesc : 'a hept_it_funs -> 'a -> desc -> desc * 'a; + eq : 'a hept_it_funs -> 'a -> eq -> eq * 'a; + eqdesc : 'a hept_it_funs -> 'a -> eqdesc -> eqdesc * 'a; + escape_unless : 'a hept_it_funs -> 'a -> escape -> escape * 'a; + escape_until : 'a hept_it_funs -> 'a -> escape -> escape * 'a; + exp : 'a hept_it_funs -> 'a -> exp -> exp * 'a; + pat : 'a hept_it_funs -> 'a -> pat -> pat * 'a; + present_handler: 'a hept_it_funs -> 'a -> present_handler -> present_handler * 'a; + state_handler : 'a hept_it_funs -> 'a -> state_handler -> state_handler * 'a; + switch_handler : 'a hept_it_funs -> 'a -> switch_handler -> switch_handler * 'a; + var_dec : 'a hept_it_funs -> 'a -> var_dec -> var_dec * 'a; + last : 'a hept_it_funs -> 'a -> last -> last * 'a; + contract : 'a hept_it_funs -> 'a -> contract -> contract * 'a; + node_dec : 'a hept_it_funs -> 'a -> node_dec -> node_dec * 'a; + const_dec : 'a hept_it_funs -> 'a -> const_dec -> const_dec * 'a; + program : 'a hept_it_funs -> 'a -> program -> program * 'a; + global_funs : 'a Global_mapfold.global_it_funs } let rec exp_it funs acc e = funs.exp funs acc e @@ -200,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 @@ -238,7 +217,7 @@ and present_handler funs acc ph = and var_dec_it funs acc vd = funs.var_dec funs acc vd and var_dec funs acc vd = - (* v_type ??? *) + (* TODO v_type ??? *) let v_last, acc = last_it funs acc vd.v_last in { vd with v_last = v_last }, acc diff --git a/compiler/heptagon/heptagon.ml b/compiler/heptagon/heptagon.ml index f18f793..87a5889 100644 --- a/compiler/heptagon/heptagon.ml +++ b/compiler/heptagon/heptagon.ml @@ -76,7 +76,7 @@ and pat = type eq = { eq_desc : eqdesc; - eq_statefull : bool; + eq_stateful : bool; eq_loc : location; } and eqdesc = @@ -91,7 +91,7 @@ and block = { b_local : var_dec list; b_equs : eq list; b_defnames : ty Env.t; - b_statefull : bool; + b_stateful : bool; b_loc : location; } and state_handler = { @@ -141,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; @@ -166,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 } @@ -197,16 +197,16 @@ let mk_op_app ?(params=[]) ?(unsafe=false) ?(reset=None) op args = 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) @@ -217,15 +217,15 @@ let mk_ifthenelse e1 e2 e3 = { e3 with e_desc = mk_op_app Eifthenelse [e1; e2; e3] } let mk_simple_equation pat e = - mk_equation ~statefull:false (Eeq(pat, e)) + mk_equation ~stateful:false (Eeq(pat, e)) -let mk_switch_equation ?(statefull = true) e l = - mk_equation ~statefull:statefull (Eswitch (e, l)) +let mk_switch_equation ?(stateful = true) e l = + mk_equation ~stateful:stateful (Eswitch (e, l)) -let mk_signature name ins outs statefull params loc = +let mk_signature name ins outs stateful params loc = { sig_name = name; sig_inputs = ins; - sig_statefull = statefull; + sig_stateful = stateful; sig_outputs = outs; sig_params = params; sig_loc = loc } diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index 3a783d9..8ccf3ff 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -47,7 +47,6 @@ open Hept_parsetree %token AROBASE %token DOUBLE_LESS DOUBLE_GREATER %token MAP FOLD FOLDI MAPFOLD -%token ASYNC BANG %token PREFIX %token INFIX0 %token INFIX1 @@ -59,7 +58,6 @@ open Hept_parsetree %right AROBASE -%nonassoc prec_ident %nonassoc DEFAULT %left ELSE %right ARROW @@ -77,8 +75,7 @@ open Hept_parsetree %right PRE %left POWER %right PREFIX -%left DOT -%left BANG + %start program @@ -190,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; @@ -547,7 +544,7 @@ modul: | m=modul DOT c=Constructor { Names.QualModule { Names.qual = m; Names.name = c} } constructor: - | Constructor { ToQ $1 } %prec prec_ident + | Constructor { ToQ $1 } | q=qualified(Constructor) { q } ; @@ -626,7 +623,7 @@ _interface_decl: RETURNS LPAREN params_signature RPAREN { Isignature({ sig_name = $3; sig_inputs = $6; - sig_statefull = $2; + sig_stateful = $2; sig_outputs = $10; sig_params = $4; sig_loc = (Loc($startpos,$endpos)) }) } diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index cac2ae4..99b6839 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -162,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; @@ -191,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 } diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index 3d14b38..ca4ccdf 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -296,7 +296,7 @@ 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_stateful = false; Heptagon.eq_loc = eq.eq_loc; } and translate_eq_desc loc env = function @@ -326,7 +326,7 @@ 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_stateful = false; Heptagon.b_loc = b.b_loc; }, env and translate_state_handler env sh = @@ -402,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; @@ -469,8 +469,8 @@ let translate_signature s = let i = List.map translate_arg s.sig_inputs in let o = List.map translate_arg s.sig_outputs in let p = params_of_var_decs s.sig_params in - add_value n (Signature.mk_node i o s.sig_statefull p); - Heptagon.mk_signature n i o s.sig_statefull p s.sig_loc + add_value n (Signature.mk_node i o s.sig_stateful p); + Heptagon.mk_signature n i o s.sig_stateful p s.sig_loc let translate_interface_desc = function diff --git a/compiler/heptagon/transformations/inline.ml b/compiler/heptagon/transformations/inline.ml index 972e9e5..e6933ce 100644 --- a/compiler/heptagon/transformations/inline.ml +++ b/compiler/heptagon/transformations/inline.ml @@ -56,7 +56,7 @@ let exp funs (env, newvars, newequs) exp = match exp.e_desc with | Eapp ({ a_op = Enode nn; } as op, argl, rso) when to_be_inlined nn -> let add_reset eq = match rso with | None -> eq - | Some x -> mk_equation ~statefull:false + | Some x -> mk_equation ~stateful:false (Ereset (mk_block [eq], x)) in let ni = mk_unique_node (env nn) in @@ -80,7 +80,7 @@ let exp funs (env, newvars, newequs) exp = match exp.e_desc with fst (Hept_mapfold.node_dec funs () ni) in let mk_input_equ vd e = - mk_equation ~statefull:false (Eeq (Evarpat vd.v_ident, e)) in + mk_equation ~stateful:false (Eeq (Evarpat vd.v_ident, e)) in let mk_output_exp vd = mk_exp (Evar vd.v_ident) vd.v_type in let newvars = ni.n_input @ ni.n_block.b_local @ ni.n_output @ newvars diff --git a/compiler/heptagon/transformations/present.ml b/compiler/heptagon/transformations/present.ml index 0d811d5..34e4ba2 100644 --- a/compiler/heptagon/transformations/present.ml +++ b/compiler/heptagon/transformations/present.ml @@ -13,10 +13,10 @@ open Hept_mapfold let translate_present_handlers handlers cont = let translate_present_handler { p_cond = e; p_block = b } cont = - let statefull = b.b_statefull or cont.b_statefull in - mk_block ~statefull:statefull ~defnames:b.b_defnames + let stateful = b.b_stateful or cont.b_stateful in + mk_block ~stateful:stateful ~defnames:b.b_defnames [mk_switch_equation - ~statefull:statefull e + ~stateful:stateful e [{ w_name = Initial.ptrue; w_block = b }; { w_name = Initial.pfalse; w_block = cont }]] in let b = List.fold_right translate_present_handler handlers cont in diff --git a/compiler/heptagon/transformations/reset.ml b/compiler/heptagon/transformations/reset.ml index d000d0c..ec04168 100644 --- a/compiler/heptagon/transformations/reset.ml +++ b/compiler/heptagon/transformations/reset.ml @@ -8,7 +8,7 @@ (**************************************************************************) (* removing reset statements *) -(* REQUIRES automaton switch statefull present *) +(* REQUIRES automaton switch stateful present *) open Misc open Idents @@ -74,7 +74,7 @@ let edesc funs (res,s) ed = -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 @@ -85,7 +85,7 @@ let eqdesc funs (res,stateful) = function let e, vd, eq = bool_var_from_exp e in let r = merge_resets res (Some e) in let b, _ = Hept_mapfold.block_it funs (r,true) b in - let b = { b with b_equs = eq::b.b_equs; b_local = vd::b.b_local; b_statefull = true } in + let b = { b with b_equs = eq::b.b_equs; b_local = vd::b.b_local; b_stateful = true } in Eblock(b), (res,true)) else ( let b, _ = Hept_mapfold.block_it funs (res,false) b in diff --git a/compiler/heptagon/transformations/switch.ml b/compiler/heptagon/transformations/switch.ml index 2523432..a2ae409 100644 --- a/compiler/heptagon/transformations/switch.ml +++ b/compiler/heptagon/transformations/switch.ml @@ -155,11 +155,11 @@ let exp funs (env,h) e = | Evar _ -> Env.sample_var e env, (env,h) | _ -> Hept_mapfold.exp funs (env,h) e -(* update statefull and loc *) +(* update stateful and loc *) let eq funs (env,h) eq = let eqd = match eq.eq_desc with - | Eblock b -> (* probably created by eqdesc, so update statefull and loc *) - Eblock { b with b_statefull = eq.eq_statefull; b_loc = eq.eq_loc } + | Eblock b -> (* probably created by eqdesc, so update stateful and loc *) + Eblock { b with b_stateful = eq.eq_stateful; b_loc = eq.eq_loc } | _ -> eq.eq_desc in Hept_mapfold.eq funs (env,h) {eq with eq_desc = eqd} diff --git a/compiler/main/hept2mls.ml b/compiler/main/hept2mls.ml index e4548f8..2e08119 100644 --- a/compiler/main/hept2mls.ml +++ b/compiler/main/hept2mls.ml @@ -377,7 +377,7 @@ let translate_contract env contract = let node { Heptagon.n_name = n; Heptagon.n_input = i; Heptagon.n_output = o; - Heptagon.n_contract = contract; + Heptagon.n_contract = contract; Heptagon.n_stateful = stateful; Heptagon.n_block = { Heptagon.b_local = v; Heptagon.b_equs = eq_list }; Heptagon.n_loc = loc; Heptagon.n_params = params; @@ -390,10 +390,11 @@ let node translate_eqs env IdentSet.empty (locals, [], []) eq_list in let l_eqs, _ = add_locals IdentSet.empty l_eqs [] s_eqs in { n_name = n; + n_stateful = stateful; n_input = List.map translate_var i; n_output = List.map translate_var o; n_contract = contract; - n_controller_call = ([],[]); + (* n_controller_call = ([],[]); *) n_local = locals; n_equs = l_eqs; n_loc = loc ; diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index adafc5c..690391a 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -31,7 +31,7 @@ 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)) + | Tarray (ty',_), idx :: l -> mk_pattern ty' (Larray (aux ty' l, idx)) | _ -> internal_error "mls2obc" 1 in aux p.pat_ty l @@ -140,12 +140,12 @@ and translate_act map pat let e2 = translate map e2 in let a1 = Afor (cpt1d, mk_static_int 0, n1, - mk_block [Aassgn (mk_pattern t (Larray (x, mk_evar_int cpt1)), + 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 (cpt2d, mk_static_int 0, n2, - mk_block [Aassgn (mk_pattern t (Larray (x, idx)), + 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] @@ -154,18 +154,26 @@ and translate_act map pat let cpt, cptd = fresh_it () in let e = translate map e in let x = Control.var_from_name map x in - [ Afor (cptd, mk_static_int 0, n, mk_block [Aassgn (mk_pattern x.pat_ty (Larray (x, mk_evar_int cpt)), e) ]) ] + 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 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 (cptd, mk_static_int 0, bound, - mk_block [Aassgn (mk_pattern x.pat_ty (Larray (x, mk_evar_int cpt)), - mk_pattern_exp e.e_ty (Larray (pattern_of_exp e, idx)))] ) ] + 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 @@ -191,7 +199,7 @@ and translate_act map pat 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_pattern x.pat_ty (Lfield (x, f)), translate map e2) in + let action = Aassgn (mk_pattern x.pat_ty (Lfield (x, f)), translate map e2) in (* TODO wrong type *) [copy; action] | Minils.Evarpat n, _ -> @@ -449,15 +457,9 @@ let subst_map inputs outputs locals mem_tys = 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) = Idents.enter_node f; let mem_var_tys = Mls_utils.node_memory_vars n in @@ -467,20 +469,21 @@ let translate_node 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.exists (fun (i,_) -> i = vd.v_ident) mem_var_tys) d_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 = 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 - { cd_name = f; cd_mems = m; cd_params = params; - cd_objs = j; cd_methods = [stepm; resetm]; - cd_loc = loc } + 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 } = @@ -488,8 +491,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; @@ -499,19 +502,12 @@ let translate_const_def { Minils.c_name = name; Minils.c_value = se; c_type = ty; c_loc = loc } -let program { - Minils.p_modname = p_modname; - Minils.p_opened = p_module_list; - Minils.p_types = p_type_list; - Minils.p_nodes = p_node_list; - Minils.p_consts = p_const_list -} = - { - p_modname = p_modname; - p_opened = p_module_list; - p_types = List.map translate_ty_def p_type_list; - p_consts = List.map translate_const_def p_const_list; - p_defs = List.map translate_node p_node_list; - } +let program { Minils.p_modname = p_modname; Minils.p_opened = p_module_list; Minils.p_types = p_type_list; + Minils.p_nodes = p_node_list; Minils.p_consts = p_const_list } = + { p_modname = p_modname; + p_opened = p_module_list; + p_types = List.map translate_ty_def p_type_list; + p_consts = List.map translate_const_def p_const_list; + p_classes = List.map translate_node p_node_list; } diff --git a/compiler/minils/main/mls2seq.ml b/compiler/minils/main/mls2seq.ml index d707659..5443fad 100644 --- a/compiler/minils/main/mls2seq.ml +++ b/compiler/minils/main/mls2seq.ml @@ -19,6 +19,7 @@ open Misc 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) @@ -38,8 +39,9 @@ let write_obc_file p = close_out obc; comment "Generation of Obc code" + let targets = [ "c", Obc_no_params Cmain.program; - "java", Obc Java_main.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 ] @@ -69,6 +71,9 @@ 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 p = p |> Mls2obc.program |> Scalarize.program in + convert_fun p (** Translation into dataflow and sequential languages, defaults to obc. *) diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index 0daa021..1eba85f 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -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; @@ -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; @@ -174,4 +176,3 @@ let mk_program o n t c = p_opened = o; p_nodes = n; p_types = t; p_consts = c } let void = mk_exp ~ty:Types.Tunit (Eapp (mk_app Etuple, [], None)) - diff --git a/compiler/minils/transformations/callgraph.ml b/compiler/minils/transformations/callgraph.ml index 54f0e69..f340590 100644 --- a/compiler/minils/transformations/callgraph.ml +++ b/compiler/minils/transformations/callgraph.ml @@ -14,7 +14,7 @@ module Error = struct type error = | Enode_unbound of qualname - | Epartial_evaluation 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_evaluation 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 Errors.Error se -> - Error.message no_location (Error.Epartial_evaluation 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]. *) diff --git a/compiler/minils/transformations/checkpass.ml b/compiler/minils/transformations/checkpass.ml index 0c850b7..2a023a2 100644 --- a/compiler/minils/transformations/checkpass.ml +++ b/compiler/minils/transformations/checkpass.ml @@ -46,7 +46,7 @@ let add_check prefix pass nd nd_list = Modules.add_value nd_check.n_name { node_inputs = []; node_outputs = [{ a_name = None; a_type = Tid Initial.pbool; }]; - node_statefull = true; + node_stateful = true; node_params = []; node_params_constraints = [] }; diff --git a/compiler/minils/transformations/tomato.ml b/compiler/minils/transformations/tomato.ml index 2873792..6ddf5ec 100644 --- a/compiler/minils/transformations/tomato.ml +++ b/compiler/minils/transformations/tomato.ml @@ -405,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. *) diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index ccee9f4..8870142 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -73,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)) @@ -100,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 @@ -362,7 +362,7 @@ 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 (name o)) @@ -471,7 +471,7 @@ let rec cstm_of_act var_env obj_env act = (** For composition of statements, just recursively apply our translation function on sub-statements. *) - | Afor ({ v_ident = 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)] @@ -541,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 [] @@ -594,7 +594,7 @@ 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) @@ -603,7 +603,7 @@ let mem_decl_of_class_def cd = 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. *) @@ -622,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; @@ -635,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 = @@ -651,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 @@ -748,7 +753,7 @@ let global_file_header name prog = let dependencies = List.map modul_to_string dependencies in let (decls, defs) = - List.split (List.map cdefs_and_cdecls_of_class_def prog.p_defs) in + List.split (List.map cdefs_and_cdecls_of_class_def prog.p_classes) in let decls = List.concat decls and defs = List.concat defs in diff --git a/compiler/obc/c/cmain.ml b/compiler/obc/c/cmain.ml index 7813311..e386f92 100644 --- a/compiler/obc/c/cmain.ml +++ b/compiler/obc/c/cmain.ml @@ -88,7 +88,7 @@ let assert_node_res cd = statements) needed for a main() function calling [cd]. *) 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" @@ -98,7 +98,7 @@ let main_def_of_class_def cd = (** 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 @@ -262,7 +262,7 @@ let mk_main name p = 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 diff --git a/compiler/obc/java/java.ml b/compiler/obc/java/java.ml index cf954a2..f2b5d2b 100644 --- a/compiler/obc/java/java.ml +++ b/compiler/obc/java/java.ml @@ -23,6 +23,7 @@ type ty = Tclass of class_name | Tint | Tfloat | Tarray of ty * exp + | Tref of ty | Tunit and classe = { c_protection : protection; @@ -81,6 +82,7 @@ and exp = Eval of pattern | 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 @@ -99,13 +101,14 @@ and pattern = Pfield of pattern * field_name type program = classe list -let default_value ty = match ty with +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,[]) diff --git a/compiler/obc/java/java_printer.ml b/compiler/obc/java/java_printer.ml index 47ce9c4..173388e 100644 --- a/compiler/obc/java/java_printer.ml +++ b/compiler/obc/java/java_printer.ml @@ -42,6 +42,7 @@ let rec _ty size ff t = match t with | 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 @@ -78,6 +79,7 @@ and exp ff = function | [] -> 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 diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index 48f8392..195e7db 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -52,6 +52,10 @@ let rec translate_modul m = match m with 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 = @@ -94,7 +98,17 @@ let rec static_exp param_env se = match se.Types.se_desc with | 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 _ -> eprintf "ojSarray_power@."; assert false; (* TODO java array *) + | 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) @@ -106,11 +120,12 @@ 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.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 - Tgeneric (java_pervasive_class ("Tuple"^ln), List.map (boxed_ty param_env) ty_l) + 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 @@ -119,6 +134,7 @@ and ty param_env t :Java.ty = match t with | Types.Tid t when t = Initial.pfloat -> Tfloat | Types.Tid t -> Tclass (qualname_to_class_name t) | Types.Tarray (t,size) -> Tarray (ty param_env t, static_exp param_env size) + | Types.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 } @@ -166,7 +182,15 @@ let rec act_list param_env act_l acts = 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 = - Aassgn (pattern param_env p, Eval (Pfield (Pvar return_id, "c"^(string_of_int i)))) + 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) @@ -231,8 +255,6 @@ let copy_to_this vd_l = List.map _vd vd_l - - let class_def_list classes cd_l = let class_def classes cd = Idents.enter_node cd.cd_name; @@ -249,23 +271,24 @@ let class_def_list classes cd_l = [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 = - 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 + 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 = (* In async we change the type of the async objects *) + 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 = - (* TODO java array : also initialize arrays with [ new int[3] ] *) - (* Initialize the objects *) + (* 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 @@ -280,13 +303,23 @@ let class_def_list classes cd_l = :: (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 = acts } + { b_locals = []; b_body = List.rev acts } in mk_methode ~args:vds_params body (shortname class_name), obj_env in let fields = @@ -367,7 +400,7 @@ let const_dec_list cd_l = match cd_l with 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_defs in + let p = class_def_list classes p.p_classes in get_classes()@p diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index 78cbc36..ea9adca 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -108,16 +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 : modul; p_opened : modul list; p_types : type_dec list; p_consts : const_dec list; - p_defs : class_def list } + p_classes : class_def list; } diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml index 181552e..462712f 100644 --- a/compiler/obc/obc_mapfold.ml +++ b/compiler/obc/obc_mapfold.ml @@ -147,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 @@ -186,8 +188,8 @@ and program_it funs acc p = funs.program funs acc p and program funs acc p = let td_list, acc = mapfold (type_dec_it funs) acc p.p_types in let cd_list, acc = mapfold (const_dec_it funs) acc p.p_consts in - let nd_list, acc = mapfold (class_def_it funs) acc p.p_defs in - { p with p_types = td_list; p_consts = cd_list; p_defs = nd_list }, acc + let nd_list, acc = mapfold (class_def_it funs) acc p.p_classes in + { p with p_types = td_list; p_consts = cd_list; p_classes = nd_list }, acc let defaults = { diff --git a/compiler/obc/obc_printer.ml b/compiler/obc/obc_printer.ml index c380ff0..7a17401 100644 --- a/compiler/obc/obc_printer.ml +++ b/compiler/obc/obc_printer.ml @@ -152,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 @@ -179,12 +180,12 @@ let print_const_dec ff c = print_static_exp c.c_value let print_prog ff { p_opened = modules; p_types = types; - p_consts = consts; p_defs = defs } = + p_consts = consts; p_classes = classes; } = List.iter (print_open_module ff) modules; List.iter (print_type_def ff) types; List.iter (print_const_dec ff) consts; fprintf ff "@\n"; - List.iter (fun def -> (print_class_def ff def; fprintf ff "@\n@\n")) defs + List.iter (fun cdef -> (print_class_def ff cdef; fprintf ff "@\n@\n")) classes let print oc p = let ff = formatter_of_out_channel oc in diff --git a/compiler/obc/transformations/scalarize.ml b/compiler/obc/transformations/scalarize.ml new file mode 100644 index 0000000..38b1110 --- /dev/null +++ b/compiler/obc/transformations/scalarize.ml @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(** Remove implicit array's deep copy. If ever some p = e with p of type array still exist, + they are only used as reference to the array, no copy is implied : + array assignation after [scalarize] is pointer wise assignation *) + + +open Misc +open Obc +open Obc_utils +open Obc_mapfold + + +(** fresh Afor from 0 to [size] with [body] a function from [var_ident] (the iterator) to [act] list *) +let fresh_for size body = + let i = Idents.gen_var "scalarize" "i" in + let id = mk_var_dec i Initial.tint in + let ei = mk_evar_int i in + Afor (id, Initial.mk_static_int 0, size, mk_block (body ei)) + + +let act funs () a = match a with + | Aassgn (p,e) -> + (match e.e_ty with + | Types.Tarray (t, size) -> + (* a reference (alias) to the array, since we could have a full expression *) + let array_ref = Idents.gen_var "scalarize" "a_ref" in + let vd_array_ref = mk_var_dec array_ref (Types.Tmutable p.pat_ty) in + (* reference initialization *) + let pat_array_ref = mk_pattern ~loc:e.e_loc p.pat_ty (Lvar array_ref) in + let init_array_ref = Aassgn (pat_array_ref, e) in + (* the copy loop *) + let array_ref_i i = mk_pattern_exp t (Larray (pat_array_ref, i)) in + let p_i i = mk_pattern t (Larray (p, i)) in + let copy_i i = + (* recursive call to deal with multidimensional arrays (go deeper) *) + let a = Aassgn (p_i i, array_ref_i i) in + let a, _ = act_it funs () a in + [a] + in + let copy_array = fresh_for size copy_i in + (* resulting block *) + let block = mk_block ~locals:[vd_array_ref] [init_array_ref; copy_array] in + Ablock block, () + | _ -> raise Errors.Fallback + ) + | _ -> raise Errors.Fallback + + +let program p = + let p, _ = program_it { defaults with act = act } () p in + p + + diff --git a/heptc b/heptc index 92b231b..94c9a58 100755 --- a/heptc +++ b/heptc @@ -9,17 +9,25 @@ SCRIPT_DIR=$RUN_DIR/`dirname $0` COMPILER_DIR=$SCRIPT_DIR/compiler COMPILER=heptc.byte +COMPILER_DEBUG=heptc.d.byte LIB_DIR=$SCRIPT_DIR/lib #the symlink HEPTC=$COMPILER_DIR/$COMPILER +HEPTC_DEBUG=$COMPILER_DIR/$COMPILER_DEBUG #compile the compiler if [ ! -x $HEPTC ] then - cd $COMPILER_DIR - ocamlbuild -j 0 $COMPILER - cd - + if [ -x $HEPTC_DEBUG ] + then + #use the debug + HEPTC=$HEPTC_DEBUG + else + cd $COMPILER_DIR + ocamlbuild -j 0 $COMPILER + cd - + fi fi #compile the stdlib diff --git a/lib/java/jeptagon/Pervasives.java b/lib/java/jeptagon/Pervasives.java index 607c052..6508a64 100644 --- a/lib/java/jeptagon/Pervasives.java +++ b/lib/java/jeptagon/Pervasives.java @@ -25,48 +25,39 @@ public class Pervasives { public V get(long timeout, TimeUnit unit) { return v; } } - public static class Tuple1 { - public final T c0; - public Tuple1(T v) { + public static class Tuple1 { + public final Object c0; + public Tuple1(Object v) { c0 = v; } } - public static class Tuple22 { + public static class Tuple2 { public final Object c0; public final Object c1; - public Tuple22(Object v0, Object v1) { + public Tuple2(Object v0, Object v1) { c0 = v0; c1 = v1; } } - public static class Tuple2 { - public final T0 c0; - public final T1 c1; - public Tuple2(T0 v0, T1 v1) { - c0 = v0; - c1 = v1; - } - } - - public static class Tuple3 { - public final T0 c0; - public final T1 c1; - public final T2 c2; - public Tuple3(T0 v0, T1 v1, T2 v2) { + 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 T0 c0; - public final T1 c1; - public final T2 c2; - public final T3 c3; - public Tuple4(T0 v0, T1 v1, T2 v2, T3 v3) { + 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; @@ -74,13 +65,13 @@ public class Pervasives { } } - public static class Tuple5 { - public final T0 c0; - public final T1 c1; - public final T2 c2; - public final T3 c3; - public final T4 c4; - public Tuple5(T0 v0, T1 v1, T2 v2, T3 v3, T4 v4) { + 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; @@ -89,14 +80,14 @@ public class Pervasives { } } - public static class Tuple6 { - public final T0 c0; - public final T1 c1; - public final T2 c2; - public final T3 c3; - public final T4 c4; - public final T5 c5; - public Tuple6(T0 v0, T1 v1, T2 v2, T3 v3, T4 v4, T5 v5) { + 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; @@ -106,15 +97,15 @@ public class Pervasives { } } - public static class Tuple7 { - public final T0 c0; - public final T1 c1; - public final T2 c2; - public final T3 c3; - public final T4 c4; - public final T5 c5; - public final T6 c6; - public Tuple7(T0 v0, T1 v1, T2 v2, T3 v3, T4 v4, T5 v5, T6 v6) { + 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; diff --git a/test/async/pipline.ept b/test/async/pipline.ept index 08f4ac7..240bc51 100644 --- a/test/async/pipline.ept +++ b/test/async/pipline.ept @@ -12,7 +12,7 @@ tel fun mean<> (i: int^n) returns (m: int) let - m = fold sum <> (i,0) + m = (fold (+) <> (i,0)) /n tel diff --git a/test/async/scalarize.ept b/test/async/scalarize.ept new file mode 100644 index 0000000..f4ced3a --- /dev/null +++ b/test/async/scalarize.ept @@ -0,0 +1,7 @@ + +node f() returns () +var t1,t2 : int^4; +let + t1 = [3, 5, 6, 7]; + t2 = map (+) <<4>> (4^4,t1); +tel diff --git a/test/good/array_fill.ept b/test/good/array_fill.ept index 3cac5b9..4078a15 100644 --- a/test/good/array_fill.ept +++ b/test/good/array_fill.ept @@ -1,9 +1,10 @@ const n : int = 33 node stopbb(shiftenable : bool) returns (dataout : bool^n) -var last dataint : bool^n = false^n; +var last dataint : bool^n; f : bool; let - dataout = (false^n) fby dataint; + f = false; + dataout = (f^n) fby dataint; switch shiftenable | true do dataint = [true] @ dataout[0 .. n - 2]; | false do diff --git a/todo.txt b/todo.txt index 498fbf2..b83963b 100644 --- a/todo.txt +++ b/todo.txt @@ -3,7 +3,7 @@ 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. -*- Functions in Obc should not be objetcs. +*- 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. diff --git a/tools/debugger_script b/tools/debugger_script index 1caea16..b55afc3 100644 --- a/tools/debugger_script +++ b/tools/debugger_script @@ -1,29 +1,31 @@ -load_printer "_build/global/names.d.cmo" -load_printer "_build/global/location.d.cmo" +load_printer "/sw/lib/ocaml/menhirLib/menhirLib.cmo" +load_printer "/sw/lib/ocaml/str.cma" +load_printer "_build/menhirLib.cmo" load_printer "_build/utilities/misc.d.cmo" -load_printer "_build/global/types.d.cmo" -load_printer "_build/global/signature.d.cmo" +load_printer "_build/global/names.d.cmo" load_printer "_build/utilities/global/compiler_options.d.cmo" +load_printer "_build/global/idents.d.cmo" +load_printer "_build/global/location.d.cmo" +load_printer "_build/global/types.d.cmo" +load_printer "_build/global/clocks.d.cmo" +load_printer "_build/global/signature.d.cmo" load_printer "_build/utilities/global/errors.d.cmo" load_printer "_build/utilities/global/compiler_utils.d.cmo" load_printer "_build/global/modules.d.cmo" -load_printer "_build/global/initial.d.cmo" -load_printer "_build/global/idents.d.cmo" -load_printer "_build/global/clocks.d.cmo" load_printer "_build/utilities/pp_tools.d.cmo" load_printer "_build/global/global_printer.d.cmo" +load_printer "_build/global/initial.d.cmo" load_printer "_build/global/static.d.cmo" load_printer "_build/heptagon/heptagon.d.cmo" +load_printer "_build/utilities/graph.d.cmo" +load_printer "_build/heptagon/analysis/causal.d.cmo" +load_printer "_build/heptagon/analysis/causality.d.cmo" load_printer "_build/heptagon/analysis/initialization.d.cmo" load_printer "_build/global/global_mapfold.d.cmo" load_printer "_build/heptagon/hept_mapfold.d.cmo" load_printer "_build/heptagon/analysis/statefull.d.cmo" load_printer "_build/heptagon/analysis/typing.d.cmo" load_printer "_build/heptagon/hept_printer.d.cmo" -load_printer "_build/heptagon/parsing/hept_parsetree.d.cmo" -load_printer "_build/heptagon/parsing/hept_parser.d.cmo" -load_printer "_build/heptagon/parsing/hept_lexer.d.cmo" -load_printer "_build/heptagon/parsing/hept_scoping.d.cmo" load_printer "_build/heptagon/transformations/automata.d.cmo" load_printer "_build/heptagon/transformations/block.d.cmo" load_printer "_build/heptagon/transformations/completion.d.cmo" @@ -31,28 +33,34 @@ load_printer "_build/heptagon/transformations/reset.d.cmo" load_printer "_build/heptagon/transformations/every.d.cmo" load_printer "_build/heptagon/transformations/last.d.cmo" load_printer "_build/heptagon/transformations/present.d.cmo" +load_printer "_build/heptagon/transformations/switch.d.cmo" load_printer "_build/heptagon/main/hept_compiler.d.cmo" +load_printer "_build/heptagon/parsing/hept_parsetree.d.cmo" +load_printer "_build/heptagon/parsing/hept_parser.d.cmo" +load_printer "_build/heptagon/parsing/hept_lexer.d.cmo" +load_printer "_build/heptagon/parsing/hept_scoping.d.cmo" load_printer "_build/heptagon/parsing/hept_parsetree_mapfold.d.cmo" load_printer "_build/heptagon/parsing/hept_static_scoping.d.cmo" +load_printer "_build/heptagon/main/hept_parser_scoper.d.cmo" load_printer "_build/minils/minils.d.cmo" load_printer "_build/minils/mls_mapfold.d.cmo" load_printer "_build/minils/mls_printer.d.cmo" -load_printer "_build/utilities/graph.d.cmo" load_printer "_build/utilities/global/dep.d.cmo" load_printer "_build/minils/mls_utils.d.cmo" load_printer "_build/main/hept2mls.d.cmo" load_printer "_build/minils/transformations/itfusion.d.cmo" load_printer "_build/obc/obc.d.cmo" -load_printer "_build/obc/control.d.cmo" load_printer "_build/obc/obc_mapfold.d.cmo" +load_printer "_build/obc/obc_utils.d.cmo" +load_printer "_build/obc/control.d.cmo" load_printer "_build/main/mls2obc.d.cmo" load_printer "_build/minils/transformations/callgraph.d.cmo" -load_printer "_build/obc/c/c.d.cmo" -load_printer "_build/obc/c/csubst.d.cmo" -load_printer "_build/obc/obc_utils.d.cmo" -load_printer "_build/obc/c/cgen.d.cmo" -load_printer "_build/obc/c/cmain.d.cmo" +load_printer "_build/obc/java/java.d.cmo" +load_printer "_build/obc/java/java_printer.d.cmo" +load_printer "_build/obc/java/obc2java.d.cmo" +load_printer "_build/obc/java/java_main.d.cmo" load_printer "_build/obc/obc_printer.d.cmo" +load_printer "_build/obc/transformations/scalarize.d.cmo" load_printer "_build/minils/main/mls2seq.d.cmo" load_printer "_build/minils/analysis/clocking.d.cmo" load_printer "_build/minils/transformations/normalize.d.cmo" @@ -64,5 +72,5 @@ load_printer "_build/minils/transformations/introvars.d.cmo" load_printer "_build/minils/transformations/singletonvars.d.cmo" load_printer "_build/minils/transformations/tomato.d.cmo" load_printer "_build/minils/main/mls_compiler.d.cmo" -load_printer "_build/main/heptc.d.cmo" +load_printer "_build/main/heptc.d.cmo