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

Minimize created exps with invalid_type.

Browse source
This commit is contained in:
Léonard Gérard 2011-01-12 13:39:21 +01:00
parent 0768babab7
commit d265d7a89b
7 changed files with 37 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
compiler/global/modules.ml
View file

@ -162,13 +162,11 @@ let replace_value f v =
(** { 3 Find functions look in the global environnement, nothing more } *)
let _find env x = QualEnv.find x env
let find_value x = _find g_env.values x
let find_type x = _find g_env.types x
let find_constrs x = _find g_env.constrs x
let find_field x = _find g_env.fields x
let find_const x = _find g_env.consts x
let find_value x = QualEnv.find x g_env.values
let find_type x = QualEnv.find x g_env.types
let find_constrs x = Tid (QualEnv.find x g_env.constrs)
let find_field x = QualEnv.find x g_env.fields (* TODO master : the result should be Tid(...) *)
let find_const x = QualEnv.find x g_env.consts
(** @return the fields of a record type. *)
let find_struct n =

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

@ -171,7 +171,7 @@ let find_with_error find_fun f =
with Not_found -> error (Eundefined(fullname f))
let find_value v = find_with_error find_value v
let find_constrs c = Tid (find_with_error find_constrs c)
let find_constrs c = find_with_error find_constrs c
let find_field f = find_with_error find_field f
(** Constraints related functions *)

14
compiler/main/mls2obc.ml
View file

@ -21,10 +21,6 @@ open Initial
let fresh_it () = Idents.gen_var "mls2obc" "i"
(** Not giving any type and called after typing, DO NOT use it anywhere else *)
let static_exp_of_int i =
Types.mk_static_exp (Types.Sint i)
let gen_obj_name n =
(shortname n) ^ "_mem" ^ (gen_symbol ())
@ -143,7 +139,7 @@ and translate_act map pat
let idx = mk_exp (Eop (op_from_string "+",
[ mk_exp (Econst n1); mk_evar cpt2])) in
let a2 =
Afor (cpt2, static_exp_of_int 0, n2,
Afor (cpt2, mk_static_int 0, n2,
mk_block [Aassgn (mk_lhs (Larray (x, idx)),
mk_lhs_exp (Larray (lhs_of_exp e2,
mk_evar cpt2)))] )
@ -373,7 +369,7 @@ and translate_iterator map call_context it name_list app loc n x c_list =
app loc name_list c_list in
let v = translate_var_dec v in
let b = mk_block ~locals:v action in
si, j, [ Afor (x, static_exp_of_int 0, n, b) ]
si, j, [ Afor (x, mk_static_int 0, n, b) ]
| Minils.Imapfold ->
let (c_list, acc_in) = split_last c_list in
@ -386,7 +382,7 @@ and translate_iterator map call_context it name_list app loc n x c_list =
let v = translate_var_dec v in
let b = mk_block ~locals:v action in
si, j, [Aassgn (acc_out, acc_in);
Afor (x, static_exp_of_int 0, n, b)]
Afor (x, mk_static_int 0, n, b)]
| Minils.Ifold ->
let (c_list, acc_in) = split_last c_list in
@ -397,7 +393,7 @@ and translate_iterator map call_context it name_list app loc n x c_list =
let v = translate_var_dec v in
let b = mk_block ~locals:v action in
si, j, [ Aassgn (acc_out, acc_in);
Afor (x, static_exp_of_int 0, n, b) ]
Afor (x, mk_static_int 0, n, b) ]
| Minils.Ifoldi ->
let (c_list, acc_in) = split_last c_list in
@ -408,7 +404,7 @@ and translate_iterator map call_context it name_list app loc n x c_list =
let v = translate_var_dec v in
let b = mk_block ~locals:v action in
si, j, [ Aassgn (acc_out, acc_in);
Afor (x, static_exp_of_int 0, n, b) ]
Afor (x, mk_static_int 0, n, b) ]
let remove m d_list =
List.filter (fun { Minils.v_ident = n } -> not (List.mem_assoc n m)) d_list

4
compiler/minils/minils.ml
View file

