From 938e8897b2262c84a00ef9948818fd578061abde Mon Sep 17 00:00:00 2001 From: Brice Gelineau Date: Thu, 26 May 2011 18:39:33 +0200 Subject: [PATCH] n-ary Sarray_power Earray_fill --- compiler/global/global_compare.ml | 4 +- compiler/global/global_mapfold.ml | 6 +-- compiler/global/global_printer.ml | 4 +- compiler/global/static.ml | 8 ++-- compiler/global/types.ml | 4 +- compiler/heptagon/analysis/typing.ml | 15 +++--- compiler/heptagon/hept_printer.ml | 3 +- compiler/heptagon/parsing/hept_parser.mly | 4 +- compiler/heptagon/parsing/hept_parsetree.ml | 2 +- .../parsing/hept_parsetree_mapfold.ml | 6 +-- compiler/heptagon/parsing/hept_scoping.ml | 2 +- .../heptagon/parsing/hept_static_scoping.ml | 4 +- compiler/main/mls2obc.ml | 19 ++++++-- compiler/minils/minils.ml | 2 +- compiler/minils/mls_printer.ml | 4 +- compiler/obc/c/cgen.ml | 24 +++++++--- compiler/obc/java/obc2java.ml | 48 +++++++++++++++---- 17 files changed, 104 insertions(+), 55 deletions(-) diff --git a/compiler/global/global_compare.ml b/compiler/global/global_compare.ml index 46292de..7373c31 100644 --- a/compiler/global/global_compare.ml +++ b/compiler/global/global_compare.ml @@ -51,9 +51,9 @@ let rec static_exp_compare se1 se2 = | Sfield f1, Sfield f2 -> c f1 f2 | Stuple sel1, Stuple sel2 -> list_compare static_exp_compare sel1 sel2 - | Sarray_power (se11, se21), Sarray_power (se12, se22) -> + | Sarray_power (se11, sel1), Sarray_power (se12, sel2) -> let cr = static_exp_compare se11 se12 in - if cr <> 0 then cr else static_exp_compare se21 se22 + if cr <> 0 then cr else list_compare static_exp_compare sel1 sel2 | Sarray sel1, Sarray sel2 -> list_compare static_exp_compare sel1 sel2 | Srecord fnsel1, Srecord fnsel2 -> diff --git a/compiler/global/global_mapfold.ml b/compiler/global/global_mapfold.ml index 00c89a5..ee68ee3 100644 --- a/compiler/global/global_mapfold.ml +++ b/compiler/global/global_mapfold.ml @@ -38,10 +38,10 @@ and static_exp_desc funs acc sd = match sd with | Sop (n, se_l) -> let se_l, acc = mapfold (static_exp_it funs) acc se_l in Sop (n, se_l), acc - | Sarray_power (se1, se2) -> + | Sarray_power (se1, se_l) -> let se1, acc = static_exp_it funs acc se1 in - let se2, acc = static_exp_it funs acc se2 in - Sarray_power(se1, se2), acc + let se_l, acc = mapfold (static_exp_it funs) acc se_l in + Sarray_power(se1, se_l), acc | Srecord f_se_l -> let aux acc (f,se) = let se,acc = static_exp_it funs acc se in (f, se), acc in diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index fb97c35..d9adb81 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -54,8 +54,8 @@ let rec print_static_exp_desc ff sed = match sed with else fprintf ff "@[<2>%a@,%a@]" print_qualname op print_static_exp_tuple se_list - | Sarray_power (se, n) -> - fprintf ff "%a^%a" print_static_exp se print_static_exp n + | Sarray_power (se, n_list) -> + fprintf ff "%a^%a" print_static_exp se (print_list print_static_exp """^""") n_list | Sarray se_list -> fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "["";""]") se_list | Stuple se_list -> print_static_exp_tuple ff se_list diff --git a/compiler/global/static.ml b/compiler/global/static.ml index a207df9..fe41b2a 100644 --- a/compiler/global/static.ml +++ b/compiler/global/static.ml @@ -114,8 +114,8 @@ let rec eval_core partial env se = match se.se_desc with { se with se_desc = se_desc } | Sarray 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_core partial env se, eval_core partial env n) } + | Sarray_power (se, n_list) -> + { se with se_desc = Sarray_power (eval_core partial env se, List.map (eval_core partial env) n_list) } | Stuple se_list -> { se with se_desc = Stuple (List.map (eval_core partial env) se_list) } | Srecord f_se_list -> @@ -188,9 +188,9 @@ let rec static_exp_subst m se = | Svar qn -> (try QualEnv.find qn m with | Not_found -> se) | Sop (op, se_list) -> { se with se_desc = Sop (op, List.map (static_exp_subst m) se_list) } - | Sarray_power (se, n) -> + | Sarray_power (se, n_list) -> { se with se_desc = Sarray_power (static_exp_subst m se, - static_exp_subst m n) } + List.map (static_exp_subst m) n_list) } | Sarray se_list -> { se with se_desc = Sarray (List.map (static_exp_subst m) se_list) } | Stuple se_list -> diff --git a/compiler/global/types.ml b/compiler/global/types.ml index 4537736..77325f8 100644 --- a/compiler/global/types.ml +++ b/compiler/global/types.ml @@ -23,7 +23,7 @@ and static_exp_desc = | Sconstructor of constructor_name | Sfield of field_name | Stuple of static_exp list - | Sarray_power of static_exp * static_exp (** power : 0^n : [0,0,0,0,0,..] *) + | Sarray_power of static_exp * (static_exp list) (** power : 0^n^m : [[0,0,..],[0,0,..],..] *) | 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 *) @@ -31,7 +31,7 @@ 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] *) (* TODO obc : array of prod ?? nonono *) + | Tarray of ty * static_exp (** [base_type] * [size] *) (* ty should not be prod *) | Tinvalid let invalid_type = Tinvalid (** Invalid type given to untyped expression etc. *) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 9e7eb08..052d38f 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -414,10 +414,11 @@ and typing_static_exp const_env se = (types_of_arg_list ty_desc.node_inputs) se_list in Sop (op, typed_se_list), prod (types_of_arg_list ty_desc.node_outputs) - | Sarray_power (se, n) -> - let typed_n = expect_static_exp const_env (Tid Initial.pint) n in + | Sarray_power (se, n_list) -> + let typed_n_list = List.map (expect_static_exp const_env Initial.tint) n_list in let typed_se, ty = typing_static_exp const_env se in - Sarray_power (typed_se, typed_n), Tarray(ty, typed_n) + let tarray = List.fold_left (fun ty typed_n -> Tarray(ty, typed_n)) ty typed_n_list in + Sarray_power (typed_se, typed_n_list), tarray | Sarray [] -> message se.se_loc Eempty_array | Sarray (se::se_list) -> @@ -691,12 +692,12 @@ and typing_app const_env h app e_list = t1, app, [typed_e1; typed_e2] | Earray_fill -> - let n = assert_1 app.a_params in + let _, _ = assert_1min app.a_params in let e1 = assert_1 e_list in - let typed_n = expect_static_exp const_env (Tid Initial.pint) n in + let typed_n_list = List.map (expect_static_exp const_env Initial.tint) app.a_params in let typed_e1, t1 = typing const_env h e1 in - add_size_constraint (Clequal (mk_static_int 1, typed_n)); - Tarray (t1, typed_n), { app with a_params = [typed_n] }, [typed_e1] + List.map (fun typed_n -> add_size_constraint (Clequal (mk_static_int 1, typed_n))) typed_n_list; + (List.fold_left (fun t1 typed_n -> Tarray (t1, typed_n)) t1 typed_n_list), { app with a_params = typed_n_list }, [typed_e1] | Eselect -> let e1 = assert_1 e_list in diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index 61e6be7..275689e 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -157,8 +157,7 @@ and print_app ff (app, args) = | 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 + fprintf ff "%a@[<2>%a@]" print_exp e (print_list print_static_exp "^""^""") app.a_params | Eselect -> let e = assert_1 args in fprintf ff "%a%a" print_exp e print_index app.a_params diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index 30d2fdc..17fb065 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -469,8 +469,8 @@ _exp: | LAST IDENT { Elast $2 } /*Array operations*/ - | exp POWER simple_exp - { mk_call ~params:[$3] Earray_fill [$1] } + | exp POWER separated_nonempty_list(POWER, simple_exp) + { mk_call ~params:$3 Earray_fill [$1] } | simple_exp indexes { mk_call ~params:$2 Eselect [$1] } | simple_exp DOT indexes DEFAULT exp diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index a2f4436..d163ccd 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -44,7 +44,7 @@ and static_exp_desc = | Sconstructor of constructor_name | Sfield of field_name | Stuple of static_exp list - | Sarray_power of static_exp * static_exp (** power : 0^n : [0,0,0,0,0,..] *) + | Sarray_power of static_exp * (static_exp list) (** power : 0^n : [0,0,0,0,0,..] *) | 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 *) diff --git a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml index 29e6824..b26e184 100644 --- a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml +++ b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml @@ -64,10 +64,10 @@ and static_exp_desc funs acc sd = match sd with | Sop (n, se_l) -> let se_l, acc = mapfold (static_exp_it funs) acc se_l in Sop (n, se_l), acc - | Sarray_power (se1, se2) -> + | Sarray_power (se1, se_l) -> let se1, acc = static_exp_it funs acc se1 in - let se2, acc = static_exp_it funs acc se2 in - Sarray_power(se1, se2), acc + let se_l, acc = mapfold (static_exp_it funs) acc se_l in + Sarray_power(se1, se_l), acc | Srecord f_se_l -> let aux acc (f,se) = let se,acc = static_exp_it funs acc se in (f, se), acc in diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index 3cfc9aa..a6caf59 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -217,7 +217,7 @@ and translate_static_exp_desc loc ed = | Sconstructor c -> Types.Sconstructor (qualify_constrs c) | Sfield c -> Types.Sfield (qualify_field c) | Stuple se_list -> Types.Stuple (List.map t se_list) - | Sarray_power (se,sn) -> Types.Sarray_power (t se, t sn) + | Sarray_power (se,sn) -> Types.Sarray_power (t se, List.map t sn) | Sarray se_list -> Types.Sarray (List.map t se_list) | Srecord se_f_list -> let qualf (f, se) = (qualify_field f, t se) in diff --git a/compiler/heptagon/parsing/hept_static_scoping.ml b/compiler/heptagon/parsing/hept_static_scoping.ml index 6128930..6d93815 100644 --- a/compiler/heptagon/parsing/hept_static_scoping.ml +++ b/compiler/heptagon/parsing/hept_static_scoping.ml @@ -40,8 +40,8 @@ let exp funs local_const e = Svar (Q (qualify_const local_const (ToQ n))) with | Error.ScopingError _ -> raise Not_static) - | Eapp({ a_op = Earray_fill; a_params = [n] }, [e]) -> - Sarray_power (assert_se e, assert_se n) + | Eapp({ a_op = Earray_fill; a_params = n_list }, [e]) -> + Sarray_power (assert_se e, List.map assert_se n_list) | Eapp({ a_op = Earray }, e_list) -> Sarray (List.map assert_se e_list) | Eapp({ a_op = Etuple }, e_list) -> diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 007315b..23ec7f5 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -264,16 +264,27 @@ and translate_act map pat | _ -> assert false) | Minils.Evarpat x, - Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; Minils.a_params = [n] }, [e], _) -> - let cpt, cptd = fresh_it () in + Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; Minils.a_params = n_list }, [e], _) -> let e = translate_extvalue map e in let x = 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 b = mk_block [Aassgn (mk_pattern t (Larray (x, mk_evar_int cpt)), e) ] in - [ Afor (cptd, mk_exp_const_int 0, mk_exp_static_int n, b) ] + + let rec make_loop power_list replace = match power_list with + | [] -> x, replace + | p :: power_list -> + let cpt, cptd = fresh_it () in + let e, replace = + make_loop power_list + (fun y -> [Afor (cptd, mk_exp_const_int 0, + mk_exp_static_int p, mk_block (replace y))]) in + let e = Larray (e, mk_evar_int cpt) in + (mk_pattern t e, replace) + in + let e, b = make_loop n_list (fun y -> [Aassgn (y, e)]) in + b e | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice; diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index fbd38ea..7c60316 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -82,7 +82,7 @@ and op = | Eifthenelse (** if arg1 then arg2 else arg3 *) | Efield_update (** { arg1 with a_param1 = arg2 } *) | Earray (** [ args ] *) - | Earray_fill (** [arg1^a_param1] *) + | Earray_fill (** [arg1^a_param1^..^a_paramn] *) | Eselect (** arg1[a_params] *) | Eselect_slice (** arg1[a_param1..a_param2] *) | Eselect_dyn (** arg1.[arg3...] default arg2 *) diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index 40ad008..a1609ab 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -145,8 +145,8 @@ and print_app ff (app, args) = | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_extvalue "["";""]") args | Earray_fill -> let e = assert_1 args in - let n = assert_1 app.a_params in - fprintf ff "%a^%a" print_extvalue e print_static_exp n + let n_list = app.a_params in + fprintf ff "%a@[<2>%a@]" print_extvalue e (print_list print_static_exp "^""^""") n_list | Eselect -> let e = assert_1 args in fprintf ff "%a%a" print_extvalue e print_index app.a_params diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index d7f6135..0fbf86e 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -253,9 +253,9 @@ let rec cexpr_of_static_exp se = in Cstructlit (ty_name, List.map (fun (_, se) -> cexpr_of_static_exp se) fl) - | Sarray_power(c,n) -> - let cc = cexpr_of_static_exp c in - Carraylit (repeat_list cc (int_of_static_exp n)) (* TODO should be recursive *) + | Sarray_power(c,n_list) -> + (List.fold_left (fun cc n -> Carraylit (repeat_list cc (int_of_static_exp n))) + (cexpr_of_static_exp c) n_list) | Svar ln -> (try let cd = find_const ln in @@ -419,10 +419,20 @@ let rec create_affect_const var_env dest c = | Svar ln -> let se = Static.simplify QualEnv.empty (find_const ln).c_value in create_affect_const var_env dest se - | Sarray_power(c, n) -> - let x = gen_symbol () in - [Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp n, - create_affect_const var_env (Carray (dest, Clhs (Cvar x))) c)] + | Sarray_power(c, n_list) -> + + let rec make_loop power_list replace = match power_list with + | [] -> dest, replace + | p :: power_list -> + let x = gen_symbol () in + let e, replace = + make_loop power_list + (fun y -> [Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp p, replace y)]) in + let e = (Carray (e, Clhs (Cvar x))) in + e, replace + in + let e, b = make_loop n_list (fun y -> y) in + b (create_affect_const var_env e c) | Sarray cl -> let create_affect_idx c (i, affl) = let dest = Carray (dest, Cconst (Ccint i)) in diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index 7712bd6..7b97289 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -104,17 +104,45 @@ 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 (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) + | Types.Sarray_power (see,pow_list) -> + let pow_list = List.rev pow_list in + let rec make_array tyl pow_list = match tyl, pow_list with + | Tarray(t, _), pow::pow_list -> + 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 + Enew_array (tyl, Misc.repeat_list (make_array t pow_list) pow) + | _ -> static_exp param_env see 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) + make_array (ty param_env se.Types.se_ty) pow_list + (*let t = match x.pat_ty with + | Tarray (t,_) -> t + | _ -> Misc.internal_error "mls2obc select slice type" 5 + in + let eval_int 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 rec make_matrix acc = match pow_list with + | [] -> acc + | pow :: pow_list -> + let pow = eval_int pow in + make_matrix (Misc.repeat_list acc pow) pow_list + in + let se_l = match pow_list with + | [] -> Misc.internal_error "Empty power list" 0 + | pow :: pow_list -> make_matrix (Misc.repeat_list (static_exp param_env see)) pow_list + 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 *)