Extvalue inlining: fix point computation
This commit is contained in:
parent
a7e3f4a973
commit
964f6ca605
2 changed files with 22 additions and 11 deletions
|
@ -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
|
||||
|
|
|
@ -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 *)
|
||||
|
|
Loading…
Reference in a new issue