Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Update middle_end/ for recent changes from flambda_trunk

master
Mark Shinwell 2016-01-12 13:38:52 +01:00
parent 22f35f12b7
commit b7df26e34b
20 changed files with 1170 additions and 665 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
middle_end/alias_analysis.ml
View File

@ -38,12 +38,11 @@ type constant_defining_value =
type initialize_symbol_field = Variable.t option
type definitions =
{
variable : constant_defining_value Variable.Tbl.t;
initialize_symbol : initialize_symbol_field list Symbol.Tbl.t;
symbol : Flambda.constant_defining_value Symbol.Tbl.t;
}
type definitions = {
variable : constant_defining_value Variable.Tbl.t;
initialize_symbol : initialize_symbol_field list Symbol.Tbl.t;
symbol : Flambda.constant_defining_value Symbol.Tbl.t;
}
let print_constant_defining_value ppf = function
| Allocated_const (Normal const) -> Allocated_const.print ppf const
@ -71,7 +70,8 @@ let print_constant_defining_value ppf = function
let rec resolve_definition
(definitions: definitions)
(var: Variable.t)
(def: constant_defining_value) : allocation_point =
(def: constant_defining_value)
~the_dead_constant : allocation_point =
match def with
| Allocated_const _
| Block _
@ -82,41 +82,39 @@ let rec resolve_definition
Variable var
| Project_var {var} ->
fetch_variable definitions (Var_within_closure.unwrap var)
~the_dead_constant
| Variable v ->
fetch_variable definitions v
~the_dead_constant
| Symbol sym -> Symbol sym
| Field (v, n) ->
begin match fetch_variable definitions v with
begin match fetch_variable definitions v ~the_dead_constant with
| Symbol s ->
fetch_symbol_field definitions s n
fetch_symbol_field definitions s n ~the_dead_constant
| Variable v ->
fetch_variable_field definitions v n
fetch_variable_field definitions v n ~the_dead_constant
end
| Symbol_field (symbol, field) ->
fetch_symbol_field definitions symbol field
fetch_symbol_field definitions symbol field ~the_dead_constant
and fetch_variable
(definitions: definitions)
(var: Variable.t) : allocation_point =
(var: Variable.t)
~the_dead_constant : allocation_point =
match Variable.Tbl.find definitions.variable var with
| exception Not_found -> Variable var
| def ->
resolve_definition definitions var def
| def -> resolve_definition definitions var def ~the_dead_constant
and fetch_variable_field
(definitions: definitions)
(var: Variable.t)
(field: int) : allocation_point =
(field: int)
~the_dead_constant : allocation_point =
match Variable.Tbl.find definitions.variable var with
| Block (_, fields) ->
begin match List.nth fields field with
| exception Not_found ->
(* CR mshinwell for pchambart: Maybe we need to harden this module so that
it doesn't go wrong when compiling dead code? (In the same way as
[Inline_and_simplify])? *)
Misc.fatal_errorf "No field %i in block %a" field Variable.print var
| v ->
fetch_variable definitions v
| exception Not_found -> Symbol the_dead_constant
| v -> fetch_variable definitions v ~the_dead_constant
end
| exception Not_found ->
Misc.fatal_errorf "No definition for field access to %a" Variable.print var
@ -125,41 +123,43 @@ and fetch_variable_field
assert false
| Const _ | Allocated_const _
| Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ ->
Misc.fatal_errorf "Field access to %a which is not a block" Variable.print var
Symbol the_dead_constant
and fetch_symbol_field
(definitions: definitions)
(sym: Symbol.t)
(field: int) : allocation_point =
(field: int)
~the_dead_constant : allocation_point =
match Symbol.Tbl.find definitions.symbol sym with
| Block (_, fields) ->
begin match List.nth fields field with
| exception Not_found ->
Misc.fatal_errorf "No field %i in block %a" field Symbol.print sym
| Symbol s ->
Symbol s
| Const _ ->
Symbol sym
| exception Not_found -> Symbol the_dead_constant
| Symbol s -> Symbol s
| Const _ -> Symbol sym
end
| exception Not_found -> begin
match Symbol.Tbl.find definitions.initialize_symbol sym with
| fields -> begin
match List.nth fields field with
| None ->
Misc.fatal_errorf "field access to a not constant %a" Symbol.print sym
| Some v ->
fetch_variable definitions v
| exception Not_found ->
begin match Symbol.Tbl.find definitions.initialize_symbol sym with
| fields ->
begin match List.nth fields field with
| None ->
Misc.fatal_errorf "constant field access to an inconstant %a"
Symbol.print sym
| Some v ->
fetch_variable definitions v ~the_dead_constant
end
| exception Not_found ->
Misc.fatal_errorf "No definition for field access to %a" Symbol.print sym
Misc.fatal_errorf "No definition for field access to %a"
Symbol.print sym
end
| Allocated_const _ | Set_of_closures _ | Project_closure _ ->
Misc.fatal_errorf "Field access to %a which is not a block" Symbol.print sym
Symbol the_dead_constant
let run variable initialize_symbol symbol =
let run variable initialize_symbol symbol ~the_dead_constant =
let definitions = { variable; initialize_symbol; symbol; } in
Variable.Tbl.fold (fun var definition result ->
let definition = resolve_definition definitions var definition in
let definition =
resolve_definition definitions var definition ~the_dead_constant
in
Variable.Map.add var definition result)
definitions.variable
Variable.Map.empty

7
middle_end/alias_analysis.mli
View File

@ -43,11 +43,16 @@ type initialize_symbol_field = Variable.t option
been assigned to symbols. The return value gives the assignment
of the defining values of constants to variables.
Also see comments for [Lift_constants], whose input feeds this
pass. *)
pass.
Variables found to be ill-typed accesses to other constants, for
example arising from dead code, will be pointed at [the_dead_constant].
*)
val run
: constant_defining_value Variable.Tbl.t
-> initialize_symbol_field list Symbol.Tbl.t
-> Flambda.constant_defining_value Symbol.Tbl.t
-> the_dead_constant:Symbol.t
-> allocation_point Variable.Map.t
val print_constant_defining_value

36
middle_end/flambda.ml
View File

@ -479,8 +479,8 @@ let print_program ppf program =
program.imported_symbols;
print_program_body ppf program.program_body
let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_in_project_var
~all_used_variables tree =
let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument
?ignore_uses_in_project_var ~all_used_variables tree =
match tree with
| Var var -> Variable.Set.singleton var
| _ ->
@ -498,21 +498,25 @@ let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_in_project_var
| None -> free_variable func
| Some () -> ()
end;
List.iter free_variable args
begin match ignore_uses_as_argument with
| None -> List.iter free_variable args
| Some () -> ()
end
| Let { var; free_vars_of_defining_expr; free_vars_of_body;
defining_expr; body; _ } ->
bound_variable var;
if all_used_variables
|| ignore_uses_as_callee <> None
|| ignore_uses_as_argument <> None
|| ignore_uses_in_project_var <> None then begin
(* In these cases we can't benefit from the pre-computed free
variable sets. *)
free_variables
(variables_usage_named ?ignore_uses_in_project_var ?ignore_uses_as_callee
~all_used_variables defining_expr);
?ignore_uses_as_argument ~all_used_variables defining_expr);
free_variables
(variables_usage ?ignore_uses_as_callee ?ignore_uses_in_project_var
~all_used_variables body)
(variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument
?ignore_uses_in_project_var ~all_used_variables body)
end
else begin
free_variables free_vars_of_defining_expr;
@ -575,7 +579,7 @@ let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_in_project_var
Variable.Set.diff !free !bound
and variables_usage_named ?ignore_uses_in_project_var
?ignore_uses_as_callee
?ignore_uses_as_callee ?ignore_uses_as_argument
~all_used_variables named =
let free = ref Variable.Set.empty in
let free_variable fv = free := Variable.Set.add fv !free in
@ -600,21 +604,25 @@ and variables_usage_named ?ignore_uses_in_project_var
free_variable closure
| Prim (_, args, _) -> List.iter free_variable args
| Expr flam ->
free := Variable.Set.union (variables_usage ?ignore_uses_as_callee ~all_used_variables flam) !free
free := Variable.Set.union
(variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument
~all_used_variables flam) !free
end;
!free
let free_variables ?ignore_uses_as_callee ?ignore_uses_in_project_var tree =
variables_usage ?ignore_uses_as_callee ?ignore_uses_in_project_var
~all_used_variables:false tree
let free_variables ?ignore_uses_as_callee ?ignore_uses_as_argument
?ignore_uses_in_project_var tree =
variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument
?ignore_uses_in_project_var ~all_used_variables:false tree
let free_variables_named ?ignore_uses_in_project_var named =
variables_usage_named ?ignore_uses_in_project_var
~all_used_variables:false named
let used_variables ?ignore_uses_as_callee ?ignore_uses_in_project_var tree =
variables_usage ?ignore_uses_as_callee ?ignore_uses_in_project_var
~all_used_variables:true tree
let used_variables ?ignore_uses_as_callee ?ignore_uses_as_argument
?ignore_uses_in_project_var tree =
variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument
?ignore_uses_in_project_var ~all_used_variables:true tree
let used_variables_named ?ignore_uses_in_project_var named =
variables_usage_named ?ignore_uses_in_project_var

2
middle_end/flambda.mli
View File

@ -387,6 +387,7 @@ type program = {
*)
val free_variables
: ?ignore_uses_as_callee:unit
-> ?ignore_uses_as_argument:unit
-> ?ignore_uses_in_project_var:unit
-> t
-> Variable.Set.t
@ -401,6 +402,7 @@ val free_variables_named
for [Let]s). *)
val used_variables
: ?ignore_uses_as_callee:unit
-> ?ignore_uses_as_argument:unit
-> ?ignore_uses_in_project_var:unit
-> t
-> Variable.Set.t

9
middle_end/inline_and_simplify.ml
View File

