From b53e5789bce3cd595072ae1d31d7fb387c67d2b9 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Wed, 23 Dec 2015 16:24:52 +0000 Subject: [PATCH] Move split_default_wrapper to Simplif --- .depend | 20 +++++++++------- asmcomp/closure.ml | 56 +------------------------------------------- bytecomp/simplif.ml | 54 ++++++++++++++++++++++++++++++++++++++++++ bytecomp/simplif.mli | 8 +++++++ 4 files changed, 74 insertions(+), 64 deletions(-) diff --git a/.depend b/.depend index f976ce1ee..6e94e0c8a 100644 --- a/.depend +++ b/.depend @@ -462,7 +462,7 @@ bytecomp/meta.cmi : bytecomp/instruct.cmi bytecomp/printinstr.cmi : bytecomp/instruct.cmi bytecomp/printlambda.cmi : bytecomp/lambda.cmi bytecomp/runtimedef.cmi : -bytecomp/simplif.cmi : bytecomp/lambda.cmi +bytecomp/simplif.cmi : bytecomp/lambda.cmi typing/ident.cmi bytecomp/switch.cmi : bytecomp/symtable.cmi : utils/misc.cmi typing/ident.cmi \ bytecomp/cmo_format.cmi @@ -770,15 +770,17 @@ asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \ bytecomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi asmcomp/closure.cmo : utils/warnings.cmi utils/tbl.cmi bytecomp/switch.cmi \ - typing/primitive.cmi utils/misc.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi bytecomp/debuginfo.cmi \ - asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \ - parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/closure.cmi + bytecomp/simplif.cmi typing/primitive.cmi utils/misc.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ + bytecomp/debuginfo.cmi asmcomp/compilenv.cmi utils/clflags.cmi \ + asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ + asmcomp/closure.cmi asmcomp/closure.cmx : utils/warnings.cmx utils/tbl.cmx bytecomp/switch.cmx \ - typing/primitive.cmx utils/misc.cmx parsing/location.cmx \ - bytecomp/lambda.cmx typing/ident.cmx bytecomp/debuginfo.cmx \ - asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \ - parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/closure.cmi + bytecomp/simplif.cmx typing/primitive.cmx utils/misc.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ + bytecomp/debuginfo.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ + asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ + asmcomp/closure.cmi asmcomp/cmmgen.cmo : typing/types.cmi bytecomp/switch.cmi \ asmcomp/strmatch.cmi asmcomp/proc.cmi typing/primitive.cmi utils/misc.cmi \ bytecomp/lambda.cmi typing/ident.cmi bytecomp/debuginfo.cmi \ diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 6ee617bbe..3d427ae8a 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -93,60 +93,6 @@ let occurs_var var u = true in occurs u -(* Split a function with default parameters into a wrapper and an - inner function. The wrapper fills in missing optional parameters - with their default value and tail-calls the inner function. The - wrapper can then hopefully be inlined on most call sites to avoid - the overhead associated with boxing an optional argument with a - 'Some' constructor, only to deconstruct it immediately in the - function's body. *) - -let split_default_wrapper fun_id kind params body attr = - let rec aux map = function - | Llet(Strict, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when - Ident.name optparam = "*opt*" && List.mem optparam params - && not (List.mem_assoc optparam map) - -> - let wrapper_body, inner = aux ((optparam, id) :: map) rest in - Llet(Strict, id, def, wrapper_body), inner - | _ when map = [] -> raise Exit - | body -> - (* Check that those *opt* identifiers don't appear in the remaining - body. This should not appear, but let's be on the safe side. *) - let fv = Lambda.free_variables body in - List.iter (fun (id, _) -> if IdentSet.mem id fv then raise Exit) map; - - let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in - let map_param p = try List.assoc p map with Not_found -> p in - let args = List.map (fun p -> Lvar (map_param p)) params in - let wrapper_body = - Lapply {ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=Lvar inner_id; - ap_args=args; - ap_inlined=Default_inline} - in - - let inner_params = List.map map_param params in - let new_ids = List.map Ident.rename inner_params in - let subst = List.fold_left2 - (fun s id new_id -> - Ident.add id (Lvar new_id) s) - Ident.empty inner_params new_ids - in - let body = Lambda.subst_lambda subst body in - let inner_fun = Lfunction{kind = Curried; params = new_ids; body; - attr} in - (wrapper_body, (inner_id, inner_fun)) - in - try - let wrapper_body, inner = aux [] body in - [(fun_id, Lfunction{kind; params; body = wrapper_body; - attr = default_function_attribute}); inner] - with Exit -> - [(fun_id, Lfunction{kind; params; body; attr})] - - (* Determine whether the estimated size of a clambda term is below some threshold *) @@ -1113,7 +1059,7 @@ and close_functions fenv cenv fun_defs = (List.map (function | (id, Lfunction{kind; params; body; attr}) -> - split_default_wrapper id kind params body attr + Simplif.split_default_wrapper id kind params body attr | _ -> assert false ) fun_defs) diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index eaf689c8d..aa2cd0163 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -610,6 +610,60 @@ and list_emit_tail_infos_fun f is_tail = and list_emit_tail_infos is_tail = List.iter (emit_tail_infos is_tail) +(* Split a function with default parameters into a wrapper and an + inner function. The wrapper fills in missing optional parameters + with their default value and tail-calls the inner function. The + wrapper can then hopefully be inlined on most call sites to avoid + the overhead associated with boxing an optional argument with a + 'Some' constructor, only to deconstruct it immediately in the + function's body. *) + +let split_default_wrapper fun_id kind params body attr = + let rec aux map = function + | Llet(Strict, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when + Ident.name optparam = "*opt*" && List.mem optparam params + && not (List.mem_assoc optparam map) + -> + let wrapper_body, inner = aux ((optparam, id) :: map) rest in + Llet(Strict, id, def, wrapper_body), inner + | _ when map = [] -> raise Exit + | body -> + (* Check that those *opt* identifiers don't appear in the remaining + body. This should not appear, but let's be on the safe side. *) + let fv = Lambda.free_variables body in + List.iter (fun (id, _) -> if IdentSet.mem id fv then raise Exit) map; + + let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in + let map_param p = try List.assoc p map with Not_found -> p in + let args = List.map (fun p -> Lvar (map_param p)) params in + let wrapper_body = + Lapply { + ap_func = Lvar inner_id; + ap_args = args; + ap_loc = Location.none; + ap_should_be_tailcall = false; + ap_inlined = Default_inline; + } + in + let inner_params = List.map map_param params in + let new_ids = List.map Ident.rename inner_params in + let subst = List.fold_left2 + (fun s id new_id -> + Ident.add id (Lvar new_id) s) + Ident.empty inner_params new_ids + in + let body = Lambda.subst_lambda subst body in + let inner_fun = + Lfunction { kind = Curried; params = new_ids; body; attr; } + in + (wrapper_body, (inner_id, inner_fun)) + in + try + let wrapper_body, inner = aux [] body in + [(fun_id, Lfunction{kind; params; body = wrapper_body; attr}); inner] + with Exit -> + [(fun_id, Lfunction{kind; params; body; attr})] + (* The entry point: simplification + emission of tailcall annotations, if needed. *) diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli index 4cc6dab97..7a1bdd8c5 100644 --- a/bytecomp/simplif.mli +++ b/bytecomp/simplif.mli @@ -19,6 +19,14 @@ open Lambda val simplify_lambda: lambda -> lambda +val split_default_wrapper + : Ident.t + -> function_kind + -> Ident.t list + -> lambda + -> function_attribute + -> (Ident.t * lambda) list + (* To be filled by asmcomp/selectgen.ml *) val is_tail_native_heuristic: (int -> bool) ref (* # arguments -> can tailcall *)