From d265d7a89b15e0da481d465d5c4542c75f2cfdc4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Wed, 12 Jan 2011 13:39:21 +0100 Subject: [PATCH] Minimize created exps with invalid_type. --- compiler/global/modules.ml | 12 ++++------ compiler/heptagon/analysis/typing.ml | 2 +- compiler/main/mls2obc.ml | 14 ++++------- compiler/minils/minils.ml | 4 ++-- compiler/minils/transformations/itfusion.ml | 26 +++++++++++---------- compiler/minils/transformations/tomato.ml | 15 ++++++------ compiler/obc/obc.ml | 6 ++--- 7 files changed, 37 insertions(+), 42 deletions(-) diff --git a/compiler/global/modules.ml b/compiler/global/modules.ml index 66f8437..c132353 100644 --- a/compiler/global/modules.ml +++ b/compiler/global/modules.ml @@ -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 = diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index eea7345..9115bea 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -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 *) diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index a083e79..c9bd4ae 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -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 diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index ad40894..361cfe2 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -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)) diff --git a/compiler/minils/transformations/itfusion.ml b/compiler/minils/transformations/itfusion.ml index f3effeb..6e7c0e3 100644 --- a/compiler/minils/transformations/itfusion.ml +++ b/compiler/minils/transformations/itfusion.ml @@ -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 diff --git a/compiler/minils/transformations/tomato.ml b/compiler/minils/transformations/tomato.ml index 5b358dc..dce1cfd 100644 --- a/compiler/minils/transformations/tomato.ml +++ b/compiler/minils/transformations/tomato.ml @@ -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 diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index e842dee..efe8a3a 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -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)