From d0ed09c3e5ef9ba5c42441d30e878c9092ec800e Mon Sep 17 00:00:00 2001 From: Adrien Guatto Date: Mon, 3 Oct 2011 11:43:50 +0200 Subject: [PATCH] Ext-value inlining pass. --- compiler/global/types.ml | 2 +- compiler/minils/main/mls_compiler.ml | 1 + compiler/minils/minils.ml | 8 +- compiler/minils/mls_utils.ml | 11 +- .../transformations/inline_extvalues.ml | 170 ++++++++++++++++++ 5 files changed, 186 insertions(+), 6 deletions(-) create mode 100644 compiler/minils/transformations/inline_extvalues.ml diff --git a/compiler/global/types.ml b/compiler/global/types.ml index 77325f8..d10b0a0 100644 --- a/compiler/global/types.ml +++ b/compiler/global/types.ml @@ -30,7 +30,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]) *) + | Tid of type_name (** Usable type_name are alias or pervasives {bool,int,float} (see [Initial])*) | Tarray of ty * static_exp (** [base_type] * [size] *) (* ty should not be prod *) | Tinvalid diff --git a/compiler/minils/main/mls_compiler.ml b/compiler/minils/main/mls_compiler.ml index adca0b3..ff02acc 100644 --- a/compiler/minils/main/mls_compiler.ml +++ b/compiler/minils/main/mls_compiler.ml @@ -34,6 +34,7 @@ let compile_program p = let p = let call_tomato = !tomato or (List.length !tomato_nodes > 0) in + let p = pass "Extended value inlining" call_tomato Inline_extvalues.program p pp in pass "Data-flow minimization" call_tomato Tomato.program p pp in (** TODO: re enable when ported to the new AST diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index 5af07e8..1956827 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -78,10 +78,10 @@ and edesc = (** map f <> <(extvalue)> (extvalue) reset ident *) and app = { a_op: op; - a_params: static_exp list; - a_unsafe: bool; - a_id: ident option; - a_inlined: bool } + a_params: static_exp list; + a_unsafe: bool; + a_id: ident option; + a_inlined: bool } (** Unsafe applications could have side effects and be delicate about optimizations, !be careful! *) diff --git a/compiler/minils/mls_utils.ml b/compiler/minils/mls_utils.ml index 54ffdfb..2e24780 100644 --- a/compiler/minils/mls_utils.ml +++ b/compiler/minils/mls_utils.ml @@ -215,10 +215,19 @@ module AllDep = Dep.Make let eq_find id = List.find (fun eq -> List.mem id (Vars.def [] eq)) - let ident_list_of_pat pat = let rec f acc pat = match pat with | Evarpat id -> id::acc | Etuplepat pat_l -> List.fold_left f acc pat_l in List.rev (f [] pat) + +let remove_eqs_from_node nd ids = + let walk_vd vd vd_list = if IdentSet.mem vd.v_ident ids then vd_list else vd :: vd_list in + let walk_eq eq eq_list = + let defs = ident_list_of_pat eq.eq_lhs in + if List.for_all (fun v -> IdentSet.mem v ids) defs then eq_list else eq :: eq_list + in + let vd_list = List.fold_right walk_vd nd.n_local [] in + let eq_list = List.fold_right walk_eq nd.n_equs [] in + { nd with n_local = vd_list; n_equs = eq_list; } diff --git a/compiler/minils/transformations/inline_extvalues.ml b/compiler/minils/transformations/inline_extvalues.ml new file mode 100644 index 0000000..c83d669 --- /dev/null +++ b/compiler/minils/transformations/inline_extvalues.ml @@ -0,0 +1,170 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +open Misc +open Names +open Idents +open Signature +open Minils +open Mls_utils +open Mls_printer +open Global_printer +open Types +open Clocks +open Pp_tools +open Mls_compare + +(* + Help tomato by inlining extended values. + + 1. Create an environment mapping x to w for each equation of the form "x = w" ; + + 2. Traverse the AST, replacing each use of x by its definition ; + + 3. Compute potential new formed extended values, e.g. when y = 1 + x becomes y = 1 + w ; + + 4. If no new extended value was formed, stop ; else, go back to 1. +*) + +let gather_extvalues_node nd = + let gather_extvalues_eq _ env eq = + let env = match eq.eq_lhs, eq.eq_rhs.e_desc with + | Evarpat x, Eextvalue w -> Env.add x w env + | _ -> env + in + eq, env + in + + let funs = { Mls_mapfold.defaults with Mls_mapfold.eq = gather_extvalues_eq; } in + let _, env = Mls_mapfold.node_dec funs Env.empty nd in + env + +let inline_extvalue_node env nd = + let inline_extvalue_desc env funs () w_d = + let w_d, () = Mls_mapfold.extvalue_desc funs () w_d in + (match w_d with + | Wvar x -> (try (Env.find x env).w_desc with Not_found -> w_d) + | _ -> w_d), () + in + + let env = + let funs = + { Mls_mapfold.defaults with + Mls_mapfold.extvalue_desc = inline_extvalue_desc env; } in + + let tclose x w new_env = + let w, () = Mls_mapfold.extvalue funs () w in + Env.add x w new_env + in + Env.fold tclose env Env.empty + in + + let funs = { Mls_mapfold.defaults with Mls_mapfold.extvalue_desc = inline_extvalue_desc env; } in + + let nd, () = Mls_mapfold.node_dec funs () nd in + nd + +let form_new_extvalue_node nd = + let rec form_new_extvalue e = + try + let se = form_new_const e in + mk_extvalue ~ty:e.e_ty ~linearity:e.e_linearity ~clock:e.e_base_ck ~loc:e.e_loc (Wconst se) + with Errors.Fallback -> + let w_d = match e.e_desc with + | Eextvalue w -> w.w_desc + | Ewhen (e, v, x) -> Wwhen (form_new_extvalue e, v, x) + | _ -> raise Errors.Fallback + in + mk_extvalue ~ty:e.e_ty ~linearity:e.e_linearity ~clock:e.e_base_ck ~loc:e.e_loc w_d + + and form_new_const e = + let se_d = match e.e_desc with + | Eextvalue { w_desc = Wconst c; } -> c.se_desc + + (* | Eextvalue { w_desc = Wvar n; } -> *) + (* (try Svar (Q (qualify_const local_const (ToQ n))) *) + (* with Error.ScopingError _ -> raise Errors.Fallback) *) + + | Eapp ({ a_op = Efun ({ qual = Names.Pervasives; } as funn); }, w_list, None) -> + Sop (funn, form_new_consts w_list) + + | Eapp ({ a_op = Earray_fill; a_params = n_list; }, [w], None) -> + Sarray_power (form_new_const_w w, n_list) + + | Eapp ({ a_op = Earray; }, w_list, None) -> + Sarray (form_new_consts w_list) + + | Estruct w_list -> + Srecord (List.map (fun (f, w) -> f, form_new_const_w w) w_list) + + | _ -> raise Errors.Fallback + in + mk_static_exp ~loc:e.e_loc e.e_ty se_d + + and form_new_consts w_list = List.map form_new_const_w w_list + + and form_new_const_w w = + let mk_exp w = + mk_exp w.w_ck w.w_ty ~linearity:w.w_linearity ~ck:w.w_ck ~ct:(Ck w.w_ck) (Eextvalue w) in + form_new_const (mk_exp w) + + and form_new_extvalue_eq _ n eq = match eq.eq_rhs.e_desc with + | Eextvalue _ -> (eq, n) + | _ -> + try + let w = form_new_extvalue eq.eq_rhs in + let e = { eq.eq_rhs with e_desc = Eextvalue w; } in + { eq with eq_rhs = e; }, n + 1 + with Errors.Fallback -> + eq, n + in + + let funs = { Mls_mapfold.defaults with Mls_mapfold.eq = form_new_extvalue_eq; } in + let nd, n = Mls_mapfold.node_dec funs 0 nd in + nd, n > 0 + +let compute_needed nd = + let compute_needed_edesc funs ids e_d = + let e_d, ids = Mls_mapfold.edesc funs ids e_d in + e_d, + (match e_d with + | Emerge (x, _) -> IdentSet.add x ids + | Ewhen (_, _, x) -> IdentSet.add x ids + | Eapp (_, _, Some x) -> IdentSet.add x ids + | _ -> ids) + + and compute_needed_node funs ids nd = + let nd, ids = Mls_mapfold.node_dec funs ids nd in + nd, (List.fold_left (fun ids v -> IdentSet.add v.v_ident ids) ids nd.n_output) in + + let funs = + { Mls_mapfold.defaults with + Mls_mapfold.node_dec = compute_needed_node; + Mls_mapfold.edesc = compute_needed_edesc; } in + snd (Mls_mapfold.node_dec_it funs IdentSet.empty nd) + +let id_set_of_env nd env = + let needed = compute_needed nd in + let add id _ ids = if IdentSet.mem id needed then ids else IdentSet.add id ids in + Env.fold add env IdentSet.empty + +let rec node funs () nd = + let env = gather_extvalues_node nd in + (* Format.eprintf "=> %d@." (Env.fold (fun _ _ n -> n + 1) env 0); *) + (* Env.fold (fun x w () -> Format.eprintf "%a => @[%a@]@." print_ident x print_extvalue w) env (); *) + let nd = inline_extvalue_node env nd in + let nd = remove_eqs_from_node nd (id_set_of_env nd env) in + (* IdentSet.iter (fun id -> Format.eprintf "%a@." print_ident id) (id_set_of_env nd env); *) + let nd, changed = form_new_extvalue_node nd in + if changed then node funs () nd else (nd, ()) + +let program program = + let funs = { Mls_mapfold.defaults with Mls_mapfold.node_dec = node; } in + let program, () = Mls_mapfold.program funs () program in + program