@ -632,7 +632,7 @@ and simplify_set_of_closures original_env r
E.enter_closure closure_env ~closure_id:(Closure_id.wrap fid)
~inline_inside:
(Inlining_decision.should_inline_inside_declaration function_decl)
~where:Transform_set_of_closures_expression
~debuginfo:function_decl.dbg
~f:(fun body_env -> simplify body_env r function_decl.body)
in
let inline : Lambda.inline_attribute =
@ -798,7 +798,12 @@ and simplify_partial_application env r ~lhs_of_application
inline = Default_inline;
}
in
Flambda_utils.make_closure_declaration ~id:(Variable.create "partial_fun")
let closure_variable =
Variable.rename
~append:"_partial_fun"
(Closure_id.unwrap closure_id_being_applied)
in
Flambda_utils.make_closure_declaration ~id:closure_variable
~body
~params:remaining_args
in

33
middle_end/inline_and_simplify_aux.ml
View File

@ -244,21 +244,44 @@ module Env = struct
(* CR-soon mshinwell: this is a bit contorted (see use in
inlining_decision.ml) *)
let note_entering_closure t ~closure_id ~where =
let note_entering_closure t ~closure_id ~debuginfo =
{ t with
inlining_stats_closure_stack =
Inlining_stats.Closure_stack.note_entering_closure
t.inlining_stats_closure_stack ~closure_id ~where;
t.inlining_stats_closure_stack ~closure_id ~debuginfo;
}
let enter_closure t ~closure_id ~inline_inside ~where ~f =
let note_entering_call t ~closure_id ~debuginfo =
{ t with
inlining_stats_closure_stack =
Inlining_stats.Closure_stack.note_entering_call
t.inlining_stats_closure_stack ~closure_id ~debuginfo;
}
let note_entering_inlined t =
{ t with
inlining_stats_closure_stack =
Inlining_stats.Closure_stack.note_entering_inlined
t.inlining_stats_closure_stack;
}
let note_entering_specialised t ~closure_ids =
{ t with
inlining_stats_closure_stack =
Inlining_stats.Closure_stack.note_entering_specialised
t.inlining_stats_closure_stack ~closure_ids;
}
let enter_closure t ~closure_id ~inline_inside ~debuginfo ~f =
let t =
if inline_inside then t
else set_never_inline t
in
f (note_entering_closure t ~closure_id ~where)
f (note_entering_closure t ~closure_id ~debuginfo)
let inlining_stats_closure_stack t = t.inlining_stats_closure_stack
let record_decision t decision =
Inlining_stats.record_decision decision
~closure_stack:t.inlining_stats_closure_stack
end
let initial_inlining_threshold ~round : Inlining_cost.Threshold.t =

34
middle_end/inline_and_simplify_aux.mli
View File

