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

n-ary Sarray_power Earray_fill

Browse source
This commit is contained in:
Brice Gelineau 2011-05-26 18:39:33 +02:00
parent fdbe6445a7
commit 938e8897b2
17 changed files with 104 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
compiler/global/global_compare.ml
View file

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

6
compiler/global/global_mapfold.ml
View file

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

4
compiler/global/global_printer.ml
View file

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

8
compiler/global/static.ml
View file

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

4
compiler/global/types.ml
View file

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

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

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

3
compiler/heptagon/hept_printer.ml
View file

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

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

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

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

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

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

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

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

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

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

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

19
compiler/main/mls2obc.ml
View file

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

2
compiler/minils/minils.ml
View file

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

4
compiler/minils/mls_printer.ml
View file

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

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

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

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

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