@ -133,7 +133,7 @@ type program = {
(*Helper functions to build the AST*)
let mk_exp ?(ty = invalid_type) ?(clock = fresh_clock())
let mk_exp ~ty ?(clock = fresh_clock())
?(loc = no_location) ?(base_clock = Cbase) desc =
{ e_desc = desc; e_ty = ty;
e_base_ck = base_clock; e_ck = clock; e_loc = loc }
@ -173,5 +173,5 @@ let mk_program o n t c =
{ p_modname = ""; p_format_version = "";
p_opened = o; p_nodes = n; p_types = t; p_consts = c }
let void = mk_exp (Eapp (mk_app Etuple, [], None))
let void = mk_exp ~ty:Types.Tunit (Eapp (mk_app Etuple, [], None))

26
compiler/minils/transformations/itfusion.ml
View file

@ -104,25 +104,27 @@ let edesc funs acc ed =
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 ->
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
new_inp @ inp, acc_eq_list, e::largs, local_args @ args, true
| _ ->
let vd = mk_var_dec (fresh_var ()) e.e_ty in
let x = mk_exp (Evar vd.v_ident) in
let x = mk_exp ~ty:vd.v_type (Evar vd.v_ident) in
vd::inp, acc_eq_list, x::largs, e::args, b
in
let inp, acc_eq_list, largs, args, can_be_fused =
List.fold_right mk_arg e_list ([], [], [], [], false) in
if can_be_fused then (
(* create the call to f in the lambda fun *)
let call = mk_exp (Eapp(f, largs, None)) in
let _, outp = get_node_inp_outp f in
let eq = mk_equation (pat_of_vd_list outp) call in
(* create the lambda *)
let anon = mk_app (Enode (add_anon_node inp outp [] (eq::acc_eq_list))) in
Eiterator(Imap, anon, n, args, r), acc
) else
ed, acc
if can_be_fused
then (
(* create the call to f in the lambda fun *)
let _, outp = get_node_inp_outp f in
let f_out_type = Types.prod (List.map (fun v -> v.v_type) outp) in
let call = mk_exp ~ty:f_out_type (Eapp(f, largs, None)) in
let eq = mk_equation (pat_of_vd_list outp) call in
(* create the lambda *)
let anon = mk_app (Enode (add_anon_node inp outp [] (eq::acc_eq_list))) in
Eiterator(Imap, anon, n, args, r), acc)
else
ed, acc
| _ -> raise Errors.Fallback

15
compiler/minils/transformations/tomato.ml
View file

@ -155,9 +155,9 @@ struct
end
let empty_var = Idents.gen_var "tomato" "EMPTY"
let dummy_exp = mk_exp (Evar empty_var)
let dummy_exp = mk_exp ~ty:Types.Tunit (Evar empty_var)
let exp_of_ident vi = mk_exp (Evar vi)
let exp_of_ident ~ty vi = mk_exp ~ty:ty (Evar vi)
and ident_of_exp { e_desc = e_d; } = match e_d with
| Evar vi -> vi
| _ -> invalid_arg "ident_of_exp"
@ -180,7 +180,7 @@ let behead e =
let encode_reset rst = match rst with
| None -> (None, [])
| Some x -> (Some empty_var, [exp_of_ident x]) in
| Some x -> (Some empty_var, [exp_of_ident ~ty:(Tid Initial.pbool) x]) in
let (e_desc, children) = match e.e_desc with
| Econst _ -> (e.e_desc, [])
@ -192,12 +192,11 @@ let behead e =
an empty argument list. *)
(Eapp (op, repeat_list dummy_exp (List.length e_list), rst), l @ e_list)
| Ewhen (e, cstr, x) ->
(Ewhen (dummy_exp, cstr, empty_var), [exp_of_ident x; e])
(Ewhen (dummy_exp, cstr, empty_var), [exp_of_ident ~ty:(Modules.find_constrs cstr) x; e])
| Emerge (x, lne_list) ->
let (lne_list, e_list) =
List.split
(List.map (fun (ln, e) -> ((ln, dummy_exp), e)) lne_list) in
(Emerge (empty_var, lne_list), exp_of_ident x :: e_list)
let (lne_list, e_list) = List.split (List.map (fun (ln, e) -> ((ln, dummy_exp), e)) lne_list) in
let ty = lne_list |> List.hd |> fun (c,_) -> c |> Modules.find_constrs in
(Emerge (empty_var, lne_list), exp_of_ident ~ty:ty x::e_list)
| Estruct lne_list ->
let (lne_list, e_list) =
List.split

6
compiler/obc/obc.ml
View file

@ -109,13 +109,13 @@ type program =
let mk_var_dec ?(loc=no_location) name ty =
{ v_ident = name; v_type = ty; v_loc = loc }
let mk_exp ?(ty=invalid_type) ?(loc=no_location) desc =
let mk_exp ?(ty=invalid_type) ?(loc=no_location) desc = (* TODO master : remove the invalid_type *)
{ e_desc = desc; e_ty = ty; e_loc = loc }
let mk_lhs ?(ty=invalid_type) ?(loc=no_location) desc =
let mk_lhs ?(ty=invalid_type) ?(loc=no_location) desc = (* TODO master : remove the invalid_type *)
{ pat_desc = desc; pat_ty = ty; pat_loc = loc }
let mk_lhs_exp ?(ty=invalid_type) desc =
let mk_lhs_exp ?(ty=invalid_type) desc = (* TODO master : remove the invalid_type *)
let lhs = mk_lhs ~ty:ty desc in
mk_exp ~ty:ty (Elhs lhs)