@ -161,9 +161,29 @@ module Env : sig
val note_entering_closure
: t
-> closure_id:Closure_id.t
-> where:Inlining_stats_types.where_entering_closure
-> debuginfo:Debuginfo.t
-> t
(** If collecting inlining statistics, record that the inliner is about to
descend into a call to [closure_id]. This information enables us to
produce a stack of closures that form a kind of context around an
inlining decision point. *)
val note_entering_call
: t
-> closure_id:Closure_id.t
-> debuginfo:Debuginfo.t
-> t
(** If collecting inlining statistics, record that the inliner is about to
descend into an inlined function call. This requires that the inliner
has already entered the call with [note_entering_call]. *)
val note_entering_inlined : t -> t
(** If collecting inlining statistics, record that the inliner is about to
descend into a specialised function definition. This requires that the
inliner has already entered the call with [note_entering_call]. *)
val note_entering_specialised : t -> closure_ids:Closure_id.Set.t -> t
(** Update a given environment to record that the inliner is about to
descend into [closure_id] and pass the resulting environment to [f].
If [inline_inside] is [false] then the environment passed to [f] will be
@ -172,15 +192,17 @@ module Env : sig
: t
-> closure_id:Closure_id.t
-> inline_inside:bool
-> where:Inlining_stats_types.where_entering_closure
-> debuginfo:Debuginfo.t
-> f:(t -> 'a)
-> 'a
(** Return the closure stack, used for the generation of inlining statistics,
stored inside the given environment. *)
val inlining_stats_closure_stack
(** If collecting inlining statistics, record an inlining decision for the
call at the top of the closure stack stored inside the given
environment. *)
val record_decision
: t
-> Inlining_stats.Closure_stack.t
-> Inlining_stats_types.Decision.t
-> unit
(** Print a human-readable version of the given environment. *)
val print : Format.formatter -> t -> unit

178
middle_end/inlining_cost.ml
View File

@ -310,6 +310,55 @@ module Benefit = struct
let c2 = evaluate ~round t2 in
if c1 > c2 then t1 else t2
(* Print out a benefit as a table *)
let benefit_table =
[ "Calls", (fun b -> b.remove_call);
"Allocs", (fun b -> b.remove_alloc);
"Prims", (fun b -> b.remove_prim);
"Branches", (fun b -> b.remove_branch);
"Indirect calls", (fun b -> b.direct_call_of_indirect);
]
let benefits_table =
lazy begin
List.map
(fun (header, accessor) -> (header, accessor, String.length header))
benefit_table
end
let table_line =
lazy begin
let benefits_table = Lazy.force benefits_table in
let dashes =
List.map (fun (_, _, n) -> String.make n '-') benefits_table
in
"|-" ^ String.concat "-+-" dashes ^ "-|"
end
let table_headers =
lazy begin
let benefits_table = Lazy.force benefits_table in
let headers = List.map (fun (head, _, _) -> head) benefits_table in
"| " ^ String.concat " | " headers ^ " |"
end
let print_table_values ppf b =
let rec loop ppf = function
| [] -> Format.fprintf ppf "|"
| (_, accessor, width) :: rest ->
Format.fprintf ppf "| %*d %a" width (accessor b) loop rest
in
loop ppf (Lazy.force benefits_table)
let print_table ppf b =
let table_line = Lazy.force table_line in
let table_headers = Lazy.force table_headers in
Format.fprintf ppf
"@[<v>@[<h>%s@]@;@[<h>%s@]@;@[<h>%s@]@;@[<h>%a@]@;@[<h>%s@]@]"
table_line table_headers table_line
print_table_values b
table_line
end
module Whether_sufficient_benefit = struct
@ -345,40 +394,39 @@ module Whether_sufficient_benefit = struct
f = f (* is not nan *)
&& f >= 0.
let evaluate t =
let estimated_benefit =
if t.toplevel && t.lifting && t.branch_depth = 0 then begin
let lifting_benefit =
Clflags.Int_arg_helper.get ~key:t.round !Clflags.inline_lifting_benefit
let estimated_benefit t =
if t.toplevel && t.lifting && t.branch_depth = 0 then begin
let lifting_benefit =
Clflags.Int_arg_helper.get ~key:t.round !Clflags.inline_lifting_benefit
in
float (t.evaluated_benefit + lifting_benefit)
end else begin
(* The estimated benefit is the evaluated benefit times an
estimation of the probability that the branch does not matter
for performances (is cold). The probability is very roughtly
estimated by considering that for every branching the
sub-expressions has the same [1 / (1 + factor)] probability
[p] of being cold. Hence the probability for the current
call to be cold is [p ^ number of nested branch].
The probability is expressed as [1 / (1 + factor)] rather
than letting the user directly provide [p], since for every
positive value of [factor] [p] is in [0, 1]. *)
let branch_never_taken_estimated_probability =
let branch_inline_factor =
Clflags.Float_arg_helper.get ~key:t.round !Clflags.branch_inline_factor
in
float (t.evaluated_benefit + lifting_benefit)
end else begin
(* The estimated benefit is the evaluated benefit times an
estimation of the probability that the branch does not matter
for performances (is cold). The probability is very roughtly
estimated by considering that for every branching the
sub-expressions has the same [1 / (1 + factor)] probability
[p] of being cold. Hence the probability for the current
call to be cold is [p ^ number of nested branch].
(* CR pchambart to pchambart: change this assert to a warning *)
assert(correct_branch_factor branch_inline_factor);
1. /. (1. +. branch_inline_factor)
in
let call_estimated_probability =
branch_never_taken_estimated_probability ** float t.branch_depth
in
float t.evaluated_benefit *. call_estimated_probability
end
The probability is expressed as [1 / (1 + factor)] rather
than letting the user directly provide [p], since for every
positive value of [factor] [p] is in [0, 1]. *)
let branch_never_taken_estimated_probability =
let branch_inline_factor =
Clflags.Float_arg_helper.get ~key:t.round !Clflags.branch_inline_factor
in
(* CR pchambart to pchambart: change this assert to a warning *)
assert(correct_branch_factor branch_inline_factor);
1. /. (1. +. branch_inline_factor)
in
let call_estimated_probability =
branch_never_taken_estimated_probability ** float t.branch_depth
in
float t.evaluated_benefit *. call_estimated_probability
end
in
float t.new_size -. estimated_benefit <= float t.original_size
let evaluate t =
float t.new_size -. estimated_benefit t <= float t.original_size
let to_string t =
@ -410,6 +458,72 @@ module Whether_sufficient_benefit = struct
evaluated_benefit
t.branch_depth
(if evaluate t then "yes" else "no")
let print_description ~subfunctions ppf t =
let pr_intro ppf =
let estimate = if t.estimate then " at most" else "" in
Format.pp_print_text ppf
"Specialisation of the function body";
if subfunctions then
Format.pp_print_text ppf
", including speculative inlining of other functions,";
Format.pp_print_text ppf " removed";
Format.pp_print_text ppf estimate;
Format.pp_print_text ppf " the following operations:"
in
let lifting = t.toplevel && t.lifting && t.branch_depth = 0 in
let requested = t.benefit.requested_inline in
let pr_requested ppf =
if requested > 0 then begin
Format.pp_open_box ppf 0;
Format.pp_print_text ppf
"and inlined user-annotated functions worth ";
Format.fprintf ppf "%d." requested;
Format.pp_close_box ppf ();
Format.pp_print_cut ppf ();
Format.pp_print_cut ppf ()
end
in
let pr_lifting ppf =
if lifting then begin
Format.pp_open_box ppf 0;
Format.pp_print_text ppf
"Inlining the function would also \
lift some definitions to toplevel.";
Format.pp_close_box ppf ();
Format.pp_print_cut ppf ();
Format.pp_print_cut ppf ()
end
in
let total_benefit =
if lifting then
let lifting_benefit =
Clflags.Int_arg_helper.get ~key:t.round !Clflags.inline_lifting_benefit
in
t.evaluated_benefit + lifting_benefit
else t.evaluated_benefit
in
let expected_benefit = estimated_benefit t in
let size_change = t.new_size - t.original_size in
let result = if evaluate t then "less" else "greater" in
let pr_conclusion ppf =
Format.pp_print_text ppf "This gives a total benefit of ";
Format.pp_print_int ppf total_benefit;
Format.pp_print_text ppf ". At a branch depth of ";
Format.pp_print_int ppf t.branch_depth;
Format.pp_print_text ppf " this produces an expected benefit of ";
Format.fprintf ppf "%.1f" expected_benefit;
Format.pp_print_text ppf ". The new code has size ";
Format.pp_print_int ppf t.new_size;
Format.pp_print_text ppf ", giving a change in code size of ";
Format.pp_print_int ppf size_change;
Format.pp_print_text ppf ". The change in code size is ";
Format.pp_print_text ppf result;
Format.pp_print_text ppf " than the expected benefit."
in
Format.fprintf ppf "%t@,@[<v>@[<v 2>@;%a@]@;@;%t%t@]%t"
pr_intro Benefit.print_table t.benefit pr_requested pr_lifting pr_conclusion
end
let scale_inline_threshold_by = 8

2
middle_end/inlining_cost.mli
View File

@ -109,6 +109,8 @@ module Whether_sufficient_benefit : sig
val evaluate : t -> bool
val to_string : t -> string
val print_description : subfunctions:bool -> Format.formatter -> t -> unit
end
val scale_inline_threshold_by : int

579
middle_end/inlining_decision.ml
View File

@ -20,13 +20,18 @@ module R = Inline_and_simplify_aux.Result
module U = Flambda_utils
module W = Inlining_cost.Whether_sufficient_benefit
module T = Inlining_cost.Threshold
module S = Inlining_stats_types
module D = S.Decision
type inlining_result =
| Changed of (Flambda.t * R.t)
| Original
let inline_non_recursive env r ~function_decls ~lhs_of_application
~closure_id_being_applied ~(function_decl : Flambda.function_declaration)
~value_set_of_closures ~only_use_of_function ~original
~(args : Variable.t list) ~size_from_approximation ~simplify
~always_inline ~(inline_requested : Lambda.inline_attribute)
~(made_decision : Inlining_stats_types.Decision.t -> unit) =
~always_inline ~(inline_requested : Lambda.inline_attribute) =
(* When all of the arguments to the function being inlined are unknown, then
we cannot materially simplify the function. As such, we know what the
benefit of inlining it would be: just removing the call. In this case
@ -58,7 +63,7 @@ let inline_non_recursive env r ~function_decls ~lhs_of_application
let known_to_have_no_benefit =
if function_decl.stub || only_use_of_function || always_inline
|| (toplevel && branch_depth = 0) then
false
None
else if A.all_not_useful (E.find_list_exn env args) then
match size_from_approximation with
| Some body_size ->
@ -90,25 +95,24 @@ let inline_non_recursive env r ~function_decls ~lhs_of_application
~benefit
in
if (not (W.evaluate wsb)) then begin
made_decision (Tried (Copying_body (Evaluated wsb)));
true
end else false
Some
(S.Inlined.Not_inlined (Without_subfunctions wsb))
end else None
| None ->
(* The function is definitely too large to inline given that we don't
have any approximations for its arguments. Further, the body
should already have been simplified (inside its declaration), so
we also expect no gain from the code below that permits inlining
inside the body. *)
made_decision (Tried (Copying_body Evaluated_unspecialized));
true
Some (S.Inlined.Not_inlined Unspecialized)
else begin
(* There are useful approximations, so we should simplify. *)
false
None
end
in
if known_to_have_no_benefit then begin
None
end else begin
match known_to_have_no_benefit with
| Some descision -> (Original, (D.Nonrecursive descision))
| None -> begin
let body, r_inlined =
(* First we construct the code that would result from copying the body of
the function, without doing any further inlining upon it, to the call
@ -124,37 +128,7 @@ let inline_non_recursive env r ~function_decls ~lhs_of_application
(R.num_direct_applications r_inlined) - (R.num_direct_applications r)
in
assert (num_direct_applications_seen >= 0);
let keep_inlined_version =
if function_decl.stub then begin
made_decision (Inlined (Copying_body Stub));
true
end else if always_inline then begin
made_decision (Inlined (Copying_body Unconditionally));
true
end else if only_use_of_function then begin
made_decision (Inlined (Copying_body Decl_local_to_application));
true
end else begin
let sufficient_benefit =
W.create ~original body
~toplevel:(E.at_toplevel env)
~branch_depth:(E.branch_depth env)
~lifting:function_decl.Flambda.is_a_functor
~round:(E.round env)
~benefit:(R.benefit r_inlined)
in
let keep_inlined_version = W.evaluate sufficient_benefit in
let decision : Inlining_stats_types.Decision.t =
if keep_inlined_version then
Inlined (Copying_body (Evaluated sufficient_benefit))
else
Tried (Copying_body (Evaluated sufficient_benefit))
in
made_decision decision;
keep_inlined_version
end
in
if keep_inlined_version then begin
let keep_inlined_version decision =
(* Inlining the body of the function was sufficiently beneficial that we
will keep it, replacing the call site. We continue by allowing
further inlining within the inlined copy of the body. *)
@ -176,10 +150,7 @@ let inline_non_recursive env r ~function_decls ~lhs_of_application
(* [lift_lets_expr] aims to clean up bindings introduced by the
inlining. *)
let body = Lift_code.lift_lets_expr body ~toplevel:true in
let env =
E.note_entering_closure env ~closure_id:closure_id_being_applied
~where:Inline_by_copying_function_body
in
let env = E.note_entering_inlined env in
let env =
if function_decl.stub ||
(* Stub functions should not prevent other functions
@ -191,22 +162,16 @@ let inline_non_recursive env r ~function_decls ~lhs_of_application
then env
else E.inlining_level_up env
in
Some (simplify env r body)
end else if num_direct_applications_seen < 1 then begin
(* Inlining the body of the function did not appear sufficiently
beneficial; however, it may become so if we inline within the body
first. We try that next, unless it is known that there are were
no direct applications in the simplified body computed above, meaning
no opportunities for inlining. *)
None
end else begin
let body, r_inlined =
Inlining_transforms.inline_by_copying_function_body ~env
~r:(R.reset_benefit r)
~function_decls ~lhs_of_application ~closure_id_being_applied
~inline_requested ~function_decl ~args ~simplify
in
let wsb =
(Changed (simplify env r body), decision)
in
if function_decl.stub then
keep_inlined_version (D.Nonrecursive (Inlined Stub))
else if always_inline then
keep_inlined_version (D.Nonrecursive (Inlined Unconditionally))
else if only_use_of_function then
keep_inlined_version (D.Nonrecursive (Inlined Decl_local_to_application))
else begin
let sufficient_benefit =
W.create ~original body
~toplevel:(E.at_toplevel env)
~branch_depth:(E.branch_depth env)
@ -214,28 +179,60 @@ let inline_non_recursive env r ~function_decls ~lhs_of_application
~round:(E.round env)
~benefit:(R.benefit r_inlined)
in
let keep_inlined_version = W.evaluate wsb in
let decision : Inlining_stats_types.Decision.t =
if keep_inlined_version then
(* CR mshinwell: This "with_subfunctions" name isn't
descriptive enough. *)
Inlined (Copying_body_with_subfunctions (Evaluated wsb))
else
Tried (Copying_body_with_subfunctions (Evaluated wsb))
in
made_decision decision;
if keep_inlined_version then begin
Some (body, R.map_benefit r_inlined
(Inlining_cost.Benefit.(+) (R.benefit r)))
end
else begin
(* r_inlined contains an approximation that may be invalid for the
untransformed expression: it may reference functions that only
exists if the body of the function is in fact inlined.
If the function approximation contained an approximation that
does not depend on the actual values of its arguments, it
could be returned instead of [A.value_unknown]. *)
None
if W.evaluate sufficient_benefit then
keep_inlined_version
(D.Nonrecursive
(Inlined (Without_subfunctions sufficient_benefit)))
else if num_direct_applications_seen < 1 then begin
(* Inlining the body of the function did not appear sufficiently
beneficial; however, it may become so if we inline within the body
first. We try that next, unless it is known that there are were
no direct applications in the simplified body computed above, meaning
no opportunities for inlining. *)
let decision =
D.Nonrecursive
(Not_inlined (Without_subfunctions sufficient_benefit))
in
(Original, decision)
end else begin
let body, r_inlined =
Inlining_transforms.inline_by_copying_function_body ~env
~r:(R.reset_benefit r)
~function_decls ~lhs_of_application ~closure_id_being_applied
~inline_requested ~function_decl ~args ~simplify
in
let wsb =
W.create ~original body
~toplevel:(E.at_toplevel env)
~branch_depth:(E.branch_depth env)
~lifting:function_decl.Flambda.is_a_functor
~round:(E.round env)
~benefit:(R.benefit r_inlined)
in
if W.evaluate wsb then begin
let res =
(body, R.map_benefit r_inlined
(Inlining_cost.Benefit.(+) (R.benefit r)))
in
let decision =
D.Nonrecursive
(Inlined (With_subfunctions(sufficient_benefit, wsb)))
in
(Changed res, decision)
end
else begin
(* r_inlined contains an approximation that may be invalid for the
untransformed expression: it may reference functions that only
exists if the body of the function is in fact inlined.
If the function approximation contained an approximation that
does not depend on the actual values of its arguments, it
could be returned instead of [A.value_unknown]. *)
let decision =
D.Nonrecursive
(Not_inlined (With_subfunctions(sufficient_benefit, wsb)))
in
(Original, decision)
end
end
end
end
@ -243,56 +240,44 @@ let inline_non_recursive env r ~function_decls ~lhs_of_application
let unroll_recursive env r ~max_level ~lhs_of_application
~(function_decls : Flambda.function_declarations)
~closure_id_being_applied ~function_decl ~args ~simplify
~original
~(made_decision : Inlining_stats_types.Decision.t -> unit) =
let tried_unrolling = ref false in
let result =
if E.unrolling_allowed env && E.inlining_level env <= max_level then
let self_unrolling =
E.inside_set_of_closures_declaration function_decls.set_of_closures_id
env
~original =
if E.unrolling_allowed env && E.inlining_level env <= max_level then
let self_unrolling =
E.inside_set_of_closures_declaration function_decls.set_of_closures_id
env
in
if self_unrolling then
(* CR mshinwell for pchambart: Should we really completely
disallow this? (Maybe there should be a compiler option?) *)
(Original, S.Unrolled.Unrolling_not_tried)
else begin
let env = E.inside_unrolled_function env in
let body, r_inlined =
Inlining_transforms.inline_by_copying_function_body ~env
~r:(R.reset_benefit r) ~function_decls ~lhs_of_application
~inline_requested:Default_inline
~closure_id_being_applied ~function_decl ~args ~simplify
in
if self_unrolling then
(* CR mshinwell for pchambart: Should we really completely
disallow this? (Maybe there should be a compiler option?) *)
None
else begin
let env = E.inside_unrolled_function env in
let body, r_inlined =
Inlining_transforms.inline_by_copying_function_body ~env
~r:(R.reset_benefit r) ~function_decls ~lhs_of_application
~inline_requested:Default_inline
~closure_id_being_applied ~function_decl ~args ~simplify
let wsb =
W.create body ~original
~toplevel:(E.at_toplevel env)
~branch_depth:(E.branch_depth env)
~lifting:false
~round:(E.round env)
~benefit:(R.benefit r_inlined)
in
if W.evaluate wsb then begin
let r =
R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r))
in
tried_unrolling := true;
let wsb =
W.create body ~original
~toplevel:(E.at_toplevel env)
~branch_depth:(E.branch_depth env)
~lifting:false
~round:(E.round env)
~benefit:(R.benefit r_inlined)
in
let keep_unrolled_version =
if W.evaluate wsb then begin
made_decision (Inlined (Unrolled wsb));
true
end else begin
(* No decision is recorded here; we will try another strategy
below, and then record that we also tried to unroll. *)
false
end
in
if keep_unrolled_version then
let r =
R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r))
in
Some (body, r)
else None
(Changed (body, r), S.Unrolled.Unrolled wsb)
end else begin
(* No decision is recorded here; we will try another strategy
below, and then record that we also tried to unroll. *)
(Original, S.Unrolled.Not_unrolled wsb)
end
else None
in
!tried_unrolling, result
end
else (Original, S.Unrolled.Unrolling_not_tried)
let should_duplicate_recursive_function env
~(function_decl : Flambda.function_declaration)
@ -317,17 +302,17 @@ let inline_recursive env r ~max_level ~lhs_of_application
~(function_decls : Flambda.function_declarations)
~closure_id_being_applied ~function_decl
~(value_set_of_closures : Simple_value_approx.value_set_of_closures)
~args ~args_approxs ~dbg ~simplify ~original
~(made_decision : Inlining_stats_types.Decision.t -> unit) =
let tried_unrolling, unrolling_result =
~args ~args_approxs ~dbg ~simplify ~original =
let unrolling_result, unrolling_decision =
(* First try unrolling the recursive call, if we're allowed to. *)
unroll_recursive env r ~max_level ~lhs_of_application ~function_decls
~closure_id_being_applied ~function_decl ~args ~simplify
~original ~made_decision
~original
in
match unrolling_result with
| Some _ -> unrolling_result
| None ->
| Changed _ ->
unrolling_result, D.Recursive(unrolling_decision, Specialising_not_tried)
| Original ->
(* If unrolling failed, consider duplicating the whole function
declaration at the call site, specialising parameters whose arguments
we know. *)
@ -347,34 +332,35 @@ let inline_recursive env r ~max_level ~lhs_of_application
| Some (expr, r_inlined) ->
let wsb =
W.create ~original expr
~toplevel:(E.at_toplevel env)
~toplevel:false
~branch_depth:(E.branch_depth env)
~lifting:false
~round:(E.round env)
~benefit:(R.benefit r_inlined)
in
let keep_inlined_version = W.evaluate wsb in
let decision : Inlining_stats_types.Decision.t =
if keep_inlined_version then
Inlined (Copying_decl (Tried_unrolling tried_unrolling, wsb))
else
Tried (Copying_decl (Tried_unrolling tried_unrolling, wsb))
in
made_decision decision;
if keep_inlined_version then
if W.evaluate wsb then begin
let r =
R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r))
in
Some (expr, r)
else
None
| None -> None
let decision =
D.Recursive (unrolling_decision, Specialised wsb)
in
(Changed (expr, r), decision)
end else begin
let decision =
D.Recursive (unrolling_decision, Not_specialised wsb)
in
(Original, decision)
end
| None ->
let decision =
D.Recursive (unrolling_decision, Specialising_not_tried)
in
(Original, decision)
else begin
(* CR lwhite: should include details of why it was not attempted
in the reason. *)
made_decision
(Did_not_try_copying_decl (Tried_unrolling tried_unrolling));
None
(Original, D.Recursive (unrolling_decision, Specialising_not_tried))
end
let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
@ -386,13 +372,6 @@ let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
Misc.fatal_error "Inlining_decision.for_call_site: inconsistent lengths \
of [args] and [args_approxs]"
end;
let made_decision =
let closure_stack =
E.inlining_stats_closure_stack (E.note_entering_closure env
~closure_id:closure_id_being_applied ~where:Inlining_decision)
in
Inlining_stats.record_decision ~closure_stack ~debuginfo:dbg
in
let original =
Flambda.Apply {
func = lhs_of_application;
@ -405,142 +384,148 @@ let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
let original_r =
R.set_approx (R.seen_direct_application r) (A.value_unknown Other)
in
let max_level =
Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.max_inlining_depth
in
let inline_annotation =
(* Merge call site annotation and function annotation.
The call site annotation takes precedence *)
match (inline_requested : Lambda.inline_attribute) with
| Default_inline -> function_decl.inline
| Always_inline | Never_inline -> inline_requested
in
let always_inline =
match (inline_annotation : Lambda.inline_attribute) with
| Always_inline -> true
(* CR-someday mshinwell: consider whether there could be better
behaviour for stubs *)
| Never_inline | Default_inline -> false
in
let is_a_stub = function_decl.stub in
let num_params = List.length function_decl.params in
let only_use_of_function = false in
let raw_inlining_threshold = R.inlining_threshold r in
let max_inlining_threshold =
if E.at_toplevel env then
Inline_and_simplify_aux.initial_inlining_toplevel_threshold
~round:(E.round env)
else
Inline_and_simplify_aux.initial_inlining_threshold ~round:(E.round env)
in
let unthrottled_inlining_threshold =
match raw_inlining_threshold with
| None -> max_inlining_threshold
| Some inlining_threshold -> inlining_threshold
in
let inlining_threshold =
T.min unthrottled_inlining_threshold max_inlining_threshold
in
let inlining_threshold_diff =
T.sub unthrottled_inlining_threshold inlining_threshold
in
let fun_var =
U.find_declaration_variable closure_id_being_applied function_decls
in
let recursive_functions =
lazy
(Find_recursive_functions.in_function_declarations function_decls
~backend:(E.backend env))
in
let recursive =
lazy (Variable.Set.mem fun_var (Lazy.force recursive_functions))
in
let fun_cost : Inlining_cost.Threshold.t =
match (inline_annotation : Lambda.inline_attribute) with
| Never_inline -> Never_inline
| Always_inline | Default_inline ->
if always_inline
|| is_a_stub
|| (only_use_of_function && not (Lazy.force recursive))
then
inlining_threshold
else begin
Inlining_cost.can_try_inlining function_decl.body inlining_threshold
~number_of_arguments:num_params
(* CR mshinwell: for the moment, this is None, since the
Inlining_cost code isn't checking sizes up to the max inlining
threshold---this seems to take too long. *)
~size_from_approximation:None
end
in
let simpl =
if E.never_inline env then
(* This case only occurs when examining the body of a stub function
but not in the context of inlining said function. As such, there
is nothing to do here (and no decision to report). *)
None
else if fun_cost = T.Never_inline && not function_decl.stub then
(* CR pchambart: should we also accept unconditionnal inline ?
It is some kind of user defined stub, but if we restrict to stub
we are certain that no abusive use of [@@inline] can blow things up *)
let reason : Inlining_stats_types.Decision.t =
match inlining_threshold with
| Never_inline ->
Function_prevented_from_inlining
| Can_inline_if_no_larger_than threshold ->
Function_obviously_too_large threshold
in
made_decision reason;
None
else
let remaining_inlining_threshold = fun_cost in
let r = R.set_inlining_threshold r (Some remaining_inlining_threshold) in
(* Try inlining if the function is non-recursive and not too far above
the threshold (or if the function is to be unconditionally
inlined). *)
(* CR mshinwell for pchambart: I don't understand why this was applying
inline_non_recursive to recursive functions. *)
if is_a_stub
|| (E.inlining_level env < max_level
(* The classic heuristic completely disables inlining if the
function is not annotated as to be inlined. *)
&& (always_inline || not !Clflags.classic_inlining)
&& not (Lazy.force recursive))
then
let size_from_approximation =
match
Variable.Map.find fun_var (Lazy.force value_set_of_closures.size)
with
| size -> size
| exception Not_found ->
Misc.fatal_errorf "Approximation does not give a size for the \
function having fun_var %a. value_set_of_closures: %a"
Variable.print fun_var
A.print_value_set_of_closures value_set_of_closures
if E.never_inline env then
(* This case only occurs when examining the body of a stub function
but not in the context of inlining said function. As such, there
is nothing to do here (and no decision to report). *)
original, original_r
else begin
let env =
E.note_entering_call env
~closure_id:closure_id_being_applied ~debuginfo:dbg
in
let max_level =
Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.max_inlining_depth
in
let inline_annotation =
(* Merge call site annotation and function annotation.
The call site annotation takes precedence *)
match (inline_requested : Lambda.inline_attribute) with
| Default_inline -> function_decl.inline
| Always_inline | Never_inline -> inline_requested
in
let always_inline =
match (inline_annotation : Lambda.inline_attribute) with
| Always_inline -> true
(* CR-someday mshinwell: consider whether there could be better
behaviour for stubs *)
| Never_inline | Default_inline -> false
in
let is_a_stub = function_decl.stub in
let num_params = List.length function_decl.params in
let only_use_of_function = false in
let raw_inlining_threshold = R.inlining_threshold r in
let max_inlining_threshold =
if E.at_toplevel env then
Inline_and_simplify_aux.initial_inlining_toplevel_threshold
~round:(E.round env)
else
Inline_and_simplify_aux.initial_inlining_threshold ~round:(E.round env)
in
let unthrottled_inlining_threshold =
match raw_inlining_threshold with
| None -> max_inlining_threshold
| Some inlining_threshold -> inlining_threshold
in
let inlining_threshold =
T.min unthrottled_inlining_threshold max_inlining_threshold
in
let inlining_threshold_diff =
T.sub unthrottled_inlining_threshold inlining_threshold
in
let fun_var =
U.find_declaration_variable closure_id_being_applied function_decls
in
let recursive_functions =
lazy
(Find_recursive_functions.in_function_declarations function_decls
~backend:(E.backend env))
in
let recursive =
lazy (Variable.Set.mem fun_var (Lazy.force recursive_functions))
in
let fun_cost : Inlining_cost.Threshold.t =
match (inline_annotation : Lambda.inline_attribute) with
| Never_inline -> Never_inline
| Always_inline | Default_inline ->
if always_inline
|| is_a_stub
|| (only_use_of_function && not (Lazy.force recursive))
then
inlining_threshold
else begin
Inlining_cost.can_try_inlining function_decl.body inlining_threshold
~number_of_arguments:num_params
(* CR mshinwell: for the moment, this is None, since the
Inlining_cost code isn't checking sizes up to the max inlining
threshold---this seems to take too long. *)
~size_from_approximation:None
end
in
let simpl, decision =
if fun_cost = T.Never_inline && not function_decl.stub then
(* CR pchambart: should we also accept unconditionnal inline ? It is
some kind of user defined stub, but if we restrict to stub we are
certain that no abusive use of [@@inline] can blow things up *)
let reason : Inlining_stats_types.Prevented.t =
match inlining_threshold with
| Never_inline ->
Function_prevented_from_inlining
| Can_inline_if_no_larger_than threshold ->
Function_obviously_too_large threshold
in
inline_non_recursive env r ~function_decls ~lhs_of_application
~closure_id_being_applied ~function_decl ~value_set_of_closures
~made_decision ~only_use_of_function ~original
~inline_requested ~always_inline ~args ~size_from_approximation
~simplify
else if E.inlining_level env >= max_level then begin
made_decision (Can_inline_but_tried_nothing (Level_exceeded true));
None
end else if not !Clflags.classic_inlining && Lazy.force recursive then
inline_recursive env r ~max_level ~lhs_of_application ~function_decls
~closure_id_being_applied ~function_decl ~value_set_of_closures
~args ~args_approxs ~dbg ~simplify ~original ~made_decision
else begin
made_decision (Can_inline_but_tried_nothing (Level_exceeded false));
None
end
in
match simpl with
| None -> original, original_r
| Some (expr, r) ->
if E.inlining_level env = 0
then expr, R.set_inlining_threshold r raw_inlining_threshold
else expr, R.add_inlining_threshold r inlining_threshold_diff
(Original, D.Prevented reason)
else
let remaining_inlining_threshold = fun_cost in
let r =
R.set_inlining_threshold r (Some remaining_inlining_threshold)
in
(* Try inlining if the function is non-recursive and not too far above
the threshold (or if the function is to be unconditionally
inlined). *)
(* CR mshinwell for pchambart: I don't understand why this was applying
inline_non_recursive to recursive functions. *)
if is_a_stub
|| (E.inlining_level env < max_level
(* The classic heuristic completely disables inlining if the
function is not annotated as to be inlined. *)
&& (always_inline || not !Clflags.classic_inlining)
&& not (Lazy.force recursive))
then
let size_from_approximation =
match
Variable.Map.find fun_var (Lazy.force value_set_of_closures.size)
with
| size -> size
| exception Not_found ->
Misc.fatal_errorf "Approximation does not give a size for the \
function having fun_var %a. value_set_of_closures: %a"
Variable.print fun_var
A.print_value_set_of_closures value_set_of_closures
in
inline_non_recursive env r ~function_decls ~lhs_of_application
~closure_id_being_applied ~function_decl ~value_set_of_closures
~only_use_of_function ~original
~inline_requested ~always_inline ~args ~size_from_approximation
~simplify
else if E.inlining_level env >= max_level then begin
(Original, D.Prevented Level_exceeded)
end else if not !Clflags.classic_inlining && Lazy.force recursive then
inline_recursive env r ~max_level ~lhs_of_application ~function_decls
~closure_id_being_applied ~function_decl ~value_set_of_closures
~args ~args_approxs ~dbg ~simplify ~original
else begin
(Original, D.Prevented Classic_heuristic)
end
in
E.record_decision env decision;
match simpl with
| Original -> original, original_r
| Changed (expr, r) ->
if E.inlining_level env = 0
then expr, R.set_inlining_threshold r raw_inlining_threshold
else expr, R.add_inlining_threshold r inlining_threshold_diff
end
(* We do not inline inside stubs, which are always inlined at their call site.

368
middle_end/inlining_stats.ml
View File

@ -14,146 +14,268 @@
(* *)
(**************************************************************************)
let vim_trailer = "vim:fdm=expr:filetype=plain:\
let _vim_trailer = "vim:fdm=expr:filetype=plain:\
foldexpr=getline(v\\:lnum)=~'^\\\\s*$'&&getline(v\\:lnum+1)=~'\\\\S'?'<1'\\:1"
module Closure_stack = struct
type t
= (Closure_id.t * Inlining_stats_types.where_entering_closure) list
type t = node list
and node =
| Closure of Closure_id.t * Debuginfo.t
| Call of Closure_id.t * Debuginfo.t
| Inlined
| Specialised of Closure_id.Set.t
let create () = []
let _compare t1 t2 =
match t1, t2 with
| (id1, _)::_, (id2, _)::_ ->
let (_ : string) = Format.flush_str_formatter () in
let (id1 : string) =
Format.fprintf Format.str_formatter "%a" Closure_id.print id1;
Format.flush_str_formatter ()
in
let id2 =
Format.fprintf Format.str_formatter "%a" Closure_id.print id2;
Format.flush_str_formatter ()
in
String.compare id1 id2
| _ -> 0
let note_entering_closure t ~closure_id ~where =
let note_entering_closure t ~closure_id ~debuginfo =
if not !Clflags.inlining_stats then t
else t @ [closure_id, where]
else
match t with
| [] | (Closure _ | Inlined | Specialised _) :: _->
(Closure (closure_id, debuginfo)) :: t
| (Call _) :: _ ->
Misc.fatal_errorf "note_entering_closure: unexpected Call node"
let pop = function
| [] -> failwith "Closure_stack.pop on empty stack"
| hd::tl -> (fst hd), tl
(* CR-someday lwhite: since calls do not have a unique id it is possible some calls
will end up sharing nodes. *)
let note_entering_call t ~closure_id ~debuginfo =
if not !Clflags.inlining_stats then t
else
match t with
| [] | (Closure _ | Inlined | Specialised _) :: _ ->
(Call (closure_id, debuginfo)) :: t
| (Call _) :: _ ->
Misc.fatal_errorf "note_entering_call: unexpected Call node"
let note_entering_inlined t =
if not !Clflags.inlining_stats then t
else
match t with
| [] | (Closure _ | Inlined | Specialised _) :: _->
Misc.fatal_errorf "note_entering_inlined: missing Call node"
| (Call _) :: _ -> Inlined :: t
let note_entering_specialised t ~closure_ids =
if not !Clflags.inlining_stats then t
else
match t with
| [] | (Closure _ | Inlined | Specialised _) :: _ ->
Misc.fatal_errorf "note_entering_specialised: missing Call node"
| (Call _) :: _ -> Specialised closure_ids :: t
let save t ~out_channel =
let print_elt (closure_id, where) ~last_one =
let current_unit = Compilation_unit.get_current_exn () in
let output =
if Closure_id.in_compilation_unit closure_id current_unit then
Closure_id.output
else
Closure_id.output_full
in
begin match (where : Inlining_stats_types.where_entering_closure) with
| Inline_by_copying_function_declaration closure_ids ->
let closure_ids = Closure_id.Set.remove closure_id closure_ids in
if Closure_id.Set.cardinal closure_ids < 1 then
Printf.fprintf out_channel "in copy of %a" output closure_id
else begin
Printf.fprintf out_channel "in copy of %a (and" output closure_id;
Closure_id.Set.iter (fun closure_id ->
Printf.fprintf out_channel " %a" output closure_id)
closure_ids;
Printf.fprintf out_channel ")"
end
| Transform_set_of_closures_expression ->
Printf.fprintf out_channel "decl of %a" output closure_id
| Inline_by_copying_function_body ->
Printf.fprintf out_channel "inlined body of %a" output closure_id
| Inlining_decision ->
Printf.fprintf out_channel "%a" output closure_id
end;
if not last_one then begin
match (where : Inlining_stats_types.where_entering_closure) with
| Inline_by_copying_function_declaration _
| Inline_by_copying_function_body ->
Printf.fprintf out_channel ": "
| Transform_set_of_closures_expression
| Inlining_decision -> Printf.fprintf out_channel " -> "
end
in
let rec loop = function
| [] -> Printf.fprintf out_channel "[]"
| [elt] -> print_elt elt ~last_one:true
| elt::elts ->
print_elt elt ~last_one:false;
loop elts
in
loop t
end
let time = ref 0
let log
: (Closure_stack.t * Inlining_stats_types.Decision.t) list ref
= ref []
module Line_number_then_time = struct
type t = Debuginfo.t * int
let compare_fst (((dbg1, t1) : t), _) (((dbg2, t2) : t), _) =
match compare dbg1.dinfo_line dbg2.dinfo_line with
| -1 -> -1
| 1 -> 1
| _ -> compare t1 t2
let create ~debuginfo ~time = debuginfo, time
let line_number t = (fst t).Debuginfo.dinfo_line
end
let decisions :
(Line_number_then_time.t
* (Closure_stack.t * Inlining_stats_types.Decision.t)) list
Closure_id.Tbl.t = Closure_id.Tbl.create 42
let record_decision decision ~closure_stack ~debuginfo =
let record_decision decision ~closure_stack =
if !Clflags.inlining_stats then begin
let closure_id, closure_stack = Closure_stack.pop closure_stack in
let bucket =
match Closure_id.Tbl.find decisions closure_id with
| exception Not_found -> []
| bucket -> bucket
in
let key = Line_number_then_time.create ~debuginfo ~time:!time in
let data = closure_stack, decision in
(* The order here is important so that the "time rebasing" works
properly, below. *)
Closure_id.Tbl.replace decisions closure_id ((key, data) :: bucket);
incr time
match closure_stack with
| []
| Closure_stack.Closure _ :: _
| Closure_stack.Inlined :: _
| Closure_stack.Specialised _ :: _ ->
Misc.fatal_errorf "record_decision: missing Call node"
| Closure_stack.Call _ :: _ ->
log := (closure_stack, decision) :: !log
end
module Inlining_report = struct
module Place = struct
type kind =
| Closure
| Call
type t = Debuginfo.t * Closure_id.t * kind
let compare ((d1, cl1, k1) : t) ((d2, cl2, k2) : t) =
let c = compare d1.dinfo_file d2.dinfo_file in
if c <> 0 then c else
let c = compare d1.dinfo_line d2.dinfo_line in
if c <> 0 then c else
let c = compare d1.dinfo_char_end d2.dinfo_char_end in
if c <> 0 then c else
let c = compare d1.dinfo_char_start d2.dinfo_char_start in
if c <> 0 then c else
let c = Closure_id.compare cl1 cl2 in
if c <> 0 then c else
match k1, k2 with
| Closure, Closure -> 0
| Call, Call -> 0
| Closure, Call -> 1
| Call, Closure -> -1
end
module Place_map = Map.Make(Place)
type t = node Place_map.t
and node =
| Closure of t
| Call of call
and call =
{ decision: Inlining_stats_types.Decision.t option;
inlined: t option;
specialised: t option; }
let empty_call =
{ decision = None;
inlined = None;
specialised = None; }
let add_call_decision call (decision : Inlining_stats_types.Decision.t) =
match call.decision, decision with
| None, _ -> { call with decision = Some decision }
| Some _, Prevented _ -> call
| Some (Prevented _), _ -> { call with decision = Some decision }
| Some (Nonrecursive n1), Nonrecursive n2 -> begin
match n1, n2 with
| Not_inlined _, _ -> { call with decision = Some decision }
| _, _ -> call
end
| Some (Recursive (u1, s1)), Recursive (u2, s2) ->
let u =
match u1, u2 with
| _, Unrolling_not_tried -> u1
| Unrolling_not_tried, _ -> u2
| _, Not_unrolled _ -> u1
| Not_unrolled _, _ -> u2
| _, _ -> u1
in
let s =
match s1, s2 with
| _, Specialising_not_tried -> s1
| Specialising_not_tried, _ -> s2
| _, Not_specialised _ -> s1
| Not_specialised _, _ -> s2
| _, _ -> s1
in
let decision : Inlining_stats_types.Decision.t = Recursive (u, s) in
{ call with decision = Some decision }
| Some (Recursive _), Nonrecursive _ ->
Misc.fatal_errorf "add_call_decision: decision kind mismatch"
| Some (Nonrecursive _), Recursive _ ->
Misc.fatal_errorf "add_call_decision: decision kind mismatch"
let add_decision t (stack, decision) =
let rec loop t : Closure_stack.t -> _ = function
| Closure(cl, dbg) :: rest ->
let key : Place.t = (dbg, cl, Closure) in
let v =
try
match Place_map.find key t with
| Closure v -> v
| Call _ -> assert false
with Not_found -> Place_map.empty
in
let v = loop v rest in
Place_map.add key (Closure v) t
| Call(cl, dbg) :: rest ->
let key : Place.t = (dbg, cl, Call) in
let v =
try
match Place_map.find key t with
| Call v -> v
| Closure _ -> assert false
with Not_found -> empty_call
in
let v =
match rest with
| [] -> add_call_decision v decision
| Inlined :: rest ->
let inlined =
match v.inlined with
| None -> Place_map.empty
| Some inlined -> inlined
in
let inlined = loop inlined rest in
{ v with inlined = Some inlined }
| Specialised _ :: rest ->
let specialised =
match v.specialised with
| None -> Place_map.empty
| Some specialised -> specialised
in
let specialised = loop specialised rest in
{ v with specialised = Some specialised }
| Call _ :: _ -> assert false
| Closure _ :: _ -> assert false
in
Place_map.add key (Call v) t
| [] -> assert false
| Inlined :: _ -> assert false
| Specialised _ :: _ -> assert false
in
loop t (List.rev stack)
let build log =
List.fold_left add_decision Place_map.empty log
let print_stars ppf n =
let s = String.make n '*' in
Format.fprintf ppf "%s" s
let rec print ~depth ppf t =
Place_map.iter
(fun (dbg, cl, _) v ->
match v with
| Closure t ->
Format.fprintf ppf "@[<h>%a Definition of %a%s@]@."
print_stars (depth + 1)
Closure_id.print cl
(Debuginfo.to_string dbg);
print ppf ~depth:(depth + 1) t;
if depth = 0 then Format.pp_print_newline ppf ()
| Call c ->
match c.decision with
| None ->
Misc.fatal_error "Inlining_report.print: missing call decision"
| Some decision ->
Format.pp_open_vbox ppf (depth + 2);
Format.fprintf ppf "@[<h>%a Application of %a%s@]@;@;@[%a@]"
print_stars (depth + 1)
Closure_id.print cl
(Debuginfo.to_string dbg)
Inlining_stats_types.Decision.summary decision;
Format.pp_close_box ppf ();
Format.pp_print_newline ppf ();
Format.pp_print_newline ppf ();
Inlining_stats_types.Decision.calculation ~depth:(depth + 1) ppf decision;
begin
match decision with
| Prevented _ -> ()
| Nonrecursive _ -> begin
match c.inlined with
| None -> ()
| Some inlined ->
print ppf ~depth:(depth + 1) inlined
end
| Recursive _ -> begin
match c.specialised with
| None -> ()
| Some specialised ->
print ppf ~depth:(depth + 1) specialised
end
end;
if depth = 0 then Format.pp_print_newline ppf ())
t
let print ppf t = print ~depth:0 ppf t
end
let really_save_then_forget_decisions ~output_prefix =
let out_channel = open_out (output_prefix ^ ".inlining") in
Closure_id.Tbl.iter (fun closure_id bucket ->
Printf.fprintf out_channel "%a\n" Closure_id.output closure_id;
let bucket =
let rebased_time = ref (-1) in
(* Rebase timestamps to start at zero within each bucket. *)
List.rev_map (fun (key, (closure_stack, decision)) ->
incr rebased_time;
key, (!rebased_time, closure_stack, decision))
bucket
in
let bucket = List.sort Line_number_then_time.compare_fst bucket in
List.iter (fun (key, (time, closure_stack, decision)) ->
let line = Line_number_then_time.line_number key in
Printf.fprintf out_channel " %5d: (%5d) " line time;
Closure_stack.save closure_stack ~out_channel;
Printf.fprintf out_channel ": %s\n"
(Inlining_stats_types.Decision.to_string decision))
bucket;
Printf.fprintf out_channel "\n") decisions;
Printf.fprintf out_channel "# %s\n" vim_trailer;
let report = Inlining_report.build !log in
let out_channel = open_out (output_prefix ^ ".inlining.org") in
let ppf = Format.formatter_of_out_channel out_channel in
Inlining_report.print ppf report;
(*Format.fprintf ppf "@.# %s@." vim_trailer;*)
close_out out_channel;
Closure_id.Tbl.clear decisions;
time := 0
log := []
let save_then_forget_decisions ~output_prefix =
if !Clflags.inlining_stats then begin

13
middle_end/inlining_stats.mli
View File

@ -22,14 +22,23 @@ module Closure_stack : sig
val note_entering_closure
: t
-> closure_id:Closure_id.t
-> where:Inlining_stats_types.where_entering_closure
-> debuginfo:Debuginfo.t
-> t
val note_entering_call
: t
-> closure_id:Closure_id.t
-> debuginfo:Debuginfo.t
-> t
val note_entering_inlined : t -> t
val note_entering_specialised : t -> closure_ids:Closure_id.Set.t -> t
end
val record_decision
: Inlining_stats_types.Decision.t
-> closure_stack:Closure_stack.t
-> debuginfo:Debuginfo.t
-> unit
val save_then_forget_decisions : output_prefix:string -> unit

265
middle_end/inlining_stats_types.ml
View File

@ -16,90 +16,211 @@
module Wsb = Inlining_cost.Whether_sufficient_benefit
module Tried_unrolling = struct
type t =
| Tried_unrolling of bool
let print_stars ppf n =
let s = String.make n '*' in
Format.fprintf ppf "%s" s
let to_string = function
| Tried_unrolling true -> "tried unrolling"
| Tried_unrolling false -> "did not try unrolling"
end
module Copying_body = struct
type t =
| Unconditionally
| Decl_local_to_application
| Evaluated of Wsb.t
| Evaluated_unspecialized
| Stub
let to_string = function
| Unconditionally -> "unconditionally"
| Decl_local_to_application -> "decl local to application expression"
| Evaluated wsb -> Wsb.to_string wsb
| Evaluated_unspecialized -> "too large without specialized arguments"
| Stub -> "stub"
end
let print_calculation ~depth ~title ~subfunctions ppf wsb =
Format.pp_open_vbox ppf (depth + 2);
Format.fprintf ppf "@[<h>%a %s@]@;@;@[%a@]"
print_stars (depth + 1)
title
(Wsb.print_description ~subfunctions) wsb;
Format.pp_close_box ppf ();
Format.pp_print_newline ppf ();
Format.pp_print_newline ppf ()
module Inlined = struct
type t =
| Copying_body of Copying_body.t
| Copying_body_with_subfunctions of Copying_body.t
| Unrolled of Wsb.t
| Copying_decl of Tried_unrolling.t * Wsb.t
type not_inlined_reason =
| Unspecialized
| Without_subfunctions of Wsb.t
| With_subfunctions of Wsb.t * Wsb.t
let not_inlined_reason_summary ppf = function
| Unspecialized ->
Format.pp_print_text ppf
" because its parameters could not be specialised."
| Without_subfunctions _ ->
Format.pp_print_text ppf
" because the expected benefit did not \
outweigh the change in code size."
| With_subfunctions _ ->
Format.pp_print_text ppf
" because the expected benefit did not \
outweigh the change in code size."
let not_inlined_reason_calculation ~depth ppf = function
| Unspecialized -> ()
| Without_subfunctions wsb ->
print_calculation
~depth ~title:"Inlining benefit calculation"
~subfunctions:false ppf wsb
| With_subfunctions(_, wsb) ->
print_calculation
~depth ~title:"Inlining benefit calculation"
~subfunctions:true ppf wsb
type inlined_reason =
| Unconditionally
| Decl_local_to_application
| Stub
| Without_subfunctions of Wsb.t
| With_subfunctions of Wsb.t * Wsb.t
let inlined_reason_summary ppf = function
| Unconditionally ->
Format.pp_print_text ppf " because of an annotation."
| Decl_local_to_application ->
Format.pp_print_text ppf " because it was local to this application."
| Stub ->
Format.pp_print_text ppf " because it was a stub."
| Without_subfunctions _ ->
Format.pp_print_text ppf
" because the expected benefit outweighed the change in code size."
| With_subfunctions _ ->
Format.pp_print_text ppf
" because the expected benefit outweighed the change in code size."
let inlined_reason_calculation ~depth ppf = function
| Unconditionally -> ()
| Decl_local_to_application -> ()
| Stub -> ()
| Without_subfunctions wsb ->
print_calculation
~depth ~title:"Inlining benefit calculation"
~subfunctions:false ppf wsb
| With_subfunctions(_, wsb) ->
print_calculation
~depth ~title:"Inlining benefit calculation"
~subfunctions:true ppf wsb
type t =
| Not_inlined of not_inlined_reason
| Inlined of inlined_reason
let summary ppf = function
| Not_inlined r ->
Format.pp_print_text ppf "This function was not inlined";
not_inlined_reason_summary ppf r
| Inlined r ->
Format.pp_print_text ppf "This function was inlined";
inlined_reason_summary ppf r
let calculation ~depth ppf = function
| Not_inlined r -> not_inlined_reason_calculation ~depth ppf r
| Inlined r -> inlined_reason_calculation ~depth ppf r
let to_string = function
| Copying_body cb ->
Printf.sprintf "copying body (%s)" (Copying_body.to_string cb)
| Copying_body_with_subfunctions cb ->
Printf.sprintf "copying body using subfunctions (%s)" (Copying_body.to_string cb)
| Unrolled wsb ->
Printf.sprintf "unrolled (%s)" (Wsb.to_string wsb)
| Copying_decl (tried, wsb) ->
Printf.sprintf "copying decl (%s, %s)"
(Tried_unrolling.to_string tried) (Wsb.to_string wsb)
end
module Decision = struct
module Unrolled = struct
type t =
| Unrolling_not_tried
| Not_unrolled of Wsb.t
| Unrolled of Wsb.t
type level_exceeded =
| Level_exceeded of bool
let summary ppf = function
| Unrolling_not_tried ->
Format.pp_print_text ppf "This function was not eligible for unrolling."
| Not_unrolled _ ->
Format.pp_print_text ppf
"This function was not unrolled because the expected benefit \
did not outweigh the change in code size."
| Unrolled _ ->
Format.pp_print_text ppf
"This function was unrolled because the expected benefit \
outweighed the change in code size."
let calculation ~depth ppf = function
| Unrolling_not_tried -> ()
| Not_unrolled wsb ->
print_calculation
~depth ~title:"Unrolling benefit calculation"
~subfunctions:true ppf wsb
| Unrolled wsb ->
print_calculation
~depth ~title:"Unrolling benefit calculation"
~subfunctions:true ppf wsb
end
module Specialised = struct
type t =
| Specialising_not_tried
| Not_specialised of Wsb.t
| Specialised of Wsb.t
let summary ppf = function
| Specialising_not_tried ->
Format.pp_print_text ppf "This function was not eligible for specialising."
| Not_specialised _ ->
Format.pp_print_text ppf
"This function was not specialised because the expected benefit \
did not outweigh the change in code size."
| Specialised _ ->
Format.pp_print_text ppf
"This function was specialised because the expected benefit \
outweighed the change in code size."
let calculation ~depth ppf = function
| Specialising_not_tried -> ()
| Not_specialised wsb ->
print_calculation
~depth ~title:"Specialising benefit calculation"
~subfunctions:true ppf wsb
| Specialised wsb ->
print_calculation
~depth ~title:"Specialising benefit calculation"
~subfunctions:true ppf wsb
end
module Nonrecursive = struct
type t = Inlined.t
end
module Recursive = struct
type t = Unrolled.t * Specialised.t
end
module Prevented = struct
type t =
| Function_obviously_too_large of int
| Function_prevented_from_inlining
| Inlined of Inlined.t
| Tried of Inlined.t
| Did_not_try_copying_decl of Tried_unrolling.t
| Can_inline_but_tried_nothing of level_exceeded
| Level_exceeded
| Classic_heuristic
let to_string = function
| Function_obviously_too_large threshold ->
Printf.sprintf "function obviously too large (threshold: %i)"
threshold
| Function_prevented_from_inlining -> "function prevented from inlining"
| Inlined inlined ->
Printf.sprintf "inlined (%s)" (Inlined.to_string inlined)
| Tried inlined ->
Printf.sprintf "tried but failed (%s)" (Inlined.to_string inlined)
| Did_not_try_copying_decl tried ->
Printf.sprintf "did not try copying decl (%s)"
(Tried_unrolling.to_string tried)
| Can_inline_but_tried_nothing (Level_exceeded b) ->
if b then
"can inline, but tried nothing, too deep into inlining"
else
"can inline, but tried nothing"
let summary ppf = function
| Function_obviously_too_large size ->
Format.pp_print_text ppf " because it was obviously too large ";
Format.fprintf ppf "(%i)." size
| Function_prevented_from_inlining -> ()
| Level_exceeded ->
Format.pp_print_text ppf " because the inlining depth was exceeded."
| Classic_heuristic ->
Format.pp_print_text ppf " by `-classic-heuristic'."
end
type where_entering_closure =
| Transform_set_of_closures_expression
| Inline_by_copying_function_body
| Inline_by_copying_function_declaration of Closure_id.Set.t
| Inlining_decision
module Decision = struct
type t =
| Prevented of Prevented.t
| Nonrecursive of Nonrecursive.t
| Recursive of Recursive.t
let char_of_where = function
| Transform_set_of_closures_expression -> 'T'
| Inline_by_copying_function_body -> 'B'
| Inline_by_copying_function_declaration _ -> 'D'
| Inlining_decision -> 'I'
let summary ppf = function
| Prevented p ->
Format.pp_print_text ppf
"This function was prevented from inlining or specialising";
Prevented.summary ppf p
| Nonrecursive i ->
Inlined.summary ppf i
| Recursive (u, s) ->
Format.fprintf ppf "@[<v>@[%a@]@;@;@[%a@]@]"
Unrolled.summary u Specialised.summary s
let calculation ~depth ppf = function
| Prevented _ -> ()
| Nonrecursive i -> Inlined.calculation ~depth ppf i
| Recursive (u, s) ->
Unrolled.calculation ~depth ppf u;
Specialised.calculation ~depth ppf s
end

84
middle_end/inlining_stats_types.mli
View File

@ -16,54 +16,66 @@
(* Types used for producing statistics about inlining. *)
module Tried_unrolling : sig
type t =
| Tried_unrolling of bool
module Inlined : sig
type not_inlined_reason =
| Unspecialized
| Without_subfunctions of
Inlining_cost.Whether_sufficient_benefit.t
| With_subfunctions of
Inlining_cost.Whether_sufficient_benefit.t
* Inlining_cost.Whether_sufficient_benefit.t
val to_string : t -> string
end
module Copying_body : sig
type t =
type inlined_reason =
| Unconditionally
| Decl_local_to_application
| Evaluated of Inlining_cost.Whether_sufficient_benefit.t
| Evaluated_unspecialized
| Stub
| Without_subfunctions of Inlining_cost.Whether_sufficient_benefit.t
| With_subfunctions of
Inlining_cost.Whether_sufficient_benefit.t
* Inlining_cost.Whether_sufficient_benefit.t
val to_string : t -> string
end
module Inlined : sig
type t =
| Copying_body of Copying_body.t
| Copying_body_with_subfunctions of Copying_body.t
| Unrolled of Inlining_cost.Whether_sufficient_benefit.t
| Copying_decl of
Tried_unrolling.t * Inlining_cost.Whether_sufficient_benefit.t
val to_string : t -> string
| Not_inlined of not_inlined_reason
| Inlined of inlined_reason
end
module Decision : sig
type level_exceeded =
| Level_exceeded of bool
module Unrolled : sig
type t =
| Unrolling_not_tried
| Not_unrolled of Inlining_cost.Whether_sufficient_benefit.t
| Unrolled of Inlining_cost.Whether_sufficient_benefit.t
end
module Specialised : sig
type t =
| Specialising_not_tried
| Not_specialised of Inlining_cost.Whether_sufficient_benefit.t
| Specialised of Inlining_cost.Whether_sufficient_benefit.t
end
module Nonrecursive : sig
type t = Inlined.t
end
module Recursive : sig
type t = Unrolled.t * Specialised.t
end
module Prevented : sig
type t =
| Function_obviously_too_large of int
| Function_prevented_from_inlining
| Inlined of Inlined.t
| Tried of Inlined.t
| Did_not_try_copying_decl of Tried_unrolling.t
| Can_inline_but_tried_nothing of level_exceeded
val to_string : t -> string
| Level_exceeded
| Classic_heuristic
end
type where_entering_closure =
| Transform_set_of_closures_expression
| Inline_by_copying_function_body
| Inline_by_copying_function_declaration of Closure_id.Set.t
| Inlining_decision
module Decision : sig
val char_of_where : where_entering_closure -> char
type t =
| Prevented of Prevented.t
| Nonrecursive of Nonrecursive.t
| Recursive of Recursive.t
val summary : Format.formatter -> t -> unit
val calculation : depth:int -> Format.formatter -> t -> unit
end

8
middle_end/inlining_transforms.ml
View File

@ -164,10 +164,7 @@ let inline_by_copying_function_body ~env ~r ~function_decls ~lhs_of_application
function_decls.Flambda.funs
bindings_for_vars_bound_by_closure_and_params_to_args
in
let env =
E.note_entering_closure env ~closure_id:closure_id_being_applied
~where:Inline_by_copying_function_body
in
let env = E.note_entering_inlined env in
simplify (E.activate_freshening env) r expr
let inline_by_copying_function_declaration ~env ~r
@ -326,7 +323,6 @@ let inline_by_copying_function_declaration ~env ~r
List.map Closure_id.wrap
(Variable.Set.elements (Variable.Map.keys function_decls.funs)))
in
E.note_entering_closure env ~closure_id:closure_id_being_applied
~where:(Inline_by_copying_function_declaration closure_ids)
E.note_entering_specialised env ~closure_ids
in
Some (simplify (E.activate_freshening env) r expr)

33
middle_end/invariant_params.ml
View File

@ -331,11 +331,15 @@ let invariant_params_in_recursion (decls : Flambda.function_declarations)
| set -> set)
unchanging
let pass_name = "unused-arguments"
let () = Clflags.all_passes := pass_name :: !Clflags.all_passes
type argument =
| Used
| Argument of Variable.t
let unused_arguments (decls : Flambda.function_declarations) : Variable.Set.t =
let dump = Clflags.dumped_pass pass_name in
let used_variables = Variable.Tbl.create 42 in
let used_variable var = Variable.Tbl.add used_variables var () in
let param_indexes_by_fun_vars =
@ -363,15 +367,31 @@ let unused_arguments (decls : Flambda.function_declarations) : Variable.Set.t =
match expr with
| Apply { func; args; kind = Direct callee } ->
used_variable func;
if dump then Format.printf "Used as direct function: %a@." Variable.print func;
List.iteri (fun callee_pos arg ->
match
find_callee_arg ~callee ~callee_pos ~application_expr:expr
with
| Used -> used_variable arg
| Used ->
if dump then Format.printf "Used as argument: %a@." Variable.print arg;
used_variable arg
| Argument param ->
if not (Variable.equal arg param) then used_variable arg)
if not (Variable.equal arg param) then
let () =
if dump then Format.printf "Used as recursive arguments: %a \
(not equal to %a)@."
Variable.print arg
Variable.print param
in
used_variable arg)
args
| Apply { func; args; kind = Indirect; _ } ->
if dump then begin
Format.printf "Used as indirect function: %a@." Variable.print func;
List.iter (fun arg ->
Format.printf "Used as indirect function argument: %a@." Variable.print arg)
args;
end;
used_variable func;
List.iter used_variable args
| _ -> ()
@ -379,8 +399,12 @@ let unused_arguments (decls : Flambda.function_declarations) : Variable.Set.t =
Variable.Map.iter (fun _caller (decl : Flambda.function_declaration) ->
Flambda_iterators.iter check_expr (fun (_ : Flambda.named) -> ())
decl.body;
Variable.Set.iter used_variable
(Flambda.free_variables ~ignore_uses_as_callee:() decl.body))
let free_vars =
Flambda.free_variables ~ignore_uses_as_callee:()
~ignore_uses_as_argument:() decl.body
in
Format.printf "Used: %a@." Variable.Set.print free_vars;
Variable.Set.iter used_variable free_vars)
decls.funs;
let arguments =
Variable.Map.fold
@ -392,4 +416,5 @@ let unused_arguments (decls : Flambda.function_declarations) : Variable.Set.t =
acc decl.Flambda.params)
decls.funs Variable.Set.empty
in
if dump then Format.printf "Unused arguments: %a@." Variable.Set.print arguments;
arguments

