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

Merge branch 'multidimensional' into decade

Browse source 
Conflicts:
	compiler/obc/c/cgen.ml
	compiler/obc/java/java_main.ml
This commit is contained in:
Léonard Gérard 2011-07-08 11:32:17 +02:00
commit 0518ecafe6
30 changed files with 309 additions and 133 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

61
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,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 = expect_static_exp cenv (Tid Initial.pint) n 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 cenv h it n
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
add_constraint_leq cenv (mk_static_int 1) typed_n;
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) ->
@ -789,30 +789,39 @@ 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
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_butlast ty_list =
map_butlast (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 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 cenv 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)));
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 cenv 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_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*)
@ -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_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*)
@ -838,10 +849,8 @@ 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 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*)

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

4
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
| it=iterator DOUBLE_LESS n=separated_nonempty_list(COMMA, simple_exp) DOUBLE_GREATER q=qualname
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=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
| _ ->

4
compiler/heptagon/transformations/switch.ml
View file

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

95
compiler/main/mls2obc.ml
View file

@ -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,10 +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
| 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]
@ -367,7 +387,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
@ -427,16 +447,17 @@ 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
let x, xd = fresh_it () in
let xl, xdl = List.split (List.map (fun _ -> fresh_it ()) n_list) in
let call_context =
Some { oa_index = mk_pattern_int (Lvar x); oa_size = n} in
let n = mk_exp_static_int n in
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 +530,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 +599,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 +613,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) @ [ exp_of_pattern 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) ]

24
compiler/minils/analysis/clocking.ml
View file

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

2
compiler/minils/analysis/level_clock.ml
View file

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

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

26
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, cexpr_of_pattern out_env var_env p)
in
mk_idx l
) in
args@[Caddrof out; Caddrof mem]
) else
@ -560,9 +564,14 @@ let rec cstm_of_act out_env var_env obj_env act =
(match o with
| Oobj _ ->
[Csexpr (Cfun_call (classn ^ "_reset", [Caddrof field]))]
| Oarray (_, p) ->
[Csexpr (Cfun_call (classn ^ "_reset",
[Caddrof (Carray(field, cexpr_of_pattern out_env var_env p))]))]
| 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
@ -655,7 +664,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

6
compiler/obc/java/java.ml
View file

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

2
compiler/obc/java/java_main.ml
View file

@ -45,7 +45,7 @@ let program p =
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 get_arg i = Earray_elem(exp_args, Sint i) in

9
compiler/obc/java/java_printer.ml
View file

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

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

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

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

3
heptc
View file

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

6
test/good/array_iterators.ept
View file

@ -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<<n>> plusone ();
tel
node g(a:int^n) returns (o:int^n)
let
o = map<<n>> plusone (a);

11
test/good/array_iterators2.ept Normal file
View file

@ -0,0 +1,11 @@
node sum_acc (a, acc_in:int) returns (acc_out:int)
let
acc_out = acc_in + a;
tel
node h<<n, n2 :int>>(a:int^n^n2) returns (m:int)
let
m = fold<<n,n2>> sum_acc (a, 0);
tel