From 964f6ca6050712b76b6e6c75cca227686054abf8 Mon Sep 17 00:00:00 2001 From: Adrien Guatto Date: Thu, 26 Jan 2012 13:21:17 +0100 Subject: [PATCH] Extvalue inlining: fix point computation --- .../transformations/inline_extvalues.ml | 24 ++++++++++++------- compiler/minils/transformations/tomato.ml | 9 ++++--- 2 files changed, 22 insertions(+), 11 deletions(-) diff --git a/compiler/minils/transformations/inline_extvalues.ml b/compiler/minils/transformations/inline_extvalues.ml index a31026b..3f60860 100644 --- a/compiler/minils/transformations/inline_extvalues.ml +++ b/compiler/minils/transformations/inline_extvalues.ml @@ -35,7 +35,7 @@ open Mls_compare let gather_extvalues_node nd = let ty_env = - let add env vd = Env.add vd.v_ident vd.v_type env in + let add env vd = Env.add vd.v_ident vd.v_linearity env in let add_l env vd_list = List.fold_left add env vd_list in (add_l (add_l (add_l Env.empty nd.n_output) nd.n_local) nd.n_input) in @@ -51,7 +51,7 @@ let gather_extvalues_node nd = in match var_of_extvalue w with | Some x -> - let { v_linearity = lin; } = Mls_utils.find_var_node nd x in + let lin = Env.find x ty_env in Linearity.is_linear lin | _ -> false in @@ -84,7 +84,9 @@ let inline_extvalue_node env nd = in let inline_edesc env funs () e_d = - let e_d, () = Mls_mapfold.edesc funs () e_d in + let e_d', () = Mls_mapfold.edesc funs () e_d in + Format.eprintf "From %a to %a@." print_exp_desc e_d print_exp_desc e_d'; + let e_d = e_d' in (try match e_d with | Emerge (x, cl) -> Emerge (find_sampler env x, cl) | Ewhen (e, v, x) -> Ewhen (e, v, find_sampler env x) @@ -104,15 +106,18 @@ let inline_extvalue_node env nd = let env = let funs = { Mls_mapfold.defaults with + Mls_mapfold.extvalue_desc = inline_extvalue_desc env; + Mls_mapfold.edesc = inline_edesc env; Mls_mapfold.global_funs = { Global_mapfold.defaults with - Global_mapfold.ck = inline_ck env; }; - Mls_mapfold.edesc = inline_edesc env; - Mls_mapfold.extvalue_desc = inline_extvalue_desc env; } in + Global_mapfold.ck = inline_ck env; }; } in let tclose x w new_env = - let w, () = Mls_mapfold.extvalue funs () w in - Env.add x w new_env + let rec fix w = + let w', () = Mls_mapfold.extvalue funs () w in + if Mls_compare.extvalue_compare w w' = 0 then w else fix w' + in + Env.add x (fix w) new_env in Env.fold tclose env Env.empty in @@ -228,6 +233,9 @@ let id_set_of_env nd env = let rec node funs () nd = let env = gather_extvalues_node nd in + (* Format.eprintf "Env:@\n"; *) + (* Env.iter (fun k w -> Format.eprintf " %a => %a@\n" print_ident k print_extvalue w) env; *) + (* Format.eprintf "@."; *) let nd = inline_extvalue_node env nd in let nd = remove_eqs_from_node nd (id_set_of_env nd env) in let nd, changed = form_new_extvalue_node nd in diff --git a/compiler/minils/transformations/tomato.ml b/compiler/minils/transformations/tomato.ml index 4455871..0044870 100644 --- a/compiler/minils/transformations/tomato.ml +++ b/compiler/minils/transformations/tomato.ml @@ -310,7 +310,7 @@ let new_name mapping x = with Not_found -> x (* Takes a tomato env and returns a renaming environment *) -let construct_mapping (tenv, cenv) = +let construct_mapping (_, cenv) = let construct_mapping_eq_repr _ eq_repr_list mapping = let rec ty_list_of_ty ty acc = match ty with | Tprod ty_list -> List.fold_right ty_list_of_ty ty_list acc @@ -339,7 +339,7 @@ let construct_mapping (tenv, cenv) = let fused_ident_list = List.map (Misc.fold_right_1 concat_idents) idents_list in Misc.fold_left4 - (fun mapping x_list fused_x ty ck -> + (fun mapping x_list fused_x _ _ -> List.fold_left (fun mapping x -> Env.add x (Info fused_x) mapping) @@ -523,7 +523,9 @@ let compute_new_class (tenv : tom_env) = let add_eq_repr _ eqr classes = let map_class_ref cref = match cref with | Cr_input _ -> None - | Cr_plain x -> Some (Env.find x mapping) + | Cr_plain x -> + try Some (Env.find x mapping) + with Not_found -> Format.eprintf "Unknown class %a@." print_ident x; assert false in let children = List.map map_class_ref eqr.er_children in @@ -598,6 +600,7 @@ let update_node nd = ignore (Modules.replace_value nd.n_name sign) let node nd = + debug_do (fun () -> Format.eprintf "Minimizing %a@." print_qualname nd.n_name); Idents.enter_node nd.n_name; (* Initial environment *)