From a519afe6311c50f294ae3024150ba35d349b6320 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 27 Jun 2011 11:07:14 +0200 Subject: [PATCH 1/9] heptc script fix --- heptc | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/heptc b/heptc index b5648c8..13fca73 100755 --- a/heptc +++ b/heptc @@ -3,8 +3,7 @@ RUN_DIR="`pwd`" - -SCRIPT_DIR="$RUN_DIR/`dirname $0`" +SCRIPT_DIR="$( cd "$( dirname "$0" )" && pwd )" COMPILER_DIR="$SCRIPT_DIR/compiler" COMPILER=heptc.byte From 9e881550a7b4c92d3ed4ae8f0672c1adec5e0fe4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 27 Jun 2011 11:07:40 +0200 Subject: [PATCH 2/9] test iterators. --- test/good/array_iterators.ept | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/test/good/array_iterators.ept b/test/good/array_iterators.ept index 802a793..05dbd03 100644 --- a/test/good/array_iterators.ept +++ b/test/good/array_iterators.ept @@ -1,10 +1,16 @@ const n:int = 42 + node plusone(a:int) returns (o:int) let o = a+1; tel +fun f() returns (o:int^n) +let + o = mapi<> plusone (); +tel + node g(a:int^n) returns (o:int^n) let o = map<> plusone (a); From c70d34ec0654bee3f2aa1b4db48e897e7bba303d Mon Sep 17 00:00:00 2001 From: Brice Gelineau Date: Mon, 27 Jun 2011 10:58:14 +0200 Subject: [PATCH 3/9] Preliminary version of multidimensional iterators. --- compiler/heptagon/analysis/typing.ml | 67 +++--- compiler/heptagon/hept_mapfold.ml | 6 +- compiler/heptagon/hept_printer.ml | 6 +- compiler/heptagon/heptagon.ml | 2 +- compiler/heptagon/obc_mapfold.ml | 221 ++++++++++++++++++ compiler/heptagon/parsing/hept_parser.mly | 6 +- compiler/heptagon/parsing/hept_parsetree.ml | 6 +- .../parsing/hept_parsetree_mapfold.ml | 6 +- compiler/heptagon/parsing/hept_scoping.ml | 6 +- compiler/heptagon/transformations/itfusion.ml | 2 +- compiler/main/mls2obc.ml | 75 +++--- compiler/main/mls2seq.ml | 2 +- compiler/minils/minils.ml | 2 +- compiler/minils/mls_mapfold.ml | 6 +- compiler/minils/mls_printer.ml | 4 +- compiler/obc/c/cgen.ml | 27 ++- compiler/obc/obc.ml | 4 +- compiler/obc/obc_mapfold.ml | 2 +- compiler/obc/obc_printer.ml | 6 +- compiler/utilities/misc.ml | 30 +++ compiler/utilities/misc.mli | 8 + 21 files changed, 399 insertions(+), 95 deletions(-) create mode 100644 compiler/heptagon/obc_mapfold.ml diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index c1f1236..2b67f70 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -559,7 +559,7 @@ let rec typing cenv h e = | Eiterator (it, ({ a_op = (Enode f | Efun f); a_params = params } as app), - n, pe_list, e_list, reset) -> + n_list, 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 = @@ -568,19 +568,19 @@ let rec typing cenv h e = let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in let result_ty_list = List.map (subst_type_vars m) result_ty_list in - let typed_n = expect_static_exp cenv (Tid Initial.pint) n in + let typed_n_list = List.map (expect_static_exp const_env (Tid Initial.pint)) n_list 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 cenv h p_ty_list pe_list in (*typing of other arguments*) - let ty, typed_e_list = typing_iterator cenv h it n + let ty, typed_e_list = typing_iterator const_env h it n_list expected_ty_list result_ty_list e_list in let typed_params = typing_node_params cenv ty_desc.node_params params in (* add size constraints *) let constrs = List.map (simplify m) ty_desc.node_param_constraints in - add_constraint_leq cenv (mk_static_int 1) typed_n; + List.iter (fun n -> add_size_constraint (Clequal (mk_static_int 1, n))) typed_n_list; List.iter (add_constraint cenv) constrs; (* return the type *) Eiterator(it, { app with a_op = op; a_params = typed_params } @@ -788,31 +788,40 @@ and typing_app cenv h app e_list = -and typing_iterator cenv h - it n args_ty_list result_ty_list e_list = match it with +and typing_iterator const_env h + it n_list args_ty_list result_ty_list e_list = + let rec array_of_idx_list l ty = match l with + | [] -> ty + | n::l -> array_of_idx_list l (Tarray(ty, n)) + in + let mk_array_type ty_list = List.map (array_of_idx_list n_list) ty_list in + let n_size = List.length n_list in + let mk_array_type_butnlast ty_list = + map_butnlast n_size (array_of_idx_list n_list) ty_list in + match it with | Imap -> - let args_ty_list = List.map (fun ty -> Tarray(ty, n)) args_ty_list in - let result_ty_list = - List.map (fun ty -> Tarray(ty, n)) result_ty_list in - let typed_e_list = typing_args cenv h + let args_ty_list = mk_array_type args_ty_list in + let result_ty_list = mk_array_type result_ty_list in + let typed_e_list = typing_args const_env h args_ty_list e_list in prod result_ty_list, typed_e_list | Imapi -> - let args_ty_list, idx_ty = split_last args_ty_list in - let args_ty_list = List.map (fun ty -> Tarray(ty, n)) args_ty_list in - let result_ty_list = - List.map (fun ty -> Tarray(ty, n)) result_ty_list in + let args_ty_list, idx_ty_list = split_nlast n_size args_ty_list in + let args_ty_list = mk_array_type args_ty_list in + let result_ty_list = mk_array_type result_ty_list in (* Last but one arg of the function should be integer *) - ( try unify cenv idx_ty (Tid Initial.pint) - with TypingError _ -> raise (TypingError (Emapi_bad_args idx_ty))); - let typed_e_list = typing_args cenv h + List.iter + (fun idx_ty -> + ( try unify cenv idx_ty (Tid Initial.pint) + with TypingError _ -> raise (TypingError (Emapi_bad_args idx_ty)))) + idx_ty_list; + let typed_e_list = typing_args const_env h args_ty_list e_list in prod result_ty_list, typed_e_list | Ifold -> - let args_ty_list = - map_butlast (fun ty -> Tarray (ty, n)) args_ty_list in + let args_ty_list = mk_array_type_butnlast args_ty_list in let typed_e_list = typing_args cenv h args_ty_list e_list in (*check accumulator type matches in input and output*) @@ -823,12 +832,14 @@ and typing_iterator cenv h | Ifoldi -> let args_ty_list, acc_ty = split_last args_ty_list in - let args_ty_list, idx_ty = split_last args_ty_list in + let args_ty_list, idx_ty_list = split_nlast n_size args_ty_list in (* Last but one arg of the function should be integer *) - ( try unify cenv idx_ty (Tid Initial.pint) - with TypingError _ -> raise (TypingError (Efoldi_bad_args idx_ty))); - let args_ty_list = - map_butlast (fun ty -> Tarray (ty, n)) (args_ty_list@[acc_ty]) in + List.iter + (fun idx_ty -> + ( try unify cenv idx_ty (Tid Initial.pint) + with TypingError _ -> raise (TypingError (Emapi_bad_args idx_ty)))) + idx_ty_list; + let args_ty_list = mk_array_type_butnlast (args_ty_list@[acc_ty]) in let typed_e_list = typing_args cenv h args_ty_list e_list in (*check accumulator type matches in input and output*) @@ -838,11 +849,9 @@ and typing_iterator cenv h (List.hd result_ty_list), typed_e_list | Imapfold -> - let args_ty_list = - map_butlast (fun ty -> Tarray (ty, n)) args_ty_list in - let result_ty_list = - map_butlast (fun ty -> Tarray (ty, n)) result_ty_list in - let typed_e_list = typing_args cenv h + let args_ty_list = mk_array_type_butnlast args_ty_list in + let result_ty_list = mk_array_type_butnlast result_ty_list in + let typed_e_list = typing_args const_env h args_ty_list e_list in (*check accumulator type matches in input and output*) ( try unify cenv (last_element args_ty_list) (last_element result_ty_list) diff --git a/compiler/heptagon/hept_mapfold.ml b/compiler/heptagon/hept_mapfold.ml index 86df74a..e20ba77 100644 --- a/compiler/heptagon/hept_mapfold.ml +++ b/compiler/heptagon/hept_mapfold.ml @@ -109,13 +109,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, pargs, args, reset) -> + | Eiterator (i, app, params, 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 params, acc = mapfold (static_exp_it funs.global_funs) acc params 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, pargs, args, reset), acc + Eiterator (i, app, params, 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 b2627d4..5a1c741 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -111,11 +111,11 @@ 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, pargs, args, reset) -> - fprintf ff "@[<2>(%s (%a)<<%a>>)@,(%a)%a@]%a" + | Eiterator (it, f, params, pargs, args, reset) -> + fprintf ff "@[<2>(%s (%a)%a)@,(%a)%a@]%a" (iterator_to_string it) print_app (f, []) - print_static_exp param + (print_list_r print_static_exp "<<"","">>") params print_exp_tuple pargs print_exp_tuple args print_every reset diff --git a/compiler/heptagon/heptagon.ml b/compiler/heptagon/heptagon.ml index 3aadc1b..7d4d91b 100644 --- a/compiler/heptagon/heptagon.ml +++ b/compiler/heptagon/heptagon.ml @@ -46,7 +46,7 @@ and desc = | Emerge of var_ident * (constructor_name * exp) list (** merge ident (Constructor -> exp)+ *) | Eapp of app * exp list * exp option - | Eiterator of iterator_type * app * static_exp + | Eiterator of iterator_type * app * static_exp list * exp list * exp list * exp option and app = { diff --git a/compiler/heptagon/obc_mapfold.ml b/compiler/heptagon/obc_mapfold.ml new file mode 100644 index 0000000..4ee29b6 --- /dev/null +++ b/compiler/heptagon/obc_mapfold.ml @@ -0,0 +1,221 @@ + (**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +(* Generic mapred over Obc Ast *) +open Misc +open Errors +open Global_mapfold +open Obc + +type 'a obc_it_funs = { + exp: 'a obc_it_funs -> 'a -> Obc.exp -> Obc.exp * 'a; + edesc: 'a obc_it_funs -> 'a -> Obc.exp_desc -> Obc.exp_desc * 'a; + lhs: 'a obc_it_funs -> 'a -> Obc.pattern -> Obc.pattern * 'a; + lhsdesc: 'a obc_it_funs -> 'a -> Obc.pat_desc -> Obc.pat_desc * 'a; + act: 'a obc_it_funs -> 'a -> Obc.act -> Obc.act * 'a; + block: 'a obc_it_funs -> 'a -> Obc.block -> Obc.block * 'a; + var_dec: 'a obc_it_funs -> 'a -> Obc.var_dec -> Obc.var_dec * 'a; + var_decs: 'a obc_it_funs -> 'a -> Obc.var_dec list -> Obc.var_dec list * 'a; + obj_dec: 'a obc_it_funs -> 'a -> Obc.obj_dec -> Obc.obj_dec * 'a; + obj_decs: 'a obc_it_funs -> 'a -> Obc.obj_dec list -> Obc.obj_dec list * 'a; + method_def: 'a obc_it_funs -> 'a -> Obc.method_def -> Obc.method_def * 'a; + class_def: 'a obc_it_funs -> 'a -> Obc.class_def -> Obc.class_def * 'a; + const_dec: 'a obc_it_funs -> 'a -> Obc.const_dec -> Obc.const_dec * 'a; + type_dec: 'a obc_it_funs -> 'a -> Obc.type_dec -> Obc.type_dec * 'a; + tdesc: 'a obc_it_funs -> 'a -> Obc.tdesc -> Obc.tdesc * 'a; + program: 'a obc_it_funs -> 'a -> Obc.program -> Obc.program * 'a; + program_desc: 'a obc_it_funs -> 'a -> Obc.program_desc -> Obc.program_desc * 'a; + global_funs: 'a Global_mapfold.global_it_funs } + + +let rec exp_it funs acc e = funs.exp funs acc e +and exp funs acc e = + let ed, acc = edesc_it funs acc e.e_desc in + { e with e_desc = ed }, acc + + +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 + | Epattern l -> + let l, acc = lhs_it funs acc l in + Epattern l, acc + | Econst se -> + let se, acc = static_exp_it funs.global_funs acc se in + Econst se, acc + | Eop (op, args) -> + let args, acc = mapfold (exp_it funs) acc args in + Eop (op, args), acc + | Estruct(tyn, f_e_list) -> + let aux acc (f,e) = + let e, acc = exp_it funs acc e in + (f,e), acc in + let f_e_list, acc = mapfold aux acc f_e_list in + Estruct(tyn, f_e_list), acc + | Earray args -> + let args, acc = mapfold (exp_it funs) acc args in + Earray args, acc + + +and lhs_it funs acc l = funs.lhs funs acc l +and lhs funs acc l = + let ld, acc = lhsdesc_it funs acc l.pat_desc in + { l with pat_desc = ld }, acc + + +and lhsdesc_it funs acc ld = + try funs.lhsdesc funs acc ld + with Fallback -> lhsdesc funs acc ld +and lhsdesc funs acc ld = match ld with + | Lvar x -> Lvar x, acc + | Lmem x -> Lmem x, acc + | Lfield(lhs, f) -> + let lhs, acc = lhs_it funs acc lhs in + Lfield(lhs, f), acc + | Larray(lhs, e) -> + let lhs, acc = lhs_it funs acc lhs in + let e, acc = exp_it funs acc e in + Larray(lhs, e), acc + + +and act_it funs acc a = + try funs.act funs acc a + with Fallback -> act funs acc a +and act funs acc a = match a with + | Aassgn(lhs, e) -> + let lhs, acc = lhs_it funs acc lhs in + let e, acc = exp_it funs acc e in + Aassgn(lhs, e), acc + | Aop(op_name, args) -> + let args, acc = mapfold (exp_it funs) acc args in + Aop(op_name, args), acc + | Acall(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 + Acall(lhs_list, obj, n, args), acc + | Acase(e, c_b_list) -> + let aux acc (c,b) = + let b, acc = block_it funs acc b in + (c,b), acc in + let e, acc = exp_it funs acc e in + let c_b_list, acc = mapfold aux acc c_b_list in + Acase(e, c_b_list), acc + | Afor(x, idx1, idx2, b) -> + let idx1, acc = exp_it funs acc idx1 in + let idx2, acc = exp_it 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 = + let b_locals, acc = var_decs_it funs acc b.b_locals in + let b_body, acc = mapfold (act_it funs) acc b.b_body in + { b with b_locals = b_locals; b_body = b_body }, acc + +and var_dec_it funs acc vd = funs.var_dec funs acc vd +and var_dec funs acc vd = + let v_type, acc = ty_it funs.global_funs acc vd.v_type in + { vd with v_type = v_type }, acc + +and var_decs_it funs acc vds = funs.var_decs funs acc vds +and var_decs funs acc vds = mapfold (var_dec_it funs) acc vds + + +and obj_dec_it funs acc od = funs.obj_dec funs acc od +and obj_dec funs acc od = + let o_size, acc = optional_wacc + (mapfold (static_exp_it funs.global_funs)) acc od.o_size in + { od with o_size = o_size }, acc + +and obj_decs_it funs acc ods = funs.obj_decs funs acc ods +and obj_decs funs acc ods = mapfold (obj_dec_it funs) acc ods + + +and method_def_it funs acc md = funs.method_def funs acc md +and method_def funs acc md = + let m_inputs, acc = var_decs_it funs acc md.m_inputs in + let m_outputs, acc = var_decs_it funs acc md.m_outputs in + let m_body, acc = block_it funs acc md.m_body in + { md with + m_inputs = m_inputs; m_outputs = m_outputs; m_body = m_body } + , acc + + +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 + let cd_params, acc = mapfold (param_it funs.global_funs) acc cd.cd_params in + let cd_methods, acc = mapfold (method_def_it funs) acc cd.cd_methods in + { cd with + cd_mems = cd_mems; cd_objs = cd_objs; + cd_params = cd_params; cd_methods = cd_methods } + , acc + + +and const_dec_it funs acc c = funs.const_dec funs acc c +and const_dec funs acc c = + let ty, acc = ty_it funs.global_funs acc c.c_type in + let se, acc = static_exp_it funs.global_funs acc c.c_value in + { c with c_type = ty; c_value = se }, acc + + +and type_dec_it funs acc t = funs.type_dec funs acc t +and type_dec funs acc t = + let tdesc, acc = tdesc_it funs acc t.t_desc in + { t with t_desc = tdesc }, acc + + +and tdesc_it funs acc td = + try funs.tdesc funs acc td + with Fallback -> tdesc funs acc td +and tdesc funs acc td = match td with + | Type_struct s -> + let s, acc = structure_it funs.global_funs acc s in + Type_struct s, acc + | _ -> td, acc + + +and program_it funs acc p = funs.program funs acc p +and program funs acc p = + let p_desc, acc = mapfold (program_desc_it funs) acc p.p_desc in + { p with p_desc = p_desc }, acc + +and program_desc_it funs acc pd = + try funs.program_desc funs acc pd + with Fallback -> program_desc funs acc pd +and program_desc funs acc pd = match pd with + | Pconst cd -> let cd, acc = const_dec_it funs acc cd in Pconst cd, acc + | Ptype td -> let td, acc = type_dec_it funs acc td in Ptype td, acc + | Pclass n -> let n, acc = class_def_it funs acc n in Pclass n, acc + +let defaults = { + lhs = lhs; + lhsdesc = lhsdesc; + exp = exp; + edesc = edesc; + act = act; + block = block; + var_dec = var_dec; + var_decs = var_decs; + obj_dec = obj_dec; + obj_decs = obj_decs; + method_def = method_def; + class_def = class_def; + const_dec = const_dec; + type_dec = type_dec; + tdesc = tdesc; + program = program; + program_desc = program_desc; + global_funs = Global_mapfold.defaults } diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index 40e3b3e..5ece9af 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -517,11 +517,11 @@ _exp: | exp AROBASE exp { mk_call Econcat [$1; $3] } /*Iterators*/ - | it=iterator DOUBLE_LESS n=simple_exp DOUBLE_GREATER q=qualname - pargs=delim_slist(COMMA, LESS_LPAREN, RPAREN_GREATER, exp) + | it=iterator DOUBLE_LESS n=separated_nonempty_list(COMMA, simple_exp) DOUBLE_GREATER q=qualname + pargs=delim_slist(COMMA, LPAREN_LESS, GREATER_RPAREN, exp) LPAREN args=exps RPAREN { mk_iterator_call it q [] n pargs args } - | it=iterator DOUBLE_LESS n=simple_exp DOUBLE_GREATER + | it=iterator DOUBLE_LESS n=separated_nonempty_list(COMMA, simple_exp) DOUBLE_GREATER LPAREN q=qualname DOUBLE_LESS sa=array_exp_list DOUBLE_GREATER RPAREN pargs=delim_slist(COMMA, LESS_LPAREN, RPAREN_GREATER, exp) LPAREN args=exps RPAREN diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index 87ae38e..b92ee14 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -82,7 +82,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 * exp list + | Eiterator of iterator_type * app * exp list * exp list * exp list | Ewhen of exp * constructor_name * var_name | Emerge of var_name * (constructor_name * exp) list @@ -240,8 +240,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 pexps exps = - Eiterator (it, mk_app (Enode ln) params, n, pexps, exps) +let mk_iterator_call it ln params n_list pexps exps = + Eiterator (it, mk_app (Enode ln) params, n_list, 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 631939d..2d81624 100644 --- a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml +++ b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml @@ -114,12 +114,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, pargs, args) -> + | Eiterator (i, app, params, pargs, args) -> let app, acc = app_it funs acc app in - let param, acc = exp_it funs acc param in + let params, acc = mapfold (exp_it funs) acc params 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, pargs, args), acc + Eiterator (i, app, params, 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 3d0cad3..eddcff3 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -285,14 +285,14 @@ and translate_desc loc env = function let app = mk_app ~params:params (translate_op op) in Heptagon.Eapp (app, e_list, None) - | Eiterator (it, { a_op = op; a_params = params }, n, pe_list, e_list) -> + | Eiterator (it, { a_op = op; a_params = params }, n_list, 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 n_list = List.map expect_static_exp n_list in let params = List.map (expect_static_exp) params in let app = mk_app ~params:params (translate_op op) in Heptagon.Eiterator (translate_iterator_type it, - app, n, pe_list, e_list, None) + app, n_list, pe_list, e_list, None) | Ewhen (e, c, x) -> let x = Rename.var loc env x in let e = translate_exp env e in diff --git a/compiler/heptagon/transformations/itfusion.ml b/compiler/heptagon/transformations/itfusion.ml index 57fea0b..b0fd598 100644 --- a/compiler/heptagon/transformations/itfusion.ml +++ b/compiler/heptagon/transformations/itfusion.ml @@ -108,7 +108,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 List.for_all2 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 | _ -> diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 29eb6bc..9eded13 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -91,6 +91,14 @@ let array_elt_of_exp idx e = mk_ext_value_exp ty (Warray(ext_value_of_exp e, idx)) | _ -> internal_error "mls2obc" +let rec array_elt_of_exp_list idx_list e = + 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_exp ty (Epattern (pattern_of_idx_list (pattern_of_exp e) idx_list)) + | _ -> internal_error "mls2obc" 2 + (** Creates the expression that checks that the indices in idx_list are in the bounds. If idx_list=[e1;..;ep] and bounds = [n1;..;np], it returns @@ -367,7 +375,7 @@ and translate_act map pat assert false (** In an iteration, objects used are element of object arrays *) -type obj_array = { oa_index : Obc.pattern; oa_size : static_exp } +type obj_array = { oa_index : Obc.pattern list; oa_size : static_exp list } (** A [None] context is normal, otherwise, we are in an iteration *) type call_context = obj_array option @@ -431,12 +439,13 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } let name_list = translate_pat map e.Minils.e_ty pat in let p_list = List.map (translate_extvalue_to_exp map) pe_list in let c_list = List.map (translate_extvalue_to_exp 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 n = mk_exp_static_int n in + let xl, xdl = List.split (List.map (fun _ -> fresh_it ()) n_list) in + let call_context = + Some { oa_index = List.map (fun x -> mk_pattern_int (Lvar x)) xl; + oa_size = n_list} in + let n_list = List.map mk_exp_static_int n_list 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 + name_list app loc n_list xl xdl p_list c_list e.Minils.e_ty in let action = List.map (control map ck) action in let s = (match reset, app.Minils.a_op with @@ -509,50 +518,64 @@ and mk_node_call map call_context app loc (name_list : Obc.pattern list) args ty | _ -> assert false 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 + app loc n_list xl xdl p_list c_list ty = + let rec unarray n ty = match ty, n with + | Tarray (t,_), 1 -> t + | Tarray (t,_), n -> unarray (n-1) t | _ -> Format.eprintf "%a" Global_printer.print_type ty; internal_error "mls2obc" in + let unarray = unarray (List.length n_list) 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 + let rec aux l ty xl = match ty, xl with + | _, [] -> l + | Tarray(tyn, _), x :: xl -> aux (mk_pattern ~loc:loc ty (Larray(l, mk_evar_int x))) tyn xl + | _, _ -> assert false + in + List.map2 (fun l ty -> aux l ty xl) name_list ty_list in let array_of_input c_list = - List.map (array_elt_of_exp (mk_evar_int x)) c_list in + List.map (array_elt_of_exp_list (List.map mk_evar_int xl)) c_list + in + let mk_loop b xdl nl = + let rec mk_loop b xdl nl = match xdl, nl with + | xd::[], n::[] -> Afor (xd, mk_exp_const_int 0, n, b) + | xd::xdl, n::nl -> mk_loop (mk_block [Afor (xd, mk_exp_const_int 0, n, b)]) xdl nl + | _, _ -> assert false + in + mk_loop b (List.rev xdl) nl + 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 name_list = array_of_output name_list (Types.unprod ty) 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 (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_exp_const_int 0, n, bi)], j, - [Afor (xd, mk_exp_const_int 0, n, b)] + [mk_loop bi xdl n_list], j, [mk_loop b xdl n_list] | Minils.Imapi -> 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 name_list = array_of_output name_list (Types.unprod ty) 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 (p_list@c_list@[mk_evar_int x]) node_out_ty in + app loc name_list (p_list@c_list@(List.map mk_evar_int xl)) 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_exp_const_int 0, n, bi)], j, - [Afor (xd, mk_exp_const_int 0, n, b)] + [mk_loop bi xdl n_list], j, [mk_loop b xdl n_list] | Minils.Imapfold -> let (c_list, acc_in) = split_last c_list in let c_list = array_of_input c_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 ty_name_list, _ = Misc.split_last (Types.unprod ty) 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 @@ -564,8 +587,8 @@ and translate_iterator map call_context it name_list let v = translate_var_dec v in let b = mk_block ~locals:v action in let bi = mk_block si in - [Afor (xd, mk_exp_const_int 0, n, bi)], j, - [Aassgn (acc_out, acc_in); Afor (xd, mk_exp_const_int 0, n, b)] + [mk_loop bi xdl n_list], j, + [Aassgn (acc_out, acc_in); mk_loop b xdl n_list] | Minils.Ifold -> let (c_list, acc_in) = split_last c_list in @@ -578,21 +601,21 @@ and translate_iterator map call_context it name_list let v = translate_var_dec v in let b = mk_block ~locals:v action in let bi = mk_block si in - [Afor (xd, mk_exp_const_int 0, n, bi)], j, - [ Aassgn (acc_out, acc_in); Afor (xd, mk_exp_const_int 0, n, b) ] + [mk_loop bi xdl n_list], j, + [ Aassgn (acc_out, acc_in); mk_loop b xdl n_list] | 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 - (p_list @ c_list @ [ mk_evar_int x; exp_of_pattern acc_out ]) ty + (p_list @ c_list @ (List.map mk_evar_int xl) @ [ 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_exp_const_int 0, n, bi)], j, - [ Aassgn (acc_out, acc_in); Afor (xd, mk_exp_const_int 0, n, b) ] + [mk_loop bi xdl n_list], j, + [ Aassgn (acc_out, acc_in); mk_loop b xdl n_list] let remove m d_list = List.filter (fun { Minils.v_ident = n } -> not (List.mem_assoc n m)) d_list diff --git a/compiler/main/mls2seq.ml b/compiler/main/mls2seq.ml index c0f3d83..396e260 100644 --- a/compiler/main/mls2seq.ml +++ b/compiler/main/mls2seq.ml @@ -41,7 +41,7 @@ let write_obc_file p = let no_conf () = () let targets = [ "c",(Obc_no_params Cmain.program, no_conf); - "java", (Obc Java_main.program, no_conf); + (* "java", (Obc Java_main.program, no_conf); *) "obc", (Obc write_obc_file, no_conf); "obc_np", (Obc_no_params write_obc_file, no_conf); "epo", (Minils write_object_file, no_conf) ] diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index b8323fd..9707c13 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -70,7 +70,7 @@ and edesc = (** merge ident (Constructor -> extvalue)+ *) | Estruct of (field_name * extvalue) list (** { field=extvalue; ... } *) - | Eiterator of iterator_type * app * static_exp + | Eiterator of iterator_type * app * static_exp list * extvalue list * extvalue list * var_ident option (** map f <> <(extvalue)> (extvalue) reset ident *) diff --git a/compiler/minils/mls_mapfold.ml b/compiler/minils/mls_mapfold.ml index ff66125..fb10147 100644 --- a/compiler/minils/mls_mapfold.ml +++ b/compiler/minils/mls_mapfold.ml @@ -94,12 +94,12 @@ and edesc funs acc ed = match ed with (n,w), acc in let n_w_list, acc = mapfold aux acc n_w_list in Estruct n_w_list, acc - | Eiterator (i, app, param, pargs, args, reset) -> + | Eiterator (i, app, params, 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 params, acc = mapfold (static_exp_it funs.global_funs) acc params in let pargs, acc = mapfold (extvalue_it funs) acc pargs in let args, acc = mapfold (extvalue_it funs) acc args in - Eiterator (i, app, param, pargs, args, reset), acc + Eiterator (i, app, params, 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 611dcb0..fda4935 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -106,11 +106,11 @@ and print_exp_desc ff = function fprintf ff "@[<2>(%a@ when %a(%a))@]" print_exp e print_qualname c print_ident x | Estruct f_w_list -> print_record (print_couple print_qualname print_extvalue """ = """) ff f_w_list - | Eiterator (it, f, param, pargs, args, reset) -> + | Eiterator (it, f, params, pargs, args, reset) -> fprintf ff "@[<2>(%s (%a)<<%a>>)@,(%a)%a@]%a" (iterator_to_string it) print_app (f, []) - print_static_exp param + (print_list_r print_static_exp """, """) params print_w_tuple pargs print_w_tuple args print_every reset diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 17b928e..be5bac5 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -405,8 +405,12 @@ let step_fun_call out_env var_env sig_info objn out args = (match objn with | Oobj o -> Cfield (Cderef (Cvar "self"), local_qn (name o)) | Oarray (o, l) -> - let l = cexpr_of_pattern out_env var_env l in - Carray (Cfield (Cderef (Cvar "self"), local_qn (name o)), l) + let f = Cfield (Cderef (Cvar "self"), local_qn (name o)) in + let rec mk_idx pl = match pl with + | [] -> f + | p::pl -> Carray (mk_idx pl, Clhs (clhs_of_lhs var_env p)) + in + mk_idx l ) in args@[Caddrof out; Caddrof mem] ) else @@ -561,11 +565,15 @@ let rec cstm_of_act out_env var_env obj_env act = [Csexpr (Cfun_call (classn ^ "_reset", [Caddrof (Cfield (Cderef (Cvar "self"), local_qn (name on)))]))] | Some size -> - let x = gen_symbol () in let field = Cfield (Cderef (Cvar "self"), local_qn (name on)) in - let elt = [Caddrof( Carray(field, Cvar x) )] in - [Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp size, - [Csexpr (Cfun_call (classn ^ "_reset", elt ))] )] + let rec mk_loop nl elt = match nl with + | [] -> [Csexpr (Cfun_call (classn ^ "_reset", [Caddrof elt] ))] + | n::nl -> + let x = gen_symbol () in + let elt = Carray(elt, Clhs (Cvar x)) in + [Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp n, mk_loop nl elt)] + in + mk_loop size field ) (** Step functions applications can return multiple values, so we use a @@ -658,7 +666,12 @@ let mem_decl_of_class_def cd = 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) + | Some nl -> + let rec mk_idx nl = match nl with + | [] -> ty + | n::nl -> Cty_arr (int_of_static_exp n, mk_idx nl) + in + mk_idx nl | None -> ty in (name od.o_ident, ty)::l else diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index 2fcf665..63be5ee 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -67,7 +67,7 @@ and exp_desc = type obj_ref = | Oobj of obj_ident - | Oarray of obj_ident * pattern + | Oarray of obj_ident * pattern list type method_name = | Mreset @@ -96,7 +96,7 @@ type obj_dec = o_class : class_name; o_params : static_exp list; (** size of the array if the declaration is an array of obj *) - o_size : static_exp option; + o_size : static_exp list option; o_loc : location } type method_def = diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml index b11eab1..6e53061 100644 --- a/compiler/obc/obc_mapfold.ml +++ b/compiler/obc/obc_mapfold.ml @@ -151,7 +151,7 @@ and var_decs funs acc vds = mapfold (var_dec_it funs) acc vds and obj_dec_it funs acc od = funs.obj_dec funs acc od and obj_dec funs acc od = let o_size, acc = optional_wacc - (static_exp_it funs.global_funs) acc od.o_size in + (mapfold (static_exp_it funs.global_funs)) acc od.o_size in { od with o_size = o_size }, acc and obj_decs_it funs acc ods = funs.obj_decs funs acc ods diff --git a/compiler/obc/obc_printer.ml b/compiler/obc/obc_printer.ml index 9f6c89a..2db23ba 100644 --- a/compiler/obc/obc_printer.ml +++ b/compiler/obc/obc_printer.ml @@ -18,7 +18,7 @@ let print_obj ff o = 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 - | Some se -> fprintf ff "[%a]" print_static_exp se + | Some se -> fprintf ff "%a" (print_list_r print_static_exp "[" "][" "]") se | None -> ()); fprintf ff "@]" @@ -78,9 +78,9 @@ let print_asgn ff pref x e = let print_obj_call ff = function | Oobj o -> print_ident ff o | Oarray (o, i) -> - fprintf ff "%a[%a]" + fprintf ff "%a%a" print_ident o - print_lhs i + (print_list_r print_lhs "[" "][" "]") i let print_method_name ff = function | Mstep -> fprintf ff "step" diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index a8e7e55..b85d386 100644 --- a/compiler/utilities/misc.ml +++ b/compiler/utilities/misc.ml @@ -49,6 +49,19 @@ let rec map_butlast f l = | [a] -> [a] | a::l -> (f a)::(map_butlast f l) +let map_butnlast n f l = + let rec aux l = match l with + | [] -> [], 0 + | a::l -> + let (res, k) = aux l in + if k < n then + a::res, (k + 1) + else + (f a)::res, (k+1) + in + let res, _ = aux l in + res + let rec last_element l = match l with | [] -> assert false @@ -64,6 +77,23 @@ let rec split_last = function let l, a = split_last l in v::l, a +(** [split_nlasts l] returns l without its last n elements and + the last n elements of l. *) +let rec split_nlast n l = + let rec aux l = match l with + | [] -> [], [], 0 + | a::l -> + let (l1, l2, k) = aux l in + if k < n then + l1, a::l2, (k + 1) + else + a::l1, l2, (k+1) + in + let l1, l2, k = aux l in + if (k < n) then + assert false + else l1, l2 + 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. *) diff --git a/compiler/utilities/misc.mli b/compiler/utilities/misc.mli index dfcb41a..7fdfc64 100644 --- a/compiler/utilities/misc.mli +++ b/compiler/utilities/misc.mli @@ -30,6 +30,10 @@ val unique : 'a list -> 'a list l except the last element. *) val map_butlast : ('a -> 'a) -> 'a list -> 'a list +(** [map_butnlast f l] applies f to all the elements of + l except the n last element. *) +val map_butnlast : int -> ('a -> 'a) -> 'a list -> 'a list + (** [last_element l] returns the last element of the list l.*) val last_element : 'a list -> 'a @@ -37,6 +41,10 @@ val last_element : 'a list -> 'a and the last element of the list .*) val split_last : 'a list -> ('a list * 'a) +(** [split_nlast l] returns the list l without its n last elements + and the last element of the list .*) +val split_nlast : int -> 'a list -> ('a list * 'a list) + 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. *) From c5fbcbe7654ce7bde518cc4d36786368f30c9824 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 27 Jun 2011 19:20:47 +0200 Subject: [PATCH 4/9] removing white spaces --- compiler/heptagon/analysis/typing.ml | 12 ++++++------ compiler/main/mls2obc.ml | 8 ++++---- compiler/obc/c/cgen.ml | 6 +++--- compiler/utilities/misc.ml | 8 ++++---- 4 files changed, 17 insertions(+), 17 deletions(-) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 2b67f70..ce4fb95 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -796,7 +796,7 @@ and typing_iterator const_env h in let mk_array_type ty_list = List.map (array_of_idx_list n_list) ty_list in let n_size = List.length n_list in - let mk_array_type_butnlast ty_list = + let mk_array_type_butnlast ty_list = map_butnlast n_size (array_of_idx_list n_list) ty_list in match it with | Imap -> @@ -811,10 +811,10 @@ and typing_iterator const_env h let args_ty_list = mk_array_type args_ty_list in let result_ty_list = mk_array_type result_ty_list in (* Last but one arg of the function should be integer *) - List.iter + List.iter (fun idx_ty -> - ( try unify cenv idx_ty (Tid Initial.pint) - with TypingError _ -> raise (TypingError (Emapi_bad_args idx_ty)))) + ( try unify cenv idx_ty (Tid Initial.pint) + with TypingError _ -> raise (TypingError (Emapi_bad_args idx_ty)))) idx_ty_list; let typed_e_list = typing_args const_env h args_ty_list e_list in @@ -836,8 +836,8 @@ and typing_iterator const_env h (* Last but one arg of the function should be integer *) List.iter (fun idx_ty -> - ( try unify cenv idx_ty (Tid Initial.pint) - with TypingError _ -> raise (TypingError (Emapi_bad_args idx_ty)))) + ( try unify cenv idx_ty (Tid Initial.pint) + with TypingError _ -> raise (TypingError (Emapi_bad_args idx_ty)))) idx_ty_list; let args_ty_list = mk_array_type_butnlast (args_ty_list@[acc_ty]) in let typed_e_list = diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 9eded13..a56da08 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -91,7 +91,7 @@ let array_elt_of_exp idx e = mk_ext_value_exp ty (Warray(ext_value_of_exp e, idx)) | _ -> internal_error "mls2obc" -let rec array_elt_of_exp_list idx_list e = +let rec array_elt_of_exp_list idx_list e = match e.e_desc, Modules.unalias_type e.e_ty with | Econst ({ se_desc = Sarray_power (c, _) }), Tarray (ty,_) -> mk_exp ty (Econst c) @@ -440,7 +440,7 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } let p_list = List.map (translate_extvalue_to_exp map) pe_list in let c_list = List.map (translate_extvalue_to_exp map) e_list in let xl, xdl = List.split (List.map (fun _ -> fresh_it ()) n_list) in - let call_context = + let call_context = Some { oa_index = List.map (fun x -> mk_pattern_int (Lvar x)) xl; oa_size = n_list} in let n_list = List.map mk_exp_static_int n_list in @@ -536,7 +536,7 @@ and translate_iterator map call_context it name_list List.map2 (fun l ty -> aux l ty xl) name_list ty_list in let array_of_input c_list = - List.map (array_elt_of_exp_list (List.map mk_evar_int xl)) c_list + List.map (array_elt_of_exp_list (List.map mk_evar_int xl)) c_list in let mk_loop b xdl nl = let rec mk_loop b xdl nl = match xdl, nl with @@ -544,7 +544,7 @@ and translate_iterator map call_context it name_list | xd::xdl, n::nl -> mk_loop (mk_block [Afor (xd, mk_exp_const_int 0, n, b)]) xdl nl | _, _ -> assert false in - mk_loop b (List.rev xdl) nl + mk_loop b (List.rev xdl) nl in match it with | Minils.Imap -> diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index be5bac5..6094dc6 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -406,7 +406,7 @@ let step_fun_call out_env var_env sig_info objn out args = | Oobj o -> Cfield (Cderef (Cvar "self"), local_qn (name o)) | Oarray (o, l) -> let f = Cfield (Cderef (Cvar "self"), local_qn (name o)) in - let rec mk_idx pl = match pl with + let rec mk_idx pl = match pl with | [] -> f | p::pl -> Carray (mk_idx pl, Clhs (clhs_of_lhs var_env p)) in @@ -568,7 +568,7 @@ let rec cstm_of_act out_env var_env obj_env act = let field = Cfield (Cderef (Cvar "self"), local_qn (name on)) in let rec mk_loop nl elt = match nl with | [] -> [Csexpr (Cfun_call (classn ^ "_reset", [Caddrof elt] ))] - | n::nl -> + | n::nl -> let x = gen_symbol () in let elt = Carray(elt, Clhs (Cvar x)) in [Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp n, mk_loop nl elt)] @@ -667,7 +667,7 @@ let mem_decl_of_class_def cd = let ty = Cty_id (qn_append od.o_class "_mem") in let ty = match od.o_size with | Some nl -> - let rec mk_idx nl = match nl with + let rec mk_idx nl = match nl with | [] -> ty | n::nl -> Cty_arr (int_of_static_exp n, mk_idx nl) in diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index b85d386..8b5c977 100644 --- a/compiler/utilities/misc.ml +++ b/compiler/utilities/misc.ml @@ -52,9 +52,9 @@ let rec map_butlast f l = let map_butnlast n f l = let rec aux l = match l with | [] -> [], 0 - | a::l -> + | a::l -> let (res, k) = aux l in - if k < n then + if k < n then a::res, (k + 1) else (f a)::res, (k+1) @@ -82,9 +82,9 @@ let rec split_last = function let rec split_nlast n l = let rec aux l = match l with | [] -> [], [], 0 - | a::l -> + | a::l -> let (l1, l2, k) = aux l in - if k < n then + if k < n then l1, a::l2, (k + 1) else a::l1, l2, (k+1) From f2ca353cacda70ec544dc7f7008b7a3558f5ff35 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 27 Jun 2011 16:08:34 +0200 Subject: [PATCH 5/9] Pour que ca marche sur clocked_inputs (cela vient de memalloc) --- compiler/heptagon/analysis/typing.ml | 16 ++++++++-------- compiler/heptagon/parsing/hept_parser.mly | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index ce4fb95..5b7ed2e 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -568,23 +568,23 @@ let rec typing cenv h e = let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in let result_ty_list = List.map (subst_type_vars m) result_ty_list in - let typed_n_list = List.map (expect_static_exp const_env (Tid Initial.pint)) n_list in + let typed_n_list = List.map (expect_static_exp cenv (Tid Initial.pint)) n_list 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 cenv h p_ty_list pe_list in (*typing of other arguments*) - let ty, typed_e_list = typing_iterator const_env h it n_list + let ty, typed_e_list = typing_iterator cenv h it n_list expected_ty_list result_ty_list e_list in let typed_params = typing_node_params cenv ty_desc.node_params params in (* add size constraints *) let constrs = List.map (simplify m) ty_desc.node_param_constraints in - List.iter (fun n -> add_size_constraint (Clequal (mk_static_int 1, n))) typed_n_list; + List.iter (fun n -> add_constraint_leq cenv (mk_static_int 1) n) typed_n_list; List.iter (add_constraint cenv) constrs; (* return the type *) Eiterator(it, { app with a_op = op; a_params = typed_params } - , typed_n, typed_pe_list, typed_e_list, reset), ty + , typed_n_list, typed_pe_list, typed_e_list, reset), ty | Eiterator _ -> assert false | Ewhen (e, c, x) -> @@ -788,7 +788,7 @@ and typing_app cenv h app e_list = -and typing_iterator const_env h +and typing_iterator cenv h it n_list args_ty_list result_ty_list e_list = let rec array_of_idx_list l ty = match l with | [] -> ty @@ -802,7 +802,7 @@ and typing_iterator const_env h | Imap -> let args_ty_list = mk_array_type args_ty_list in let result_ty_list = mk_array_type result_ty_list in - let typed_e_list = typing_args const_env h + let typed_e_list = typing_args cenv h args_ty_list e_list in prod result_ty_list, typed_e_list @@ -816,7 +816,7 @@ and typing_iterator const_env h ( try unify cenv idx_ty (Tid Initial.pint) with TypingError _ -> raise (TypingError (Emapi_bad_args idx_ty)))) idx_ty_list; - let typed_e_list = typing_args const_env h + let typed_e_list = typing_args cenv h args_ty_list e_list in prod result_ty_list, typed_e_list @@ -851,7 +851,7 @@ and typing_iterator const_env h | Imapfold -> let args_ty_list = mk_array_type_butnlast args_ty_list in let result_ty_list = mk_array_type_butnlast result_ty_list in - let typed_e_list = typing_args const_env h + let typed_e_list = typing_args cenv h args_ty_list e_list in (*check accumulator type matches in input and output*) ( try unify cenv (last_element args_ty_list) (last_element result_ty_list) diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index 5ece9af..23d8c12 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -518,7 +518,7 @@ _exp: { mk_call Econcat [$1; $3] } /*Iterators*/ | it=iterator DOUBLE_LESS n=separated_nonempty_list(COMMA, simple_exp) DOUBLE_GREATER q=qualname - pargs=delim_slist(COMMA, LPAREN_LESS, GREATER_RPAREN, exp) + pargs=delim_slist(COMMA, LESS_LPAREN, RPAREN_GREATER, exp) LPAREN args=exps RPAREN { mk_iterator_call it q [] n pargs args } | it=iterator DOUBLE_LESS n=separated_nonempty_list(COMMA, simple_exp) DOUBLE_GREATER From 5837f3906fc53149d14097ccbd62817f269f1946 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Mon, 27 Jun 2011 16:08:56 +0200 Subject: [PATCH 6/9] Multidimensional iterators in java. --- compiler/heptagon/obc_mapfold.ml | 221 -------------------- compiler/heptagon/transformations/switch.ml | 4 +- compiler/main/mls2obc.ml | 34 ++- compiler/main/mls2seq.ml | 2 +- compiler/minils/analysis/clocking.ml | 2 +- compiler/minils/analysis/level_clock.ml | 2 +- compiler/obc/c/cgen.ml | 4 +- compiler/obc/java/java.ml | 6 +- compiler/obc/java/java_main.ml | 4 +- compiler/obc/java/java_printer.ml | 9 +- compiler/obc/java/obc2java.ml | 91 ++++++-- test/good/array_iterators2.ept | 11 + 12 files changed, 127 insertions(+), 263 deletions(-) delete mode 100644 compiler/heptagon/obc_mapfold.ml create mode 100644 test/good/array_iterators2.ept diff --git a/compiler/heptagon/obc_mapfold.ml b/compiler/heptagon/obc_mapfold.ml deleted file mode 100644 index 4ee29b6..0000000 --- a/compiler/heptagon/obc_mapfold.ml +++ /dev/null @@ -1,221 +0,0 @@ - (**************************************************************************) -(* *) -(* Heptagon *) -(* *) -(* Author : Marc Pouzet *) -(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) -(* *) -(**************************************************************************) -(* Generic mapred over Obc Ast *) -open Misc -open Errors -open Global_mapfold -open Obc - -type 'a obc_it_funs = { - exp: 'a obc_it_funs -> 'a -> Obc.exp -> Obc.exp * 'a; - edesc: 'a obc_it_funs -> 'a -> Obc.exp_desc -> Obc.exp_desc * 'a; - lhs: 'a obc_it_funs -> 'a -> Obc.pattern -> Obc.pattern * 'a; - lhsdesc: 'a obc_it_funs -> 'a -> Obc.pat_desc -> Obc.pat_desc * 'a; - act: 'a obc_it_funs -> 'a -> Obc.act -> Obc.act * 'a; - block: 'a obc_it_funs -> 'a -> Obc.block -> Obc.block * 'a; - var_dec: 'a obc_it_funs -> 'a -> Obc.var_dec -> Obc.var_dec * 'a; - var_decs: 'a obc_it_funs -> 'a -> Obc.var_dec list -> Obc.var_dec list * 'a; - obj_dec: 'a obc_it_funs -> 'a -> Obc.obj_dec -> Obc.obj_dec * 'a; - obj_decs: 'a obc_it_funs -> 'a -> Obc.obj_dec list -> Obc.obj_dec list * 'a; - method_def: 'a obc_it_funs -> 'a -> Obc.method_def -> Obc.method_def * 'a; - class_def: 'a obc_it_funs -> 'a -> Obc.class_def -> Obc.class_def * 'a; - const_dec: 'a obc_it_funs -> 'a -> Obc.const_dec -> Obc.const_dec * 'a; - type_dec: 'a obc_it_funs -> 'a -> Obc.type_dec -> Obc.type_dec * 'a; - tdesc: 'a obc_it_funs -> 'a -> Obc.tdesc -> Obc.tdesc * 'a; - program: 'a obc_it_funs -> 'a -> Obc.program -> Obc.program * 'a; - program_desc: 'a obc_it_funs -> 'a -> Obc.program_desc -> Obc.program_desc * 'a; - global_funs: 'a Global_mapfold.global_it_funs } - - -let rec exp_it funs acc e = funs.exp funs acc e -and exp funs acc e = - let ed, acc = edesc_it funs acc e.e_desc in - { e with e_desc = ed }, acc - - -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 - | Epattern l -> - let l, acc = lhs_it funs acc l in - Epattern l, acc - | Econst se -> - let se, acc = static_exp_it funs.global_funs acc se in - Econst se, acc - | Eop (op, args) -> - let args, acc = mapfold (exp_it funs) acc args in - Eop (op, args), acc - | Estruct(tyn, f_e_list) -> - let aux acc (f,e) = - let e, acc = exp_it funs acc e in - (f,e), acc in - let f_e_list, acc = mapfold aux acc f_e_list in - Estruct(tyn, f_e_list), acc - | Earray args -> - let args, acc = mapfold (exp_it funs) acc args in - Earray args, acc - - -and lhs_it funs acc l = funs.lhs funs acc l -and lhs funs acc l = - let ld, acc = lhsdesc_it funs acc l.pat_desc in - { l with pat_desc = ld }, acc - - -and lhsdesc_it funs acc ld = - try funs.lhsdesc funs acc ld - with Fallback -> lhsdesc funs acc ld -and lhsdesc funs acc ld = match ld with - | Lvar x -> Lvar x, acc - | Lmem x -> Lmem x, acc - | Lfield(lhs, f) -> - let lhs, acc = lhs_it funs acc lhs in - Lfield(lhs, f), acc - | Larray(lhs, e) -> - let lhs, acc = lhs_it funs acc lhs in - let e, acc = exp_it funs acc e in - Larray(lhs, e), acc - - -and act_it funs acc a = - try funs.act funs acc a - with Fallback -> act funs acc a -and act funs acc a = match a with - | Aassgn(lhs, e) -> - let lhs, acc = lhs_it funs acc lhs in - let e, acc = exp_it funs acc e in - Aassgn(lhs, e), acc - | Aop(op_name, args) -> - let args, acc = mapfold (exp_it funs) acc args in - Aop(op_name, args), acc - | Acall(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 - Acall(lhs_list, obj, n, args), acc - | Acase(e, c_b_list) -> - let aux acc (c,b) = - let b, acc = block_it funs acc b in - (c,b), acc in - let e, acc = exp_it funs acc e in - let c_b_list, acc = mapfold aux acc c_b_list in - Acase(e, c_b_list), acc - | Afor(x, idx1, idx2, b) -> - let idx1, acc = exp_it funs acc idx1 in - let idx2, acc = exp_it 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 = - let b_locals, acc = var_decs_it funs acc b.b_locals in - let b_body, acc = mapfold (act_it funs) acc b.b_body in - { b with b_locals = b_locals; b_body = b_body }, acc - -and var_dec_it funs acc vd = funs.var_dec funs acc vd -and var_dec funs acc vd = - let v_type, acc = ty_it funs.global_funs acc vd.v_type in - { vd with v_type = v_type }, acc - -and var_decs_it funs acc vds = funs.var_decs funs acc vds -and var_decs funs acc vds = mapfold (var_dec_it funs) acc vds - - -and obj_dec_it funs acc od = funs.obj_dec funs acc od -and obj_dec funs acc od = - let o_size, acc = optional_wacc - (mapfold (static_exp_it funs.global_funs)) acc od.o_size in - { od with o_size = o_size }, acc - -and obj_decs_it funs acc ods = funs.obj_decs funs acc ods -and obj_decs funs acc ods = mapfold (obj_dec_it funs) acc ods - - -and method_def_it funs acc md = funs.method_def funs acc md -and method_def funs acc md = - let m_inputs, acc = var_decs_it funs acc md.m_inputs in - let m_outputs, acc = var_decs_it funs acc md.m_outputs in - let m_body, acc = block_it funs acc md.m_body in - { md with - m_inputs = m_inputs; m_outputs = m_outputs; m_body = m_body } - , acc - - -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 - let cd_params, acc = mapfold (param_it funs.global_funs) acc cd.cd_params in - let cd_methods, acc = mapfold (method_def_it funs) acc cd.cd_methods in - { cd with - cd_mems = cd_mems; cd_objs = cd_objs; - cd_params = cd_params; cd_methods = cd_methods } - , acc - - -and const_dec_it funs acc c = funs.const_dec funs acc c -and const_dec funs acc c = - let ty, acc = ty_it funs.global_funs acc c.c_type in - let se, acc = static_exp_it funs.global_funs acc c.c_value in - { c with c_type = ty; c_value = se }, acc - - -and type_dec_it funs acc t = funs.type_dec funs acc t -and type_dec funs acc t = - let tdesc, acc = tdesc_it funs acc t.t_desc in - { t with t_desc = tdesc }, acc - - -and tdesc_it funs acc td = - try funs.tdesc funs acc td - with Fallback -> tdesc funs acc td -and tdesc funs acc td = match td with - | Type_struct s -> - let s, acc = structure_it funs.global_funs acc s in - Type_struct s, acc - | _ -> td, acc - - -and program_it funs acc p = funs.program funs acc p -and program funs acc p = - let p_desc, acc = mapfold (program_desc_it funs) acc p.p_desc in - { p with p_desc = p_desc }, acc - -and program_desc_it funs acc pd = - try funs.program_desc funs acc pd - with Fallback -> program_desc funs acc pd -and program_desc funs acc pd = match pd with - | Pconst cd -> let cd, acc = const_dec_it funs acc cd in Pconst cd, acc - | Ptype td -> let td, acc = type_dec_it funs acc td in Ptype td, acc - | Pclass n -> let n, acc = class_def_it funs acc n in Pclass n, acc - -let defaults = { - lhs = lhs; - lhsdesc = lhsdesc; - exp = exp; - edesc = edesc; - act = act; - block = block; - var_dec = var_dec; - var_decs = var_decs; - obj_dec = obj_dec; - obj_decs = obj_decs; - method_def = method_def; - class_def = class_def; - const_dec = const_dec; - type_dec = type_dec; - tdesc = tdesc; - program = program; - program_desc = program_desc; - global_funs = Global_mapfold.defaults } diff --git a/compiler/heptagon/transformations/switch.ml b/compiler/heptagon/transformations/switch.ml index bcb5f4c..7597a02 100644 --- a/compiler/heptagon/transformations/switch.ml +++ b/compiler/heptagon/transformations/switch.ml @@ -32,8 +32,8 @@ with one defined var y ( defnames = {y} ) and used var x } *) -(* base_ck is used to have correct behavior for side effects : - it keep track of the fact that a cal +(* e_level_ck is used to have correct behavior for side effects : + it keep track of the fact that a call without interaction with the dataflow was in a case of the switch *) diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index a56da08..2cf3d78 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -67,6 +67,12 @@ let rec pattern_of_idx_list p l = in aux p l +let rec exp_of_idx_list e l = match e.w_ty, l with + | _, [] -> e + | Tarray (ty',_), idx :: l -> + exp_of_idx_list (mk_ext_value ty' (Warray (e, idx))) l + | _ -> internal_error "mls2obc" + let rec extvalue_of_idx_list w l = match w.w_ty, l with | _, [] -> w | Tarray (ty',_), idx :: l -> @@ -86,18 +92,24 @@ let rec ext_value_of_trunc_idx_list p l = let array_elt_of_exp idx e = match e.e_desc, Modules.unalias_type e.e_ty with - | Eextvalue { w_desc = Wconst { se_desc = Sarray_power (c, _) }; }, Tarray (ty,_) -> mk_ext_value_exp ty (Wconst c) - | _, Tarray (ty,_) -> - mk_ext_value_exp ty (Warray(ext_value_of_exp e, idx)) - | _ -> internal_error "mls2obc" + | Eextvalue { w_desc = Wconst { se_desc = Sarray_power (c, _) }; }, Tarray (ty,_) -> + mk_ext_value_exp ty (Wconst c) (* TODO BUG : (4^2^2^2)[0][1] is not 4, but 4^2 *) + | _, Tarray (ty,_) -> + mk_ext_value_exp ty (Warray(ext_value_of_exp e, idx)) + | _ -> internal_error "mls2obc" let rec array_elt_of_exp_list idx_list e = 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_exp ty (Epattern (pattern_of_idx_list (pattern_of_exp e) idx_list)) - | _ -> internal_error "mls2obc" 2 + | Eextvalue { w_desc = Wconst { se_desc = Sarray_power (c, _) } }, Tarray (ty,_) -> + mk_ext_value_exp ty (Wconst c) (* TODO BUG : (4^2^2^2)[0][1] is not 4, but 4^2 *) + | _ , t -> + let rec ty id_l t = match id_l, t with + | [] , t -> t + | _::id_l , Tarray (t,_) -> ty id_l t + | _, _ -> internal_error "mls2obc" + in + mk_exp (ty idx_list t) (Eextvalue (extvalue_of_idx_list (ext_value_of_exp e) idx_list)) + (** Creates the expression that checks that the indices in idx_list are in the bounds. If idx_list=[e1;..;ep] @@ -435,7 +447,7 @@ 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, pe_list, e_list, reset) -> + | pat, Minils.Eiterator (it, app, n_list, pe_list, e_list, reset) -> let name_list = translate_pat map e.Minils.e_ty pat in let p_list = List.map (translate_extvalue_to_exp map) pe_list in let c_list = List.map (translate_extvalue_to_exp map) e_list in @@ -609,7 +621,7 @@ and translate_iterator map call_context it name_list 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 - (p_list @ c_list @ (List.map mk_evar_int xl) @ [ mk_exp acc_out.pat_ty (Epattern acc_out) ]) ty + (p_list @ c_list @ (List.map mk_evar_int xl) @ [ exp_of_pattern acc_out ]) ty in let v = translate_var_dec v in let b = mk_block ~locals:v action in diff --git a/compiler/main/mls2seq.ml b/compiler/main/mls2seq.ml index 396e260..510705a 100644 --- a/compiler/main/mls2seq.ml +++ b/compiler/main/mls2seq.ml @@ -41,7 +41,7 @@ let write_obc_file p = let no_conf () = () let targets = [ "c",(Obc_no_params Cmain.program, no_conf); - (* "java", (Obc Java_main.program, no_conf); *) + "java", (Obc Java_main.program, no_conf); "obc", (Obc write_obc_file, no_conf); "obc_np", (Obc_no_params write_obc_file, no_conf); "epo", (Minils write_object_file, no_conf) ] diff --git a/compiler/minils/analysis/clocking.ml b/compiler/minils/analysis/clocking.ml index 78a45b9..2453002 100644 --- a/compiler/minils/analysis/clocking.ml +++ b/compiler/minils/analysis/clocking.ml @@ -134,7 +134,7 @@ let typing_eq h { eq_lhs = pat; eq_rhs = e; eq_loc = loc } = | Ewhen (e,c,n) -> let ck_n = ck_of_name h n in let base = expect (skeleton ck_n e.e_ty) e in - skeleton (Con (ck_n, c, n)) e.e_ty, base + skeleton (Con (ck_n, c, n)) e.e_ty, Con (ck_n, c, n) | Emerge (x, c_e_list) -> let ck = ck_of_name h x in List.iter (fun (c,e) -> expect_extvalue h (Con (ck,c,x)) e) c_e_list; diff --git a/compiler/minils/analysis/level_clock.ml b/compiler/minils/analysis/level_clock.ml index b7bfe75..605efca 100644 --- a/compiler/minils/analysis/level_clock.ml +++ b/compiler/minils/analysis/level_clock.ml @@ -11,7 +11,7 @@ open Clocks open Minils (* Any clock variable left after clocking is free and should be set to level_ck. - Since inputs and outputs are grounded to Cbase, this append when + Since inputs and outputs are grounded to Cbase, this happens when no data dependence exists between an expression and the inputs/outputs.*) (* We are confident that it is sufficient to unify level_ck with base_ck diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 6094dc6..3ef147c 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -408,7 +408,7 @@ let step_fun_call out_env var_env sig_info objn out args = let f = Cfield (Cderef (Cvar "self"), local_qn (name o)) in let rec mk_idx pl = match pl with | [] -> f - | p::pl -> Carray (mk_idx pl, Clhs (clhs_of_lhs var_env p)) + | p::pl -> Carray (mk_idx pl, cexpr_of_pattern out_env var_env p) in mk_idx l ) in @@ -570,7 +570,7 @@ let rec cstm_of_act out_env var_env obj_env act = | [] -> [Csexpr (Cfun_call (classn ^ "_reset", [Caddrof elt] ))] | n::nl -> let x = gen_symbol () in - let elt = Carray(elt, Clhs (Cvar x)) in + let elt = Carray(elt, Cvar x) in [Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp n, mk_loop nl elt)] in mk_loop size field diff --git a/compiler/obc/java/java.ml b/compiler/obc/java/java.ml index 27ee1ff..f08f177 100644 --- a/compiler/obc/java/java.ml +++ b/compiler/obc/java/java.ml @@ -22,7 +22,7 @@ type ty = Tclass of class_name | Tbool | Tint | Tfloat - | Tarray of ty * exp + | Tarray of ty * exp list | Tunit and classe = { c_protection : protection; @@ -91,12 +91,12 @@ and exp = Ethis | Efield of exp * field_name | Eclass of class_name | Evar of var_ident - | Earray_elem of exp * exp + | Earray_elem of exp * exp list and pattern = Pfield of pattern * field_name | Pclass of class_name | Pvar of var_ident - | Parray_elem of pattern * exp + | Parray_elem of pattern * exp list | Pthis of field_ident type program = classe list diff --git a/compiler/obc/java/java_main.ml b/compiler/obc/java/java_main.ml index 7c836db..2263e52 100644 --- a/compiler/obc/java/java_main.ml +++ b/compiler/obc/java/java_main.ml @@ -31,7 +31,7 @@ let program p = let main_methode = let vd_step, pat_step, exp_step = mk_var Tint "step" in let vd_args, _, exp_args = - mk_var (Tarray (Tclass (Names.pervasives_qn "String"), (Sint 0))) "args" in + mk_var (Tarray (Tclass (Names.pervasives_qn "String"), [Sint 0])) "args" in let body = let vd_main, e_main, q_main, ty_main = let q_main = !Compiler_options.simulation_node |> Modules.qualify_value in (*qual*) @@ -43,7 +43,7 @@ let program p = in let acts = let integer = Eclass(Names.pervasives_qn "Integer") in - let args1 = Earray_elem(exp_args, Sint 1) in + let args1 = Earray_elem(exp_args, [Sint 1]) in let out = Eclass(Names.qualname_of_string "java.lang.System.out") in let jarrays = Eclass(Names.qualname_of_string "java.util.Arrays") in let jint = Eclass(Names.qualname_of_string "Integer") in diff --git a/compiler/obc/java/java_printer.ml b/compiler/obc/java/java_printer.ml index ee4466d..7912fbf 100644 --- a/compiler/obc/java/java_printer.ml +++ b/compiler/obc/java/java_printer.ml @@ -44,7 +44,10 @@ let rec _ty news ff t = match t with if news then fprintf ff "%a" class_name n else fprintf ff "%a<@[%a@]>" class_name n (print_list_r ty """,""") ty_l - | Tarray (t,s) -> if news then fprintf ff "%a[%a]" new_ty t exp s else fprintf ff "%a[]" ty t + | Tarray (t,s_l) -> + if news + then fprintf ff "%a@[%a@]" new_ty t (print_list exp "[""][""]") s_l + else fprintf ff "%a@[%a@]" ty t (print_list (fun ff e -> ()) "[""][""]") s_l | Tunit -> pp_print_string ff "void" and new_ty ff t = _ty true ff t @@ -91,7 +94,7 @@ and exp ff = function | Efield (p,f) -> fprintf ff "%a.%a" exp p field_name f | Evar v -> var_ident ff v | Eclass c -> class_name ff c - | Earray_elem (p,e) -> fprintf ff "%a[%a]" exp p exp e + | Earray_elem (p,e_l) -> fprintf ff "%a@[%a@]" exp p (print_list exp "[""][""]") e_l and op ff (f, e_l) = let javaop = function @@ -134,7 +137,7 @@ 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 + | Parray_elem (p,e_l) -> fprintf ff "%a%a" pattern p (print_list exp "[""][""]") e_l | Pthis f -> fprintf ff "this.%a" field_ident f let rec block ff b = diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index 83570ca..117a740 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -42,6 +42,28 @@ let fresh_for size body = let id = mk_var_dec i Tint in Afor (id, Sint 0, size, mk_block (body i)) +(** fresh nested Afor from 0 to [size] + with [body] a function from [var_ident] list (the iterator list) to [act] list : + s_l = [10; 20] + then + for i in 20 + for j in 10 + body [i][j] + *) +let fresh_nfor s_l body = + let rec aux s_l i_l = match s_l with + | [s] -> + let i = Idents.gen_var "obc2java" "i" in + let id = (mk_var_dec i Tint) in + Afor (id, Sint 0, s, mk_block (body (List.rev (i::i_l)))) + | s::s_l -> + let i = Idents.gen_var "obc2java" "i" in + let id = mk_var_dec i Tint in + Afor (id, Sint 0, s, mk_block ([aux s_l (i::i_l)])) + | [] -> Misc.internal_error "Fresh nfor called with empty size list" + in + aux s_l [] + (* current module is not translated to keep track, there is no issue since printed without the qualifier *) let rec translate_modul m = m (*match m with @@ -146,7 +168,7 @@ let rec static_exp param_env se = match se.Types.se_desc with 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.Srecord _ -> Misc.unsupported "Srecord in java" (* 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 @@ -156,7 +178,15 @@ and boxed_ty param_env t = match t with | 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 (ty param_env t, static_exp param_env size) + | Types.Tarray _ -> + let rec gather_array t = match t with + | Types.Tarray (t,size) -> + let t, s_l = gather_array t in + t, (static_exp param_env size)::s_l + | _ -> ty param_env t, [] + in + let t, s_l = gather_array t in + Tarray (t, s_l) | Types.Tinvalid -> Misc.internal_error "obc2java invalid type" and tuple_ty param_env ty_l = @@ -170,7 +200,15 @@ and ty param_env t :Java.ty = match t with | 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.Tarray _ -> + let rec gather_array t = match t with + | Types.Tarray (t,size) -> + let t, s_l = gather_array t in + t, (static_exp param_env size)::s_l + | _ -> ty param_env t, [] + in + let t, s_l = gather_array t in + Tarray (t, s_l) | Types.Tinvalid -> Misc.internal_error "obc2java invalid type" and var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident } @@ -194,27 +232,47 @@ 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) + | Obc.Larray _ -> + let p, idx_l = + let rec gather_idx acc p = match p.pat_desc with + | Obc.Larray (p,e) -> gather_idx ((exp param_env e)::acc) p + | _ -> pattern param_env p, acc + in + let p, idx_l = gather_idx [] p in + p, idx_l + in + Parray_elem (p, idx_l) and pattern_to_exp param_env p = match p.pat_desc with | Obc.Lvar v -> Evar v | Obc.Lmem v -> this_field_ident v | Obc.Lfield (p,f) -> Efield (pattern_to_exp param_env p, translate_field_name f) - | Obc.Larray (p,e) -> - Earray_elem (pattern_to_exp param_env p, exp param_env e) + | Obc.Larray _ -> + let p, idx_l = + let rec gather_idx acc p = match p.pat_desc with + | Obc.Larray (p,e) -> gather_idx ((exp param_env e)::acc) p + | _ -> pattern_to_exp param_env p, acc + in + let p, idx_l = gather_idx [] p in + p, idx_l + in + Earray_elem (p, idx_l) and ext_value param_env w = match w.w_desc with | Obc.Wvar v -> Evar v | Obc.Wconst c -> static_exp param_env c | Obc.Wmem v -> this_field_ident v | Obc.Wfield (p,f) -> Efield (ext_value param_env p, translate_field_name f) - | Obc.Warray (p,e) -> Earray_elem (ext_value param_env p, exp param_env e) + | Obc.Warray (p,e) -> Earray_elem (ext_value param_env p, [exp param_env e]) let obj_ref param_env o = match o with | Oobj id -> Evar id - | Oarray (id,p) -> Earray_elem (Evar id, pattern_to_exp param_env p) + | Oarray (id, p_l) -> + (* the generated list is in java order *) + let idx_l = List.map (fun p -> pattern_to_exp param_env p) p_l in + Earray_elem (Evar id, idx_l) let rec act_list param_env act_l acts = let _act act acts = match act with @@ -350,19 +408,19 @@ let class_def_list classes cd_l = | None -> let t = Idents.Env.find od.o_ident obj_env in (Aassgn (Pthis od.o_ident, Enew (t, params)))::acts - | Some size -> - let size = static_exp param_env size in + | Some size_l -> + let size_l = List.rev (List.map (static_exp param_env) size_l) 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)) ] + let assgn_elem i_l = + [ Aassgn (Parray_elem (Pthis od.o_ident, List.map mk_var i_l), Enew (t, params)) ] in - (Aassgn (Pthis od.o_ident, Enew_array (Tarray (t,size), []))) - :: (fresh_for size assgn_elem) + (Aassgn (Pthis od.o_ident, Enew_array (Tarray (t,size_l), []))) + :: (fresh_nfor size_l assgn_elem) :: acts in (* function to allocate the arrays *) let allocate acts vd = match vd.v_type with - | Types.Tarray (t, size) -> + | Types.Tarray _ -> let t = ty param_env vd.v_type in ( Aassgn (Pthis vd.v_ident, Enew_array (t,[])) ):: acts | _ -> acts @@ -386,7 +444,8 @@ let class_def_list classes cd_l = let obj_to_field fields od = let jty = match od.o_size with | None -> Idents.Env.find od.o_ident obj_env - | Some size -> Tarray (Idents.Env.find od.o_ident obj_env, static_exp param_env size) + | Some size_l -> Tarray (Idents.Env.find od.o_ident obj_env, + List.map (static_exp param_env) size_l) in (mk_field ~protection:Pprotected jty od.o_ident) :: fields in diff --git a/test/good/array_iterators2.ept b/test/good/array_iterators2.ept new file mode 100644 index 0000000..9cf92ab --- /dev/null +++ b/test/good/array_iterators2.ept @@ -0,0 +1,11 @@ + +node sum_acc (a, acc_in:int) returns (acc_out:int) +let + acc_out = acc_in + a; +tel + +node h(a:int^n^n2) returns (m:int) +let + m = fold<> sum_acc (a, 0); +tel + From 42c2936040908dc54411e83b7a9c1878f22f66d6 Mon Sep 17 00:00:00 2001 From: Brice Gelineau Date: Wed, 6 Jul 2011 15:51:26 +0200 Subject: [PATCH 7/9] Bugfix for the clocking analysis of iterators --- compiler/minils/analysis/clocking.ml | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/compiler/minils/analysis/clocking.ml b/compiler/minils/analysis/clocking.ml index 2453002..bf2482a 100644 --- a/compiler/minils/analysis/clocking.ml +++ b/compiler/minils/analysis/clocking.ml @@ -147,28 +147,30 @@ let typing_eq h { eq_lhs = pat; eq_rhs = e; eq_loc = loc } = let base_ck = fresh_clock () in let ct = typing_app h base_ck pat op args in ct, base_ck - | Eiterator (it, {a_op = op}, _, pargs, args, _) -> (* hyperchronous reset *) + | Eiterator (it, {a_op = op}, nl, pargs, args, _) -> (* hyperchronous reset *) let base_ck = fresh_clock() in let ct = match it with | Imap -> (* exactly as if clocking the node *) typing_app h base_ck pat op (pargs@args) - | Imapi -> (* clocking the node with the extra [i] input on [ck_r] *) - let i (* stubs [i] as 0 *) = - mk_extvalue ~ty:Initial.tint ~clock:base_ck (Wconst (Initial.mk_static_int 0)) + | Imapi -> (* clocking the node with the extra i input on [ck_r] *) + let il (* stubs i as 0 *) = + List.map (fun x -> mk_extvalue ~ty:Initial.tint + ~clock:base_ck (Wconst (Initial.mk_static_int 0))) nl in - typing_app h base_ck pat op (pargs@args@[i]) + typing_app h base_ck pat op (pargs@args@il) | Ifold | Imapfold -> (* clocking node with equality constaint on last input and last output *) let ct = typing_app h base_ck pat op (pargs@args) in unify_ck (Clocks.last_clock ct) (Misc.last_element args).w_ck; ct - | Ifoldi -> (* clocking the node with the extra [i] and last in/out constraints *) - let i (* stubs [i] as 0 *) = - mk_extvalue ~ty:Initial.tint ~clock:base_ck (Wconst (Initial.mk_static_int 0)) + | Ifoldi -> (* clocking the node with the extra i and last in/out constraints *) + let il (* stubs i as 0 *) = + List.map (fun x -> mk_extvalue ~ty:Initial.tint + ~clock:base_ck (Wconst (Initial.mk_static_int 0))) nl in let rec insert_i args = match args with - | [] -> [i] - | [l] -> i::[l] + | [] -> il + | [l] -> il @ [l] | h::l -> h::(insert_i l) in let ct = typing_app h base_ck pat op (pargs@(insert_i args)) in From f40dc66e5785af164c0ba5d1239777147d813bc2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Thu, 7 Jul 2011 16:19:30 +0200 Subject: [PATCH 8/9] Patch typing.ml from brice email 27/06/11. --- compiler/heptagon/analysis/typing.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 5b7ed2e..c3b1c1f 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -796,8 +796,8 @@ and typing_iterator cenv h in let mk_array_type ty_list = List.map (array_of_idx_list n_list) ty_list in let n_size = List.length n_list in - let mk_array_type_butnlast ty_list = - map_butnlast n_size (array_of_idx_list n_list) ty_list in + let mk_array_type_butlast ty_list = + map_butlast (array_of_idx_list n_list) ty_list in match it with | Imap -> let args_ty_list = mk_array_type args_ty_list in @@ -821,7 +821,7 @@ and typing_iterator cenv h prod result_ty_list, typed_e_list | Ifold -> - let args_ty_list = mk_array_type_butnlast args_ty_list in + let args_ty_list = mk_array_type_butlast args_ty_list in let typed_e_list = typing_args cenv h args_ty_list e_list in (*check accumulator type matches in input and output*) @@ -839,7 +839,7 @@ and typing_iterator cenv h ( try unify cenv idx_ty (Tid Initial.pint) with TypingError _ -> raise (TypingError (Emapi_bad_args idx_ty)))) idx_ty_list; - let args_ty_list = mk_array_type_butnlast (args_ty_list@[acc_ty]) in + let args_ty_list = mk_array_type_butlast (args_ty_list@[acc_ty]) in let typed_e_list = typing_args cenv h args_ty_list e_list in (*check accumulator type matches in input and output*) @@ -849,8 +849,8 @@ and typing_iterator cenv h (List.hd result_ty_list), typed_e_list | Imapfold -> - let args_ty_list = mk_array_type_butnlast args_ty_list in - let result_ty_list = mk_array_type_butnlast result_ty_list in + let args_ty_list = mk_array_type_butlast args_ty_list in + let result_ty_list = mk_array_type_butlast result_ty_list in let typed_e_list = typing_args cenv h args_ty_list e_list in (*check accumulator type matches in input and output*) From 10115684d99b23d85d7575fab498f6026effb6c9 Mon Sep 17 00:00:00 2001 From: Brice Gelineau Date: Fri, 8 Jul 2011 10:51:10 +0200 Subject: [PATCH 9/9] bugfix for reset calls in C --- compiler/obc/c/cgen.ml | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 3ef147c..c90c330 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -560,20 +560,18 @@ let rec cstm_of_act out_env var_env obj_env act = let on = obj_ref_name o in let obj = assoc_obj on obj_env in let classn = cname_of_qn obj.o_class in - (match obj.o_size with - | None -> - [Csexpr (Cfun_call (classn ^ "_reset", - [Caddrof (Cfield (Cderef (Cvar "self"), local_qn (name on)))]))] - | Some size -> - let field = Cfield (Cderef (Cvar "self"), local_qn (name on)) in - let rec mk_loop nl elt = match nl with - | [] -> [Csexpr (Cfun_call (classn ^ "_reset", [Caddrof elt] ))] - | n::nl -> - let x = gen_symbol () in - let elt = Carray(elt, Cvar x) in - [Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp n, mk_loop nl elt)] - in - mk_loop size field + let field = Cfield (Cderef (Cvar "self"), local_qn (name on)) in + (match o with + | Oobj _ -> + [Csexpr (Cfun_call (classn ^ "_reset", [Caddrof field]))] + | Oarray (_, pl) -> + let rec mk_loop pl field = match pl with + | [] -> + [Csexpr (Cfun_call (classn ^ "_reset", [Caddrof field]))] + | p::pl -> + mk_loop pl (Carray(field, cexpr_of_pattern out_env var_env p)) + in + mk_loop pl field ) (** Step functions applications can return multiple values, so we use a