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

Preliminary version of multidimensional iterators.

Browse source
This commit is contained in:
Brice Gelineau 2011-06-27 10:58:14 +02:00 committed by Léonard Gérard
parent 9e881550a7
commit c70d34ec06
21 changed files with 399 additions and 95 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

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

6
compiler/heptagon/hept_mapfold.ml
View file

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

6
compiler/heptagon/hept_printer.ml
View file

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

2
compiler/heptagon/heptagon.ml
View file

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

221
compiler/heptagon/obc_mapfold.ml Normal file
View file

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

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

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

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

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

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

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

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

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

2
compiler/heptagon/transformations/itfusion.ml
View file

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

75
compiler/main/mls2obc.ml
View file

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

2
compiler/main/mls2seq.ml
View file

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

2
compiler/minils/minils.ml
View file

@ -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 <<n>> <(extvalue)> (extvalue) reset ident *)

6
compiler/minils/mls_mapfold.ml
View file

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

4
compiler/minils/mls_printer.ml
View file

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

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

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

4
compiler/obc/obc.ml
View file

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

2
compiler/obc/obc_mapfold.ml
View file

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

6
compiler/obc/obc_printer.ml
View file

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

30
compiler/utilities/misc.ml
View file

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

8
compiler/utilities/misc.mli
View file

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