Move split_default_wrapper to Simplif
Mark Shinwell
parent
825bc346e8
commit
b53e5789bc
20
.depend
20
.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 \
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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. *)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 *)
|
||||
|
|
|
|||
Loading…
Reference in New Issue