33
middle_end/lift_constants.ml
View File

@ -817,8 +817,23 @@ let project_closure_map symbol_definition_map =
symbol_definition_map
Symbol.Map.empty
let the_dead_constant_index = ref 0
let lift_constants (program : Flambda.program) ~backend =
(* Format.eprintf "lift_constants input:@ %a\n" Flambda.print_program program; *)
let the_dead_constant =
let index = !the_dead_constant_index in
incr the_dead_constant_index;
let name = Printf.sprintf "the_dead_constant_%d" index in
Symbol.create (Compilation_unit.get_current_exn ())
(Linkage_name.create name)
in
let program_body : Flambda.program_body =
Let_symbol (the_dead_constant, Allocated_const (Nativeint 0n),
program.program_body)
in
let program : Flambda.program =
{ program with program_body; }
in
let inconstants =
Inconstant_idents.inconstants_on_program program
~backend
@ -829,18 +844,21 @@ let lift_constants (program : Flambda.program) ~backend =
in
let var_to_symbol_tbl, var_to_definition_tbl, let_symbol_to_definition_tbl,
initialize_symbol_to_definition_tbl =
assign_symbols_and_collect_constant_definitions ~backend ~program ~inconstants
assign_symbols_and_collect_constant_definitions ~backend ~program
~inconstants
in
let aliases =
Alias_analysis.run var_to_definition_tbl
initialize_symbol_to_definition_tbl
let_symbol_to_definition_tbl
~the_dead_constant
in
replace_definitions_in_initialize_symbol_and_effects
(inconstants:Inconstant_idents.result)
(aliases:Alias_analysis.allocation_point Variable.Map.t)
(var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
(var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
(var_to_definition_tbl
: Alias_analysis.constant_defining_value Variable.Tbl.t)
initialize_symbol_tbl
effect_tbl;
let symbol_definition_map =
@ -848,7 +866,8 @@ let lift_constants (program : Flambda.program) ~backend =
(inconstants:Inconstant_idents.result)
(aliases:Alias_analysis.allocation_point Variable.Map.t)
(var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
(var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
(var_to_definition_tbl
: Alias_analysis.constant_defining_value Variable.Tbl.t)
(Symbol.Tbl.to_map symbol_definition_tbl)
in
let project_closure_map = project_closure_map symbol_definition_map in
@ -857,7 +876,8 @@ let lift_constants (program : Flambda.program) ~backend =
inconstants
(aliases:Alias_analysis.allocation_point Variable.Map.t)
(var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
(var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
(var_to_definition_tbl
: Alias_analysis.constant_defining_value Variable.Tbl.t)
symbol_definition_map
project_closure_map
~backend
@ -866,7 +886,8 @@ let lift_constants (program : Flambda.program) ~backend =
var_to_block_field
(aliases:Alias_analysis.allocation_point Variable.Map.t)
(var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
(var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
(var_to_definition_tbl
: Alias_analysis.constant_defining_value Variable.Tbl.t)
in
let translated_definitions =
introduce_free_variables_in_sets_of_closures var_to_block_field_tbl

2
middle_end/middle_end.ml
View File

@ -125,6 +125,8 @@ let middle_end ppf ~source_provenance ~prefixname ~backend
+-+ ("Inline_and_simplify noinline",
Inline_and_simplify.run ~never_inline:true ~backend
~prefixname ~round)
+-+ ("Remove_unused_closure_vars 3",
Remove_unused_closure_vars.remove_unused_closure_variables)
+-+ ("Initialize_symbol_to_let_symbol",
Initialize_symbol_to_let_symbol.run)
|> loop

21
middle_end/remove_unused_arguments.ml
View File

@ -14,6 +14,9 @@
(* *)
(**************************************************************************)
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 ())
@ -144,12 +147,24 @@ let candidate_for_spliting_for_unused_arguments
end
let separate_unused_arguments_in_set_of_closures set_of_closures ~backend =
let dump = Clflags.dumped_pass pass_name in
if candidate_for_spliting_for_unused_arguments
set_of_closures.Flambda.function_decls
~backend
then match separate_unused_arguments set_of_closures with
| None -> set_of_closures
| Some set_of_closures -> set_of_closures
then
match separate_unused_arguments 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;
set_of_closures
| 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;
result
else set_of_closures
let separate_unused_arguments_in_closures_expr tree ~backend =

44
middle_end/remove_unused_closure_vars.ml
View File

@ -39,28 +39,44 @@ let remove_unused_closure_variables program =
let aux_named _ (named : Flambda.named) : Flambda.named =
match named with
| Set_of_closures ({ function_decls; free_vars; _ } as set_of_closures) ->
let all_free_vars =
Variable.Map.fold (fun _ { Flambda. free_variables } acc ->
Variable.Set.union free_variables acc)
function_decls.funs
Variable.Set.empty
let rec add_needed needed_funs remaining_funs free_vars_of_kept_funs =
let new_needed_funs, remaining_funs =
(* Keep a function if it is used either by the rest of the code,
(in used_closure_ids), or by any other kept function
(in free_vars_of_kept_funs) *)
Variable.Map.partition (fun fun_id _ ->
Variable.Set.mem fun_id free_vars_of_kept_funs
|| Closure_id.Tbl.mem used_closure_ids
(Closure_id.wrap fun_id))
remaining_funs
in
if Variable.Map.is_empty new_needed_funs then
(* If no new function is needed, we reached fixpoint *)
needed_funs, free_vars_of_kept_funs
else begin
let needed_funs =
Variable.Map.disjoint_union needed_funs new_needed_funs
in
let free_vars_of_kept_funs =
Variable.Map.fold (fun _ { Flambda. free_variables } acc ->
Variable.Set.union free_variables acc)
new_needed_funs
free_vars_of_kept_funs
in
add_needed needed_funs remaining_funs free_vars_of_kept_funs
end
in
let funs, free_vars_of_kept_funs =
add_needed Variable.Map.empty function_decls.funs Variable.Set.empty
in
let free_vars =
Variable.Map.filter (fun id _var ->
Variable.Set.mem id all_free_vars
Variable.Set.mem id free_vars_of_kept_funs
|| Var_within_closure.Tbl.mem
used_vars_within_closure
(Var_within_closure.wrap id))
free_vars
in
let funs =
Variable.Map.filter (fun fun_id _ ->
Variable.Set.mem fun_id all_free_vars
|| Closure_id.Tbl.mem
used_closure_ids
(Closure_id.wrap fun_id))
function_decls.funs
in
let function_decls =
Flambda.update_function_declarations function_decls ~funs
in