232 lines
9.2 KiB
OCaml
232 lines
9.2 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* OCaml *)
|
|
(* *)
|
|
(* Pierre Chambart, OCamlPro *)
|
|
(* Mark Shinwell and Leo White, Jane Street Europe *)
|
|
(* *)
|
|
(* Copyright 2013--2016 OCamlPro SAS *)
|
|
(* Copyright 2014--2016 Jane Street Group LLC *)
|
|
(* *)
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
(* special exception on linking described in the file LICENSE. *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
|
|
|
|
let pass_name = "remove-unused-arguments"
|
|
let () = Clflags.all_passes := pass_name :: !Clflags.all_passes
|
|
|
|
let rename_var var =
|
|
Variable.rename var
|
|
~current_compilation_unit:(Compilation_unit.get_current_exn ())
|
|
|
|
let remove_params unused (fun_decl: Flambda.function_declaration) =
|
|
let unused_params, used_params =
|
|
List.partition (fun v -> Variable.Set.mem v unused) fun_decl.params
|
|
in
|
|
let unused_params = List.filter (fun v ->
|
|
Variable.Set.mem v fun_decl.free_variables) unused_params
|
|
in
|
|
let body =
|
|
List.fold_left (fun body var ->
|
|
Flambda.create_let var (Const (Const_pointer 0)) body)
|
|
fun_decl.body
|
|
unused_params
|
|
in
|
|
Flambda.create_function_declaration ~params:used_params ~body
|
|
~stub:fun_decl.stub ~dbg:fun_decl.dbg ~inline:fun_decl.inline
|
|
~specialise:fun_decl.specialise ~is_a_functor:fun_decl.is_a_functor
|
|
|
|
let make_stub unused var (fun_decl : Flambda.function_declaration)
|
|
~specialised_args ~additional_specialised_args =
|
|
let renamed = rename_var var in
|
|
let args' =
|
|
List.map (fun var -> var, rename_var var) fun_decl.params
|
|
in
|
|
let used_args' =
|
|
List.filter (fun (var, _) -> not (Variable.Set.mem var unused)) args'
|
|
in
|
|
let args_renaming = Variable.Map.of_list args' in
|
|
let additional_specialised_args =
|
|
List.fold_left (fun additional_specialised_args (original_arg,arg) ->
|
|
match Variable.Map.find original_arg specialised_args with
|
|
| exception Not_found -> additional_specialised_args
|
|
| (outer_var : Flambda.specialised_to) ->
|
|
(* CR-soon mshinwell: share with Augment_specialised_args *)
|
|
let outer_var : Flambda.specialised_to =
|
|
match outer_var.projection with
|
|
| None -> outer_var
|
|
| Some projection ->
|
|
let projection =
|
|
Projection.map_projecting_from projection ~f:(fun var ->
|
|
match Variable.Map.find var args_renaming with
|
|
| exception Not_found ->
|
|
(* Must always be a parameter of this
|
|
[function_decl]. *)
|
|
assert false
|
|
| wrapper_arg -> wrapper_arg)
|
|
in
|
|
{ outer_var with
|
|
projection = Some projection;
|
|
}
|
|
in
|
|
Variable.Map.add arg outer_var additional_specialised_args)
|
|
additional_specialised_args args'
|
|
in
|
|
let args = List.map (fun (_, var) -> var) used_args' in
|
|
let kind = Flambda.Direct (Closure_id.wrap renamed) in
|
|
let dbg = fun_decl.dbg in
|
|
let body : Flambda.t =
|
|
Apply {
|
|
func = renamed;
|
|
args;
|
|
kind;
|
|
dbg;
|
|
inline = Default_inline;
|
|
specialise = Default_specialise;
|
|
}
|
|
in
|
|
let function_decl =
|
|
Flambda.create_function_declaration ~params:(List.map snd args') ~body
|
|
~stub:true ~dbg:fun_decl.dbg ~inline:fun_decl.inline
|
|
~specialise:fun_decl.specialise ~is_a_functor:fun_decl.is_a_functor
|
|
in
|
|
function_decl, renamed, additional_specialised_args
|
|
|
|
let separate_unused_arguments ~only_specialised
|
|
~backend ~(set_of_closures : Flambda.set_of_closures) =
|
|
let function_decls = set_of_closures.function_decls in
|
|
let unused = Invariant_params.unused_arguments ~backend function_decls in
|
|
let non_stub_arguments =
|
|
Variable.Map.fold (fun _ (decl : Flambda.function_declaration) acc ->
|
|
if decl.stub then
|
|
acc
|
|
else
|
|
Variable.Set.union acc (Variable.Set.of_list decl.Flambda.params))
|
|
function_decls.funs Variable.Set.empty
|
|
in
|
|
let unused = Variable.Set.inter non_stub_arguments unused in
|
|
let specialised_args = Variable.Map.keys set_of_closures.specialised_args in
|
|
let unused =
|
|
if only_specialised then Variable.Set.inter specialised_args unused
|
|
else unused
|
|
in
|
|
if Variable.Set.is_empty unused
|
|
then None
|
|
else begin
|
|
let funs, additional_specialised_args =
|
|
Variable.Map.fold (fun fun_id (fun_decl : Flambda.function_declaration)
|
|
(funs, additional_specialised_args) ->
|
|
if List.exists (fun v -> Variable.Set.mem v unused) fun_decl.params
|
|
then begin
|
|
let stub, renamed_fun_id, additional_specialised_args =
|
|
make_stub unused fun_id fun_decl
|
|
~specialised_args:set_of_closures.specialised_args
|
|
~additional_specialised_args
|
|
in
|
|
let cleaned = remove_params unused fun_decl in
|
|
Variable.Map.add fun_id stub
|
|
(Variable.Map.add renamed_fun_id cleaned funs),
|
|
additional_specialised_args
|
|
end
|
|
else
|
|
Variable.Map.add fun_id fun_decl funs,
|
|
additional_specialised_args
|
|
)
|
|
function_decls.funs (Variable.Map.empty, Variable.Map.empty)
|
|
in
|
|
let specialised_args =
|
|
Variable.Map.disjoint_union additional_specialised_args
|
|
(Variable.Map.filter (fun param _ ->
|
|
not (Variable.Set.mem param unused))
|
|
set_of_closures.specialised_args)
|
|
in
|
|
let specialised_args =
|
|
Flambda_utils.clean_projections ~which_variables:specialised_args
|
|
in
|
|
let function_decls =
|
|
Flambda.update_function_declarations function_decls ~funs
|
|
in
|
|
let set_of_closures =
|
|
Flambda.create_set_of_closures ~function_decls
|
|
~free_vars:set_of_closures.free_vars ~specialised_args
|
|
(* CR-soon mshinwell: Use direct_call_surrogates for this
|
|
transformation. *)
|
|
~direct_call_surrogates:set_of_closures.direct_call_surrogates
|
|
in
|
|
Some set_of_closures
|
|
end
|
|
|
|
(* Splitting is not always beneficial. For instance when a function
|
|
is only indirectly called, suppressing unused arguments does not
|
|
benefit, and introduce an useless intermediate call. Specialised
|
|
args should always be beneficial since they should not be used in
|
|
indirect calls. *)
|
|
let should_split_only_specialised_args
|
|
(fun_decls : Flambda.function_declarations)
|
|
~backend =
|
|
if not !Clflags.remove_unused_arguments then begin
|
|
true
|
|
end else begin
|
|
let no_recursive_functions =
|
|
Variable.Set.is_empty
|
|
(Find_recursive_functions.in_function_declarations fun_decls ~backend)
|
|
in
|
|
let number_of_non_stub_functions =
|
|
Variable.Map.cardinal
|
|
(Variable.Map.filter (fun _ { Flambda.stub } -> not stub)
|
|
fun_decls.funs)
|
|
in
|
|
(* CR-soon lwhite: this criteria could use some justification.
|
|
mshinwell: pchambart cannot remember how these criteria arose,
|
|
but we're going to leave this as-is for 4.03. *)
|
|
no_recursive_functions && (number_of_non_stub_functions <= 1)
|
|
end
|
|
|
|
let separate_unused_arguments_in_set_of_closures set_of_closures ~backend =
|
|
let dump = Clflags.dumped_pass pass_name in
|
|
let only_specialised =
|
|
should_split_only_specialised_args
|
|
set_of_closures.Flambda.function_decls
|
|
~backend
|
|
in
|
|
match separate_unused_arguments
|
|
~only_specialised ~backend ~set_of_closures with
|
|
| None ->
|
|
if dump then
|
|
Format.eprintf "No change for Remove_unused_arguments:@ %a@.@."
|
|
Flambda.print_set_of_closures set_of_closures;
|
|
None
|
|
| Some result ->
|
|
if dump then
|
|
Format.eprintf "Before Remove_unused_arguments:@ %a@.@.\
|
|
After Remove_unused_arguments:@ %a@.@."
|
|
Flambda.print_set_of_closures set_of_closures
|
|
Flambda.print_set_of_closures result;
|
|
Some result
|
|
|
|
let separate_unused_arguments_in_closures_expr tree ~backend =
|
|
let aux_named (named : Flambda.named) : Flambda.named =
|
|
match named with
|
|
| Set_of_closures set_of_closures -> begin
|
|
let only_specialised =
|
|
should_split_only_specialised_args
|
|
set_of_closures.function_decls
|
|
~backend
|
|
in
|
|
match separate_unused_arguments
|
|
~only_specialised ~backend ~set_of_closures with
|
|
| None -> named
|
|
| Some set_of_closures -> Set_of_closures set_of_closures
|
|
end
|
|
| e -> e
|
|
in
|
|
Flambda_iterators.map_named aux_named tree
|
|
|
|
let separate_unused_arguments_in_closures program ~backend =
|
|
Flambda_iterators.map_exprs_at_toplevel_of_program program ~f:(fun expr ->
|
|
separate_unused_arguments_in_closures_expr expr ~backend)
|