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

Reduce the size of cmx files in classic mode (flambda) (#1665) 

Reduce the size of cmx files in classic mode by keeping function bodies iff they can be inlined.
master
Xavier Clerc 2018-04-06 14:26:43 +01:00 committed by Leo White
parent 0bdab4b04c
commit 4d5852d3f9
27 changed files with 873 additions and 329 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Changes
View File

@ -347,6 +347,10 @@ Working version
- GPR#1663: refactor flambda specialise/inlining handling
(Leo White and Xavier Clerc, review by Pierre Chambart)
- GPR#1665: reduce the size of cmx files in classic mode by droping the
bodies of functions that will not be inlined
(Fuyong Quah, review by Leo White)
- GPR#1679 : remove Pbittest from primitives in lambda
(Hugo Heuzard, review by Mark Shinwell)

62
asmcomp/build_export_info.ml
View File

@ -503,23 +503,39 @@ let build_export_info ~(backend : (module Backend_intf.S))
let _global_symbol, env =
describe_program (Env.Global.create_empty ()) program
in
let function_declarations_approx (fun_decls : Flambda.function_declarations) =
let recursive =
lazy (Find_recursive_functions.in_function_declarations fun_decls ~backend)
in
let keep_body =
Inline_and_simplify_aux.keep_body_check
~is_classic_mode:fun_decls.is_classic_mode ~recursive
in
Simple_value_approx.function_declarations_approx ~keep_body fun_decls
in
let sets_of_closures =
Flambda_utils.all_function_decls_indexed_by_set_of_closures_id program
|> Set_of_closures_id.Map.map function_declarations_approx
in
let closures =
Flambda_utils.all_function_decls_indexed_by_closure_id program
in
let invariant_params =
Set_of_closures_id.Map.map
(fun { Flambda. function_decls; _ } ->
Invariant_params.invariant_params_in_recursion
~backend function_decls)
(Flambda_utils.all_sets_of_closures_map program)
|> Closure_id.Map.map function_declarations_approx
in
let unnested_values =
Env.Global.export_id_to_descr_map env
in
let invariant_params =
let invariant_params =
Set_of_closures_id.Map.map
(fun { Flambda. function_decls; _ } ->
if function_decls.is_classic_mode then begin
Variable.Map.empty
end else begin
Invariant_params.invariant_params_in_recursion
~backend function_decls
end)
(Flambda_utils.all_sets_of_closures_map program)
in
let export = Compilenv.approx_env () in
Export_id.Map.fold (fun _eid (descr:Export_info.descr)
(invariant_params) ->
@ -540,6 +556,37 @@ let build_export_info ~(backend : (module Backend_intf.S))
invariant_params)
unnested_values invariant_params
in
let recursive =
let recursive =
Set_of_closures_id.Map.map
(fun { Flambda. function_decls; _ } ->
if function_decls.is_classic_mode then begin
Variable.Set.empty
end else begin
Find_recursive_functions.in_function_declarations
~backend function_decls
end)
(Flambda_utils.all_sets_of_closures_map program)
in
let export = Compilenv.approx_env () in
Export_id.Map.fold (fun _eid (descr:Export_info.descr) recursive ->
match descr with
| Value_closure { set_of_closures }
| Value_set_of_closures set_of_closures ->
let { Export_info.set_of_closures_id } = set_of_closures in
begin match
Set_of_closures_id.Map.find set_of_closures_id
export.recursive
with
| exception Not_found ->
recursive
| (set:Variable.Set.t) ->
Set_of_closures_id.Map.add set_of_closures_id set recursive
end
| _ ->
recursive)
unnested_values recursive
in
let values =
Export_info.nest_eid_map unnested_values
in
@ -550,3 +597,4 @@ let build_export_info ~(backend : (module Backend_intf.S))
~sets_of_closures ~closures
~constant_sets_of_closures:Set_of_closures_id.Set.empty
~invariant_params
~recursive

3
asmcomp/compilenv.ml
View File

@ -39,7 +39,8 @@ let export_infos_table =
let imported_sets_of_closures_table =
(Set_of_closures_id.Tbl.create 10
: Flambda.function_declarations option Set_of_closures_id.Tbl.t)
: Simple_value_approx.function_declarations option
Set_of_closures_id.Tbl.t)
module CstMap =
Map.Make(struct

2
asmcomp/compilenv.mli
View File

@ -26,7 +26,7 @@ open Cmx_format
improvement feature.
*)
val imported_sets_of_closures_table
: Flambda.function_declarations option Set_of_closures_id.Tbl.t
: Simple_value_approx.function_declarations option Set_of_closures_id.Tbl.t
(* flambda-only *)
val reset: ?packname:string -> string -> unit

24
asmcomp/export_info.ml
View File

@ -16,6 +16,8 @@
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
module A = Simple_value_approx
type value_string_contents =
| Contents of string
| Unknown_or_mutable
@ -42,7 +44,7 @@ type descr =
| Value_constptr of int
| Value_float of float
| Value_float_array of value_float_array
| Value_boxed_int : 'a Simple_value_approx.boxed_int * 'a -> descr
| Value_boxed_int : 'a A.boxed_int * 'a -> descr
| Value_string of value_string
| Value_closure of value_closure
| Value_set_of_closures of value_set_of_closures
@ -115,7 +117,7 @@ let equal_descr (d1:descr) (d2:descr) : bool =
| Value_float_array s1, Value_float_array s2 ->
s1 = s2
| Value_boxed_int (t1, v1), Value_boxed_int (t2, v2) ->
Simple_value_approx.equal_boxed_int t1 v1 t2 v2
A.equal_boxed_int t1 v1 t2 v2
| Value_string s1, Value_string s2 ->
s1 = s2
| Value_closure c1, Value_closure c2 ->
@ -134,14 +136,15 @@ let equal_descr (d1:descr) (d2:descr) : bool =
false
type t = {
sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t;
closures : Flambda.function_declarations Closure_id.Map.t;
sets_of_closures : A.function_declarations Set_of_closures_id.Map.t;
closures : A.function_declarations Closure_id.Map.t;
values : descr Export_id.Map.t Compilation_unit.Map.t;
symbol_id : Export_id.t Symbol.Map.t;
offset_fun : int Closure_id.Map.t;
offset_fv : int Var_within_closure.Map.t;
constant_sets_of_closures : Set_of_closures_id.Set.t;
invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
recursive : Variable.Set.t Set_of_closures_id.Map.t;
}
let empty : t = {
@ -153,11 +156,12 @@ let empty : t = {
offset_fv = Var_within_closure.Map.empty;
constant_sets_of_closures = Set_of_closures_id.Set.empty;
invariant_params = Set_of_closures_id.Map.empty;
recursive = Set_of_closures_id.Map.empty;
}
let create ~sets_of_closures ~closures ~values ~symbol_id
~offset_fun ~offset_fv ~constant_sets_of_closures
~invariant_params =
~invariant_params ~recursive =
{ sets_of_closures;
closures;
values;
@ -166,6 +170,7 @@ let create ~sets_of_closures ~closures ~values ~symbol_id
offset_fv;
constant_sets_of_closures;
invariant_params;
recursive;
}
let add_clambda_info t ~offset_fun ~offset_fv ~constant_sets_of_closures =
@ -204,6 +209,11 @@ let merge (t1 : t) (t2 : t) : t =
~print:(Variable.Map.print Variable.Set.print)
~eq:(Variable.Map.equal Variable.Set.equal)
t1.invariant_params t2.invariant_params;
recursive =
Set_of_closures_id.Map.disjoint_union
~print:Variable.Set.print
~eq:Variable.Set.equal
t1.recursive t2.recursive;
}
let find_value eid map =
@ -287,7 +297,6 @@ let print_approx ppf ((t,root_symbols) : t * Symbol.t list) =
| Contents _ -> "_imm")
float_array.size
| Value_boxed_int (t, i) ->
let module A = Simple_value_approx in
match t with
| A.Int32 -> Format.fprintf ppf "%li" i
| A.Int64 -> Format.fprintf ppf "%Li" i
@ -350,7 +359,8 @@ let print_offsets ppf (t : t) =
Format.fprintf ppf "@]@ "
let print_functions ppf (t : t) =
Set_of_closures_id.Map.print Flambda.print_function_declarations ppf
Set_of_closures_id.Map.print
A.print_function_declarations ppf
t.sets_of_closures
let print_all ppf ((t, root_symbols) : t * Symbol.t list) =

14
asmcomp/export_info.mli
View File

@ -19,6 +19,8 @@
(** Exported information (that is to say, information written into a .cmx
file) about a compilation unit. *)
module A = Simple_value_approx
type value_string_contents =
| Contents of string
| Unknown_or_mutable
@ -45,7 +47,7 @@ type descr =
| Value_constptr of int
| Value_float of float
| Value_float_array of value_float_array
| Value_boxed_int : 'a Simple_value_approx.boxed_int * 'a -> descr
| Value_boxed_int : 'a A.boxed_int * 'a -> descr
| Value_string of value_string
| Value_closure of value_closure
| Value_set_of_closures of value_set_of_closures
@ -77,9 +79,9 @@ and approx =
(** A structure that describes what a single compilation unit exports. *)
type t = private {
sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t;
sets_of_closures : A.function_declarations Set_of_closures_id.Map.t;
(** Code of exported functions indexed by set of closures IDs. *)
closures : Flambda.function_declarations Closure_id.Map.t;
closures : A.function_declarations Closure_id.Map.t;
(** Code of exported functions indexed by closure IDs. *)
values : descr Export_id.Map.t Compilation_unit.Map.t;
(** Structure of exported values. *)
@ -94,6 +96,7 @@ type t = private {
invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
(* Function parameters known to be invariant (see [Invariant_params])
indexed by set of closures ID. *)
recursive : Variable.Set.t Set_of_closures_id.Map.t;
}
(** Export information for a compilation unit that exports nothing. *)
@ -101,14 +104,15 @@ val empty : t
(** Create a new export information structure. *)
val create
: sets_of_closures:Flambda.function_declarations Set_of_closures_id.Map.t
-> closures:Flambda.function_declarations Closure_id.Map.t
: sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t)
-> closures:A.function_declarations Closure_id.Map.t
-> values:descr Export_id.Map.t Compilation_unit.Map.t
-> symbol_id:Export_id.t Symbol.Map.t
-> offset_fun:int Closure_id.Map.t
-> offset_fv:int Var_within_closure.Map.t
-> constant_sets_of_closures:Set_of_closures_id.Set.t
-> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t
-> recursive:Variable.Set.t Set_of_closures_id.Map.t
-> t
(* CR-someday pchambart: Should we separate [t] in 2 types: one created by the

54
asmcomp/export_info_for_pack.ml
View File

@ -16,11 +16,16 @@
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
module A = Simple_value_approx
let rename_id_state = Export_id.Tbl.create 100
let rename_set_of_closures_id_state = Set_of_closures_id.Tbl.create 10
let imported_function_declarations_table =
let imported_flambda_function_declarations_table =
(Set_of_closures_id.Tbl.create 10
: Flambda.function_declarations Set_of_closures_id.Tbl.t)
let imported_a_function_declarations_table =
(Set_of_closures_id.Tbl.create 10
: A.function_declarations Set_of_closures_id.Tbl.t)
(* Rename export identifiers' compilation units to denote that they now
live within a pack. *)
@ -135,7 +140,8 @@ let rec import_code_for_pack units pack expr =
and import_function_declarations_for_pack_aux units pack
(function_decls : Flambda.function_declarations) =
let funs =
Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
Variable.Map.map
(fun (function_decl : Flambda.function_declaration) ->
Flambda.create_function_declaration ~params:function_decl.params
~body:(import_code_for_pack units pack function_decl.body)
~stub:function_decl.stub ~dbg:function_decl.dbg
@ -153,14 +159,44 @@ and import_function_declarations_for_pack units pack
(function_decls:Flambda.function_declarations) =
let original_set_of_closures_id = function_decls.set_of_closures_id in
try
Set_of_closures_id.Tbl.find imported_function_declarations_table
Set_of_closures_id.Tbl.find imported_flambda_function_declarations_table
original_set_of_closures_id
with Not_found ->
let function_decls =
import_function_declarations_for_pack_aux units pack function_decls
in
Set_of_closures_id.Tbl.add
imported_function_declarations_table
imported_flambda_function_declarations_table
original_set_of_closures_id
function_decls;
function_decls
let import_function_declarations_approx_for_pack_aux units pack
(function_decls : A.function_declarations) : A.function_declarations =
let funs =
Variable.Map.map
(fun (function_decl : A.function_declaration) ->
A.update_function_declaration_body function_decl
(fun body -> import_code_for_pack units pack body))
function_decls.funs
in
A.import_function_declarations_for_pack
(A.update_function_declarations function_decls ~funs)
(import_set_of_closures_id_for_pack units pack)
(import_set_of_closures_origin_for_pack units pack)
let import_function_declarations_approx_for_pack units pack
(function_decls: A.function_declarations) =
let original_set_of_closures_id = function_decls.set_of_closures_id in
try
Set_of_closures_id.Tbl.find imported_a_function_declarations_table
original_set_of_closures_id
with Not_found ->
let function_decls =
import_function_declarations_approx_for_pack_aux units pack function_decls
in
Set_of_closures_id.Tbl.add
imported_a_function_declarations_table
original_set_of_closures_id
function_decls;
function_decls
@ -184,7 +220,7 @@ let import_for_pack ~pack_units ~pack (exp : Export_info.t) =
import_set_of_closures_id_for_pack pack_units pack
in
let import_function_declarations =
import_function_declarations_for_pack pack_units pack
import_function_declarations_approx_for_pack pack_units pack
in
let sets_of_closures =
Set_of_closures_id.Map.map_keys import_set_of_closures_id
@ -193,7 +229,7 @@ let import_for_pack ~pack_units ~pack (exp : Export_info.t) =
exp.sets_of_closures)
in
Export_info.create ~sets_of_closures
~closures:(Flambda_utils.make_closure_map' sets_of_closures)
~closures:(A.make_closure_map sets_of_closures)
~offset_fun:exp.offset_fun
~offset_fv:exp.offset_fv
~values:(import_eidmap import_descr exp.values)
@ -205,8 +241,12 @@ let import_for_pack ~pack_units ~pack (exp : Export_info.t) =
~invariant_params:
(Set_of_closures_id.Map.map_keys import_set_of_closures_id
exp.invariant_params)
~recursive:
(Set_of_closures_id.Map.map_keys import_set_of_closures_id
exp.recursive)
let clear_import_state () =
Set_of_closures_id.Tbl.clear imported_function_declarations_table;
Set_of_closures_id.Tbl.clear imported_flambda_function_declarations_table;
Set_of_closures_id.Tbl.clear imported_a_function_declarations_table;
Set_of_closures_id.Tbl.clear rename_set_of_closures_id_state;
Export_id.Tbl.clear rename_id_state

23
asmcomp/flambda_to_clambda.ml
View File

@ -16,21 +16,21 @@
[@@@ocaml.warning "+a-4-9-30-40-41-42"]
type for_one_or_more_units = {
type 'a for_one_or_more_units = {
fun_offset_table : int Closure_id.Map.t;
fv_offset_table : int Var_within_closure.Map.t;
closures : Flambda.function_declarations Closure_id.Map.t;
closures : 'a Closure_id.Map.t;
constant_sets_of_closures : Set_of_closures_id.Set.t;
}
type t = {
current_unit : for_one_or_more_units;
imported_units : for_one_or_more_units;
current_unit : Set_of_closures_id.t for_one_or_more_units;
imported_units : Simple_value_approx.function_declarations for_one_or_more_units;
}
type ('a, 'b) declaration_position =
| Current_unit of 'a
| Imported_unit of 'b
type declaration_position =
| Current_unit of Set_of_closures_id.t
| Imported_unit of Set_of_closures_id.t
| Not_declared
let get_fun_offset t closure_id =
@ -61,15 +61,18 @@ let function_declaration_position t closure_id =
Current_unit (Closure_id.Map.find closure_id t.current_unit.closures)
with Not_found ->
try
Imported_unit (Closure_id.Map.find closure_id t.imported_units.closures)
let function_decls =
Closure_id.Map.find closure_id t.imported_units.closures
in
Imported_unit function_decls.set_of_closures_id
with Not_found -> Not_declared
let is_function_constant t closure_id =
match function_declaration_position t closure_id with
| Current_unit { set_of_closures_id } ->
| Current_unit set_of_closures_id ->
Set_of_closures_id.Set.mem set_of_closures_id
t.current_unit.constant_sets_of_closures
| Imported_unit { set_of_closures_id } ->
| Imported_unit set_of_closures_id ->
Set_of_closures_id.Set.mem set_of_closures_id
t.imported_units.constant_sets_of_closures
| Not_declared ->

85
asmcomp/import_approx.ml
View File

@ -19,11 +19,11 @@
module A = Simple_value_approx
let import_set_of_closures =
let import_function_declarations (clos : Flambda.function_declarations)
: Flambda.function_declarations =
let import_function_declarations (clos : A.function_declarations)
: A.function_declarations =
(* CR-soon mshinwell for pchambart: Do we still need to do this
rewriting? I'm wondering if maybe we don't have to any more. *)
let sym_to_fun_var_map (clos : Flambda.function_declarations) =
let sym_to_fun_var_map (clos : A.function_declarations) =
Variable.Map.fold (fun fun_var _ acc ->
let closure_id = Closure_id.wrap fun_var in
let sym = Compilenv.closure_symbol closure_id in
@ -40,18 +40,12 @@ let import_set_of_closures =
| named -> named
in
let funs =
Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
let body =
Flambda_iterators.map_toplevel_named f_named function_decl.body
in
Flambda.create_function_declaration ~params:function_decl.params
~body ~stub:function_decl.stub ~dbg:function_decl.dbg
~inline:function_decl.inline
~specialise:function_decl.specialise
~is_a_functor:function_decl.is_a_functor)
Variable.Map.map (fun (function_decl : A.function_declaration) ->
A.update_function_declaration_body function_decl
(Flambda_iterators.map_toplevel_named f_named))
clos.funs
in
Flambda.update_function_declarations clos ~funs
A.update_function_declarations clos ~funs
in
let aux set_of_closures_id =
ignore (Compilenv.approx_for_global
@ -77,27 +71,50 @@ let rec import_ex ex =
let import_value_set_of_closures ~set_of_closures_id ~bound_vars ~free_vars
~(ex_info : Export_info.t) ~what : A.value_set_of_closures option =
let bound_vars = Var_within_closure.Map.map import_approx bound_vars in
match
Set_of_closures_id.Map.find set_of_closures_id ex_info.invariant_params
with
| exception Not_found ->
Misc.fatal_errorf "Set of closures ID %a not found in invariant_params \
(when importing [%a: %s])"
Set_of_closures_id.print set_of_closures_id
Export_id.print ex
what
| invariant_params ->
match import_set_of_closures set_of_closures_id with
| None -> None
| Some function_decls ->
Some (A.create_value_set_of_closures
~function_decls
~bound_vars
~free_vars
~invariant_params:(lazy invariant_params)
~specialised_args:Variable.Map.empty
~freshening:Freshening.Project_var.empty
~direct_call_surrogates:Closure_id.Map.empty)
match import_set_of_closures set_of_closures_id with
| None -> None
| Some function_decls ->
let is_classic_mode = function_decls.is_classic_mode in
let invariant_params =
match
Set_of_closures_id.Map.find set_of_closures_id
ex_info.invariant_params
with
| exception Not_found ->
if is_classic_mode then
Variable.Map.empty
else
Misc.fatal_errorf "Set of closures ID %a not found in \
invariant_params (when importing [%a: %s])"
Set_of_closures_id.print set_of_closures_id
Export_id.print ex
what
| found -> found
in
let recursive =
match
Set_of_closures_id.Map.find set_of_closures_id ex_info.recursive
with
| exception Not_found ->
if is_classic_mode then
Variable.Set.empty
else
Misc.fatal_errorf "Set of closures ID %a not found in \
recursive (when importing [%a: %s])"
Set_of_closures_id.print set_of_closures_id
Export_id.print ex
what
| found -> found
in
Some (A.create_value_set_of_closures
~function_decls
~bound_vars
~free_vars
~invariant_params:(lazy invariant_params)
~recursive:(lazy recursive)
~specialised_args:Variable.Map.empty
~freshening:Freshening.Project_var.empty
~direct_call_surrogates:Closure_id.Map.empty)
in
match Export_info.find_description ex_info ex with
| exception Not_found -> A.value_unknown Other

10
middle_end/closure_conversion.ml
View File

@ -590,10 +590,12 @@ and close_functions t external_env function_declarations : Flambda.named =
(Variable.Map.add closure_bound_var generic_function_stub map)
in
let function_decls =
Flambda.create_function_declarations
~funs:
(List.fold_left close_one_function Variable.Map.empty
(Function_decls.to_list function_declarations))
let is_classic_mode = !Clflags.classic_inlining in
let funs =
List.fold_left close_one_function Variable.Map.empty
(Function_decls.to_list function_declarations)
in
Flambda.create_function_declarations ~is_classic_mode ~funs
in
(* The closed representation of a set of functions is a "set of closures".
(For avoidance of doubt, the runtime representation of the *whole set* is

49
middle_end/flambda.ml
View File

@ -109,6 +109,7 @@ and set_of_closures = {
}
and function_declarations = {
is_classic_mode : bool;
set_of_closures_id : Set_of_closures_id.t;
set_of_closures_origin : Set_of_closures_origin.t;
funs : function_declaration Variable.Map.t;
@ -1016,33 +1017,63 @@ let update_function_declaration fun_decl ~params ~body =
let free_symbols = free_symbols body in
{ fun_decl with params; body; free_variables; free_symbols }
let create_function_declarations ~funs =
let create_function_declarations ~is_classic_mode ~funs =
let compilation_unit = Compilation_unit.get_current_exn () in
let set_of_closures_id = Set_of_closures_id.create compilation_unit in
let set_of_closures_origin =
Set_of_closures_origin.create set_of_closures_id
in
{ set_of_closures_id;
{ is_classic_mode;
set_of_closures_id;
set_of_closures_origin;
funs;
}
let create_function_declarations_with_origin
~is_classic_mode ~funs ~set_of_closures_origin =
let compilation_unit = Compilation_unit.get_current_exn () in
let set_of_closures_id = Set_of_closures_id.create compilation_unit in
{ is_classic_mode;
set_of_closures_id;
set_of_closures_origin;
funs;
}
let update_function_declarations function_decls ~funs =
let is_classic_mode = function_decls.is_classic_mode in
let compilation_unit = Compilation_unit.get_current_exn () in
let set_of_closures_id = Set_of_closures_id.create compilation_unit in
let set_of_closures_origin = function_decls.set_of_closures_origin in
{ set_of_closures_id;
{ is_classic_mode;
set_of_closures_id;
set_of_closures_origin;
funs;
}
let create_function_declarations_with_closures_origin
~is_classic_mode ~funs ~set_of_closures_origin =
let compilation_unit = Compilation_unit.get_current_exn () in
let set_of_closures_id = Set_of_closures_id.create compilation_unit in
{ is_classic_mode;
set_of_closures_id;
set_of_closures_origin;
funs
}
let import_function_declarations_for_pack function_decls
import_set_of_closures_id import_set_of_closures_origin =
{ set_of_closures_id =
import_set_of_closures_id function_decls.set_of_closures_id;
set_of_closures_origin =
import_set_of_closures_origin function_decls.set_of_closures_origin;
funs = function_decls.funs;
import_set_of_closures_id import_set_of_closures_origin =
let is_classic_mode = function_decls.is_classic_mode in
let set_of_closures_id =
import_set_of_closures_id function_decls.set_of_closures_id
in
let set_of_closures_origin =
import_set_of_closures_origin function_decls.set_of_closures_origin
in
let funs = function_decls.funs in
{ is_classic_mode;
set_of_closures_id;
set_of_closures_origin;
funs;
}
let create_set_of_closures ~function_decls ~free_vars ~specialised_args

20
middle_end/flambda.mli
View File

@ -281,6 +281,9 @@ and set_of_closures = private {
}
and function_declarations = private {
is_classic_mode: bool;
(** Indicates whether this [function_declarations] was compiled
with -Oclassic. *)
set_of_closures_id : Set_of_closures_id.t;
(** An identifier (unique across all Flambda trees currently in memory)
of the set of closures associated with this set of function
@ -560,7 +563,16 @@ val update_function_declaration
(** Create a set of function declarations given the individual declarations. *)
val create_function_declarations
: funs:function_declaration Variable.Map.t
: is_classic_mode:bool
-> funs:function_declaration Variable.Map.t
-> function_declarations
(** Create a set of function declarations with a given set of closures
origin. *)
val create_function_declarations_with_origin
: is_classic_mode:bool
-> funs:function_declaration Variable.Map.t
-> set_of_closures_origin:Set_of_closures_origin.t
-> function_declarations
(** Create a set of function declarations based on another set of function
@ -570,6 +582,12 @@ val update_function_declarations
-> funs:function_declaration Variable.Map.t
-> function_declarations
val create_function_declarations_with_closures_origin
: is_classic_mode: bool
-> funs:function_declaration Variable.Map.t
-> set_of_closures_origin:Set_of_closures_origin.t
-> function_declarations
val import_function_declarations_for_pack
: function_declarations
-> (Set_of_closures_id.t -> Set_of_closures_id.t)

4
middle_end/flambda_invariants.ml
View File

@ -265,9 +265,11 @@ let variable_and_symbol_invariants (program : Flambda.program) =
({ Flambda.function_decls; free_vars; specialised_args;
direct_call_surrogates = _; } as set_of_closures) =
(* CR-soon mshinwell: check [direct_call_surrogates] *)
let { Flambda.set_of_closures_id; set_of_closures_origin; funs; } =
let { Flambda. is_classic_mode;
set_of_closures_id; set_of_closures_origin; funs; } =
function_decls
in
ignore (is_classic_mode : bool);
ignore_set_of_closures_id set_of_closures_id;
ignore_set_of_closures_origin set_of_closures_origin;
let functions_in_closure = Variable.Map.keys funs in

18
middle_end/flambda_utils.ml
View File

@ -315,7 +315,8 @@ let toplevel_substitution_named sb named =
| Let let_expr -> let_expr.defining_expr
| _ -> assert false
let make_closure_declaration ~id ~body ~params ~stub : Flambda.t =
let make_closure_declaration
~is_classic_mode ~id ~body ~params ~stub : Flambda.t =
let free_variables = Flambda.free_variables body in
let param_set = Parameter.Set.vars params in
if not (Variable.Set.subset param_set free_variables) then begin
@ -360,6 +361,7 @@ let make_closure_declaration ~id ~body ~params ~stub : Flambda.t =
let set_of_closures =
let function_decls =
Flambda.create_function_declarations
~is_classic_mode
~funs:(Variable.Map.singleton id function_declaration)
in
Flambda.create_set_of_closures ~function_decls ~free_vars
@ -463,7 +465,8 @@ let make_closure_map program =
{ function_decls } ->
Variable.Map.iter (fun var _ ->
let closure_id = Closure_id.wrap var in
map := Closure_id.Map.add closure_id function_decls !map)
let set_of_closures_id = function_decls.set_of_closures_id in
map := Closure_id.Map.add closure_id set_of_closures_id !map)
function_decls.funs
in
Flambda_iterators.iter_on_set_of_closures_of_program
@ -471,17 +474,6 @@ let make_closure_map program =
~f:add_set_of_closures;
!map
let make_closure_map' input =
let map = ref Closure_id.Map.empty in
let add_set_of_closures _ (function_decls : Flambda.function_declarations) =
Variable.Map.iter (fun var _ ->
let closure_id = Closure_id.wrap var in
map := Closure_id.Map.add closure_id function_decls !map)
function_decls.funs
in
Set_of_closures_id.Map.iter add_set_of_closures input;
!map
let all_lifted_constant_sets_of_closures program =
let set = ref Set_of_closures_id.Set.empty in
List.iter (function

13
middle_end/flambda_utils.mli
View File

@ -63,7 +63,8 @@ val description_of_toplevel_node : Flambda.t -> string
lwhite: the params restriction seems odd, perhaps give a reason
in the comment. *)
val make_closure_declaration
: id:Variable.t
: is_classic_mode:bool
-> id:Variable.t
-> body:Flambda.t
-> params:Parameter.t list
-> stub:bool
@ -107,17 +108,11 @@ val root_symbol : Flambda.program -> Symbol.t
exception. *)
val might_raise_static_exn : Flambda.named -> Static_exception.t -> bool
(** Creates a map from closure IDs to function declarations by iterating over
(** Creates a map from closure IDs to set_of_closure IDs by iterating over
all sets of closures in the given program. *)
val make_closure_map
: Flambda.program
-> Flambda.function_declarations Closure_id.Map.t
(** Like [make_closure_map], but takes a mapping from set of closures IDs to
function declarations, instead of a [program]. *)
val make_closure_map'
: Flambda.function_declarations Set_of_closures_id.Map.t
-> Flambda.function_declarations Closure_id.Map.t
-> Set_of_closures_id.t Closure_id.Map.t
(** The definitions of all constants that have been lifted out to [Let_symbol]
or [Let_rec_symbol] constructions. *)

6
middle_end/freshening.ml
View File

@ -197,7 +197,11 @@ let rewrite_recursive_calls_with_symbols t
| Inactive -> function_declarations
| Active _ ->
let all_free_symbols =
Flambda_utils.all_free_symbols function_declarations
Variable.Map.fold
(fun _ (function_decl : Flambda.function_declaration)
syms ->
Symbol.Set.union syms function_decl.free_symbols)
function_declarations.funs Symbol.Set.empty
in
let closure_symbols_used = ref false in
let closure_symbols =

64
middle_end/inline_and_simplify.ml
View File

@ -599,31 +599,10 @@ and simplify_set_of_closures original_env r
~dbg:function_decl.dbg
~f:(fun body_env -> simplify body_env r function_decl.body)
in
let inline : Lambda.inline_attribute =
match function_decl.inline with
| Default_inline ->
if !Clflags.classic_inlining && not function_decl.stub then
(* In classic-inlining mode, the inlining decision is taken at
definition site (here). If the function is small enough
(below the -inline threshold) it will always be inlined. *)
let inlining_threshold =
Inline_and_simplify_aux.initial_inlining_threshold
~round:(E.round env)
in
if Inlining_cost.can_inline body inlining_threshold ~bonus:0
then
Always_inline
else
Default_inline
else
Default_inline
| inline ->
inline
in
let function_decl =
Flambda.create_function_declaration ~params:function_decl.params
~body ~stub:function_decl.stub ~dbg:function_decl.dbg
~inline ~specialise:function_decl.specialise
~inline:function_decl.inline ~specialise:function_decl.specialise
~is_a_functor:function_decl.is_a_functor
in
let used_params' = Flambda.used_params function_decl in
@ -641,10 +620,23 @@ and simplify_set_of_closures original_env r
lazy (Invariant_params.invariant_params_in_recursion function_decls
~backend:(E.backend env))
in
let recursive =
lazy (Find_recursive_functions.in_function_declarations function_decls
~backend:(E.backend env))
in
let keep_body =
Inline_and_simplify_aux.keep_body_check
~is_classic_mode:function_decls.is_classic_mode ~recursive
in
let function_decls_approx =
A.function_declarations_approx ~keep_body function_decls
in
let value_set_of_closures =
A.create_value_set_of_closures ~function_decls
A.create_value_set_of_closures
~function_decls:function_decls_approx
~bound_vars:internal_value_set_of_closures.bound_vars
~invariant_params
~recursive
~specialised_args:internal_value_set_of_closures.specialised_args
~free_vars:internal_value_set_of_closures.free_vars
~freshening:internal_value_set_of_closures.freshening
@ -727,8 +719,9 @@ and simplify_apply env r ~(apply : Flambda.apply) : Flambda.t * R.t =
let function_decls = value_set_of_closures.function_decls in
let function_decl =
try
Flambda_utils.find_declaration closure_id_being_applied
function_decls
Variable.Map.find
(Closure_id.unwrap closure_id_being_applied)
function_decls.funs
with
| Not_found ->
Misc.fatal_errorf "When handling application expression, \
@ -742,7 +735,7 @@ and simplify_apply env r ~(apply : Flambda.apply) : Flambda.t * R.t =
| Direct _ -> r
in
let nargs = List.length args in
let arity = Flambda_utils.function_arity function_decl in
let arity = A.function_arity function_decl in
let result, r =
if nargs = arity then
simplify_full_application env r ~function_decls
@ -780,7 +773,7 @@ and simplify_full_application env r ~function_decls ~lhs_of_application
and simplify_partial_application env r ~lhs_of_application
~closure_id_being_applied ~function_decl ~args ~dbg
~inline_requested ~specialise_requested =
let arity = Flambda_utils.function_arity function_decl in
let arity = A.function_arity function_decl in
assert (arity > List.length args);
(* For simplicity, we disallow [@inline] attributes on partial
applications. The user may always write an explicit wrapper instead
@ -807,7 +800,7 @@ and simplify_partial_application env r ~lhs_of_application
| Default_specialise -> ()
end;
let freshened_params =
List.map (fun p -> Parameter.rename p) function_decl.Flambda.params
List.map (fun p -> Parameter.rename p) function_decl.A.params
in
let applied_args, remaining_args =
Misc.Stdlib.List.map2_prefix (fun arg id' -> id', arg)
@ -830,6 +823,7 @@ and simplify_partial_application env r ~lhs_of_application
(Closure_id.unwrap closure_id_being_applied)
in
Flambda_utils.make_closure_declaration ~id:closure_variable
~is_classic_mode:false
~body
~params:remaining_args
~stub:true
@ -845,7 +839,7 @@ and simplify_partial_application env r ~lhs_of_application
and simplify_over_application env r ~args ~args_approxs ~function_decls
~lhs_of_application ~closure_id_being_applied ~function_decl
~value_set_of_closures ~dbg ~inline_requested ~specialise_requested =
let arity = Flambda_utils.function_arity function_decl in
let arity = A.function_arity function_decl in
assert (arity < List.length args);
assert (List.length args = List.length args_approxs);
let full_app_args, remaining_args =
@ -1455,10 +1449,22 @@ let constant_defining_value_approx
lazy (Invariant_params.invariant_params_in_recursion function_decls
~backend:(E.backend env))
in
let recursive =
lazy (Find_recursive_functions.in_function_declarations function_decls
~backend:(E.backend env))
in
let value_set_of_closures =
let keep_body =
Inline_and_simplify_aux.keep_body_check
~is_classic_mode:function_decls.is_classic_mode ~recursive
in
let function_decls =
A.function_declarations_approx ~keep_body function_decls
in
A.create_value_set_of_closures ~function_decls
~bound_vars:Var_within_closure.Map.empty
~invariant_params
~recursive
~specialised_args:Variable.Map.empty
~free_vars:Variable.Map.empty
~freshening:Freshening.Project_var.empty

43
middle_end/inline_and_simplify_aux.ml
View File

@ -512,6 +512,38 @@ end
module A = Simple_value_approx
module E = Env
let keep_body_check ~is_classic_mode ~recursive =
if not is_classic_mode then begin
fun _ _ -> true
end else begin
let can_inline_non_rec_function (fun_decl : Flambda.function_declaration) =
(* In classic-inlining mode, the inlining decision is taken at
definition site (here). If the function is small enough
(below the -inline threshold) it will always be inlined.
Closure gives a bonus of [8] to optional arguments. In classic
mode, however, we would inline functions with the "*opt*" argument
in all cases, as it is a stub. (This is ensured by
[middle_end/closure_conversion.ml]).
*)
let inlining_threshold = initial_inlining_threshold ~round:0 in
let bonus = Flambda_utils.function_arity fun_decl in
Inlining_cost.can_inline fun_decl.body inlining_threshold ~bonus
in
fun (var : Variable.t) (fun_decl : Flambda.function_declaration) ->
if fun_decl.stub then begin
true
end else if Variable.Set.mem var (Lazy.force recursive) then begin
false
end else begin
match fun_decl.inline with
| Default_inline -> can_inline_non_rec_function fun_decl
| Unroll factor -> factor > 0
| Always_inline -> true
| Never_inline -> false
end
end
let prepare_to_simplify_set_of_closures ~env
~(set_of_closures : Flambda.set_of_closures)
~function_decls ~freshen
@ -619,9 +651,16 @@ let prepare_to_simplify_set_of_closures ~env
free_vars Var_within_closure.Map.empty
in
let free_vars = Variable.Map.map fst free_vars in
let invariant_params = lazy Variable.Map.empty in
let recursive = lazy (Variable.Map.keys function_decls.funs) in
let is_classic_mode = function_decls.is_classic_mode in
let keep_body = keep_body_check ~is_classic_mode ~recursive in
let function_decls =
A.function_declarations_approx ~keep_body function_decls
in
A.create_value_set_of_closures ~function_decls ~bound_vars
~invariant_params:(lazy Variable.Map.empty) ~specialised_args
~free_vars ~freshening ~direct_call_surrogates
~free_vars ~invariant_params ~recursive ~specialised_args
~freshening ~direct_call_surrogates
in
(* Populate the environment with the approximation of each closure.
This part of the environment is shared between all of the closures in

7
middle_end/inline_and_simplify_aux.mli
View File

@ -361,3 +361,10 @@ val prepare_to_simplify_closure
-> parameter_approximations:Simple_value_approx.t Variable.Map.t
-> set_of_closures_env:Env.t
-> Env.t
val keep_body_check
: is_classic_mode:bool
-> recursive:Variable.Set.t Lazy.t
-> Variable.t
-> Flambda.function_declaration
-> bool

260
middle_end/inlining_decision.ml
View File

@ -19,7 +19,6 @@
module A = Simple_value_approx
module E = Inline_and_simplify_aux.Env
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
@ -34,26 +33,23 @@ type 'b good_idea =
| Don't_try_it of 'b
let inline env r ~lhs_of_application
~(function_decls : Flambda.function_declarations)
~closure_id_being_applied ~(function_decl : Flambda.function_declaration)
~closure_id_being_applied
~(function_decl : A.function_declaration)
~(function_body : A.function_body)
~value_set_of_closures ~only_use_of_function ~original ~recursive
~(args : Variable.t list) ~size_from_approximation ~dbg ~simplify
~(inline_requested : Lambda.inline_attribute)
~(specialise_requested : Lambda.specialise_attribute)
~fun_vars ~set_of_closures_origin
~self_call ~fun_cost ~inlining_threshold =
let toplevel = E.at_toplevel env in
let branch_depth = E.branch_depth env in
let unrolling, always_inline, never_inline, env =
let unrolling =
E.actively_unrolling env function_decls.set_of_closures_origin
in
let unrolling = E.actively_unrolling env set_of_closures_origin in
match unrolling with
| Some count ->
if count > 0 then
let env =
E.continue_actively_unrolling
env function_decls.set_of_closures_origin
in
let env = E.continue_actively_unrolling env set_of_closures_origin in
true, true, false, env
else false, false, true, env
| None -> begin
@ -62,7 +58,7 @@ let inline env r ~lhs_of_application
The call site annotation takes precedence *)
match (inline_requested : Lambda.inline_attribute) with
| Always_inline | Never_inline | Unroll _ -> inline_requested
| Default_inline -> function_decl.inline
| Default_inline -> function_body.inline
in
match inline_annotation with
| Always_inline -> false, true, false, env
@ -72,7 +68,7 @@ let inline env r ~lhs_of_application
if count > 0 then
let env =
E.start_actively_unrolling
env function_decls.set_of_closures_origin (count - 1)
env set_of_closures_origin (count - 1)
in
true, true, false, env
else false, false, true, env
@ -93,9 +89,7 @@ let inline env r ~lhs_of_application
Try_it
else if never_inline then
Don't_try_it S.Not_inlined.Annotation
else if !Clflags.classic_inlining then
Don't_try_it S.Not_inlined.Classic_mode
else if not (E.unrolling_allowed env function_decls.set_of_closures_origin)
else if not (E.unrolling_allowed env set_of_closures_origin)
&& (Lazy.force recursive) then
Don't_try_it S.Not_inlined.Unrolling_depth_exceeded
else if remaining_inlining_threshold = T.Never_inline then
@ -152,14 +146,14 @@ let inline env r ~lhs_of_application
else acc
| None -> acc
with Not_found -> acc)
function_decl.free_variables benefit
function_body.free_variables benefit
in
W.create_estimate
~original_size:Inlining_cost.direct_call_size
~new_size:body_size
~toplevel:(E.at_toplevel env)
~branch_depth:(E.branch_depth env)
~lifting:function_decl.Flambda.is_a_functor
~lifting:function_body.A.is_a_functor
~round:(E.round env)
~benefit
in
@ -190,9 +184,9 @@ let inline env r ~lhs_of_application
the function, without doing any further inlining upon it, to the call
site. *)
Inlining_transforms.inline_by_copying_function_body ~env
~r:(R.reset_benefit r) ~function_decls ~lhs_of_application
~r:(R.reset_benefit r) ~lhs_of_application
~closure_id_being_applied ~specialise_requested ~inline_requested
~function_decl ~args ~dbg ~simplify
~function_decl ~function_body ~fun_vars ~args ~dbg ~simplify
in
let num_direct_applications_seen =
(R.num_direct_applications r_inlined) - (R.num_direct_applications r)
@ -220,7 +214,7 @@ let inline env r ~lhs_of_application
let env =
(* We decrement the unrolling count even if the function is not
recursive to avoid having to check whether or not it is recursive *)
E.inside_unrolled_function env function_decls.set_of_closures_origin
E.inside_unrolled_function env set_of_closures_origin
in
let env = E.inside_inlined_function env closure_id_being_applied in
let env =
@ -242,7 +236,7 @@ let inline env r ~lhs_of_application
W.create ~original body
~toplevel:(E.at_toplevel env)
~branch_depth:(E.branch_depth env)
~lifting:function_decl.Flambda.is_a_functor
~lifting:function_body.is_a_functor
~round:(E.round env)
~benefit:(R.benefit r_inlined)
in
@ -261,14 +255,14 @@ let inline env r ~lhs_of_application
let env =
(* We decrement the unrolling count even if the function is recursive
to avoid having to check whether or not it is recursive *)
E.inside_unrolled_function env function_decls.set_of_closures_origin
E.inside_unrolled_function env set_of_closures_origin
in
let body, r_inlined = simplify env r_inlined body in
let wsb_with_subfunctions =
W.create ~original body
~toplevel:(E.at_toplevel env)
~branch_depth:(E.branch_depth env)
~lifting:function_decl.Flambda.is_a_functor
~lifting:function_body.is_a_functor
~round:(E.round env)
~benefit:(R.benefit r_inlined)
in
@ -298,37 +292,15 @@ let inline env r ~lhs_of_application
end
let specialise env r ~lhs_of_application
~(function_decls : Flambda.function_declarations)
~(function_decl : Flambda.function_declaration)
~(function_decls : A.function_declarations)
~(function_decl : A.function_declaration)
~closure_id_being_applied
~(value_set_of_closures : Simple_value_approx.value_set_of_closures)
~(value_set_of_closures : A.value_set_of_closures)
~args ~args_approxs ~dbg ~simplify ~original ~recursive ~self_call
~inlining_threshold ~fun_cost
~inline_requested ~specialise_requested =
let bound_vars =
lazy
(let closures_required =
Flambda_utils.closures_required_by_entry_point
~entry_point:closure_id_being_applied
~backend:(E.backend env)
function_decls
in
let bound_vars_required =
Variable.Set.fold (fun fun_var bound_vars_required ->
let bound_vars =
Flambda_utils.variables_bound_by_the_closure
(Closure_id.wrap fun_var)
function_decls
in
Variable.Set.union bound_vars bound_vars_required)
closures_required
Variable.Set.empty
in
Var_within_closure.Map.filter (fun var _approx ->
Variable.Set.mem (Var_within_closure.unwrap var) bound_vars_required)
value_set_of_closures.bound_vars)
in
let invariant_params = value_set_of_closures.invariant_params in
let free_vars = value_set_of_closures.free_vars in
let has_no_useful_approxes =
lazy
(List.for_all2
@ -344,10 +316,13 @@ let specialise env r ~lhs_of_application
| Always_specialise -> true, false
| Never_specialise -> false, true
| Default_specialise -> begin
match (function_decl.specialise : Lambda.specialise_attribute) with
| Always_specialise -> true, false
| Never_specialise -> false, true
| Default_specialise -> false, false
match function_decl.function_body with
| None -> false, true
| Some { specialise } ->
match (specialise : Lambda.specialise_attribute) with
| Always_specialise -> true, false
| Never_specialise -> false, true
| Default_specialise -> false, false
end
in
let remaining_inlining_threshold : Inlining_cost.Threshold.t =
@ -360,7 +335,7 @@ let specialise env r ~lhs_of_application
- is closed (it and all other members of the set of closures on which
it depends); and
- has useful approximations for some invariant parameters. *)
if !Clflags.classic_inlining then
if function_decls.is_classic_mode then
Don't_try_it S.Not_specialised.Classic_mode
else if self_call then
Don't_try_it S.Not_specialised.Self_call
@ -375,7 +350,7 @@ let specialise env r ~lhs_of_application
| T.Can_inline_if_no_larger_than threshold -> threshold
in
Don't_try_it (S.Not_specialised.Above_threshold threshold)
else if not (Var_within_closure.Map.is_empty (Lazy.force bound_vars)) then
else if not (Variable.Map.is_empty free_vars) then
Don't_try_it S.Not_specialised.Not_closed
else if not (Lazy.force recursive) then
Don't_try_it S.Not_specialised.Not_recursive
@ -396,7 +371,7 @@ let specialise env r ~lhs_of_application
~r:(R.reset_benefit r) ~lhs_of_application
~function_decls ~closure_id_being_applied ~function_decl
~args ~args_approxs
~invariant_params:value_set_of_closures.invariant_params
~invariant_params:invariant_params
~specialised_args:value_set_of_closures.specialised_args
~free_vars:value_set_of_closures.free_vars
~direct_call_surrogates:value_set_of_closures.direct_call_surrogates
@ -490,10 +465,10 @@ let specialise env r ~lhs_of_application
Original decision
end
let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
let for_call_site ~env ~r ~(function_decls : A.function_declarations)
~lhs_of_application ~closure_id_being_applied
~(function_decl : Flambda.function_declaration)
~(value_set_of_closures : Simple_value_approx.value_set_of_closures)
~(function_decl : A.function_declaration)
~(value_set_of_closures : A.value_set_of_closures)
~args ~args_approxs ~dbg ~simplify ~inline_requested
~specialise_requested =
if List.length args <> List.length args_approxs then begin
@ -527,20 +502,107 @@ 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
if function_decl.stub then
match function_decl.function_body with
| None ->
assert (function_decls.is_classic_mode);
(* Only in classic mode can the function code be absent *)
let decision =
S.Decision.Unchanged
(S.Not_specialised.Classic_mode, S.Not_inlined.Classic_mode)
in
E.record_decision env decision;
original, original_r
| Some function_body ->
if function_body.stub then begin
let fun_vars = Variable.Map.keys function_decls.funs in
let body, r =
Inlining_transforms.inline_by_copying_function_body ~env
~r ~function_decls ~lhs_of_application
~r ~fun_vars ~lhs_of_application
~closure_id_being_applied ~specialise_requested ~inline_requested
~function_decl ~args ~dbg ~simplify
~function_decl ~function_body ~args ~dbg ~simplify
in
simplify env r body
end
else 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
else if function_decls.is_classic_mode then begin
let env =
E.note_entering_call env
~closure_id:closure_id_being_applied ~dbg:dbg
in
let simpl =
let self_call =
E.inside_set_of_closures_declaration
function_decls.set_of_closures_origin env
in
let try_inlining =
if self_call then
Don't_try_it S.Not_inlined.Self_call
else if not (E.inlining_allowed env closure_id_being_applied) then
Don't_try_it S.Not_inlined.Unrolling_depth_exceeded
else begin
Try_it
end
in
match try_inlining with
| Don't_try_it decision -> Original decision
| Try_it ->
let fun_vars = Variable.Map.keys function_decls.funs in
let body, r =
Inlining_transforms.inline_by_copying_function_body ~env
~r ~function_body ~lhs_of_application
~closure_id_being_applied ~specialise_requested ~inline_requested
~function_decl ~fun_vars ~args ~dbg ~simplify
in
let env = E.note_entering_inlined env in
let env =
(* We decrement the unrolling count even if the function is not
recursive to avoid having to check whether or not it is recursive *)
E.inside_unrolled_function env function_decls.set_of_closures_origin
in
let env = E.inside_inlined_function env closure_id_being_applied in
Changed ((simplify env r body), S.Inlined.Classic_mode)
in
let res, decision =
match simpl with
| Original decision ->
let decision =
S.Decision.Unchanged (S.Not_specialised.Classic_mode, decision)
in
(original, original_r), decision
| Changed ((expr, r), decision) ->
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 raw_inlining_threshold = R.inlining_threshold r 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 res =
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
in
res, S.Decision.Inlined (S.Not_specialised.Classic_mode, decision)
in
E.record_decision env decision;
res
end else begin
let env = E.unset_never_inline_inside_closures env in
let env =
E.note_entering_call env
@ -585,7 +647,7 @@ let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
in
let fun_cost =
lazy
(Inlining_cost.can_try_inlining function_decl.body
(Inlining_cost.can_try_inlining function_body.body
inlining_threshold
~number_of_arguments:(List.length function_decl.params)
(* CR-someday mshinwell: for the moment, this is None, since
@ -593,52 +655,56 @@ let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
inlining threshold---this seems to take too long. *)
~size_from_approximation:None)
in
let fun_var =
U.find_declaration_variable closure_id_being_applied function_decls
in
let recursive =
lazy
(Variable.Set.mem fun_var
((Find_recursive_functions.in_function_declarations
function_decls
~backend:(E.backend env))))
(let fun_var = Closure_id.unwrap closure_id_being_applied in
Variable.Set.mem fun_var
(Lazy.force value_set_of_closures.recursive))
in
let specialise_result =
specialise env r ~lhs_of_application ~function_decls ~recursive
~closure_id_being_applied ~function_decl ~value_set_of_closures
~args ~args_approxs ~dbg ~simplify ~original ~inline_requested
~specialise_requested ~fun_cost ~self_call ~inlining_threshold
specialise env r
~function_decls ~function_decl
~lhs_of_application ~recursive ~closure_id_being_applied
~value_set_of_closures ~args ~args_approxs ~dbg ~simplify
~original ~inline_requested ~specialise_requested ~fun_cost
~self_call ~inlining_threshold
in
match specialise_result with
| Changed (res, spec_reason) ->
Changed (res, D.Specialised spec_reason)
| Original spec_reason ->
let only_use_of_function = false in
(* If we didn't specialise then try inlining *)
let size_from_approximation =
match
Variable.Map.find fun_var (Lazy.force value_set_of_closures.size)
with
| size -> size
| exception Not_found ->
let only_use_of_function = false in
(* If we didn't specialise then try inlining *)
let size_from_approximation =
let fun_var = Closure_id.unwrap closure_id_being_applied in
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
let inline_result =
inline env r ~function_decls ~lhs_of_application
~closure_id_being_applied ~function_decl ~value_set_of_closures
~only_use_of_function ~original ~recursive
~inline_requested ~specialise_requested ~args
~size_from_approximation ~dbg ~simplify ~fun_cost ~self_call
~inlining_threshold
in
match inline_result with
| Changed (res, inl_reason) ->
Changed (res, D.Inlined (spec_reason, inl_reason))
| Original inl_reason ->
Original (D.Unchanged (spec_reason, inl_reason))
in
let fun_vars = Variable.Map.keys function_decls.funs in
let set_of_closures_origin =
function_decls.set_of_closures_origin
in
let inline_result =
inline env r ~lhs_of_application
~closure_id_being_applied ~function_decl ~value_set_of_closures
~only_use_of_function ~original ~recursive
~inline_requested ~specialise_requested
~fun_vars ~set_of_closures_origin ~args
~size_from_approximation ~dbg ~simplify ~fun_cost ~self_call
~inlining_threshold ~function_body
in
match inline_result with
| Changed (res, inl_reason) ->
Changed (res, D.Inlined (spec_reason, inl_reason))
| Original inl_reason ->
Original (D.Unchanged (spec_reason, inl_reason))
end
in
let res, decision =

4
middle_end/inlining_decision.mli
View File

@ -24,10 +24,10 @@
val for_call_site
: env:Inline_and_simplify_aux.Env.t
-> r:Inline_and_simplify_aux.Result.t
-> function_decls:Flambda.function_declarations
-> function_decls:Simple_value_approx.function_declarations
-> lhs_of_application:Variable.t
-> closure_id_being_applied:Closure_id.t
-> function_decl:Flambda.function_declaration
-> function_decl:Simple_value_approx.function_declaration
-> value_set_of_closures:Simple_value_approx.value_set_of_closures
-> args:Variable.t list
-> args_approxs:Simple_value_approx.t list

13
middle_end/inlining_stats_types.ml
View File

@ -35,12 +35,17 @@ let print_calculation ~depth ~title ~subfunctions ppf wsb =
module Inlined = struct
type t =
| Classic_mode
| Annotation
| Decl_local_to_application
| Without_subfunctions of Wsb.t
| With_subfunctions of Wsb.t * Wsb.t
let summary ppf = function
| Classic_mode ->
Format.pp_print_text ppf
"This function was inlined because it was small enough \
to be inlined in `-Oclassic'"
| Annotation ->
Format.pp_print_text ppf
"This function was inlined because of an annotation."
@ -57,6 +62,7 @@ module Inlined = struct
the expected benefit outweighed the change in code size."
let calculation ~depth ppf = function
| Classic_mode -> ()
| Annotation -> ()
| Decl_local_to_application -> ()
| Without_subfunctions wsb ->
@ -85,7 +91,8 @@ module Not_inlined = struct
let summary ppf = function
| Classic_mode ->
Format.pp_print_text ppf
"This function was prevented from inlining by `-Oclassic'."
"This function was not inlined because it was too \
large to be inlined in `-Oclassic'."
| Above_threshold size ->
Format.pp_print_text ppf
"This function was not inlined because \
@ -182,8 +189,8 @@ module Not_specialised = struct
let summary ppf = function
| Classic_mode ->
Format.pp_print_text ppf
"This function was prevented from specialising by \
`-Oclassic'."
"This function was not specialised because it was \
compiled with `-Oclassic'."
| Above_threshold size ->
Format.pp_print_text ppf
"This function was not specialised because \

1
middle_end/inlining_stats_types.mli
View File

@ -20,6 +20,7 @@
module Inlined : sig
type t =
| Classic_mode
| Annotation
| Decl_local_to_application
| Without_subfunctions of

133
middle_end/inlining_transforms.ml
View File

@ -19,6 +19,7 @@
module B = Inlining_cost.Benefit
module E = Inline_and_simplify_aux.Env
module R = Inline_and_simplify_aux.Result
module A = Simple_value_approx
let new_var name =
Variable.create name
@ -30,7 +31,7 @@ let new_var name =
user-specified function as an [Flambda.named] value that projects the
variable from its closure. *)
let fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied
~lhs_of_application ~function_decls ~init ~f =
~lhs_of_application ~bound_variables ~init ~f =
Variable.Set.fold (fun var acc ->
let expr : Flambda.named =
Project_var {
@ -40,8 +41,7 @@ let fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied
}
in
f ~acc ~var ~expr)
(Flambda_utils.variables_bound_by_the_closure closure_id_being_applied
function_decls)
bound_variables
init
let set_inline_attribute_on_all_apply body inline specialise =
@ -53,7 +53,8 @@ let set_inline_attribute_on_all_apply body inline specialise =
(** Assign fresh names for a function's parameters and rewrite the body to
use these new names. *)
let copy_of_function's_body_with_freshened_params env
~(function_decl : Flambda.function_declaration) =
~(function_decl : A.function_declaration)
~(function_body : A.function_body) =
let params = function_decl.params in
let param_vars = Parameter.List.vars params in
(* We cannot avoid the substitution in the case where we are inlining
@ -67,14 +68,14 @@ let copy_of_function's_body_with_freshened_params env
if E.does_not_bind env param_vars
&& E.does_not_freshen env param_vars
then
params, function_decl.body
params, function_body.body
else
let freshened_params = List.map (fun p -> Parameter.rename p) params in
let subst =
Variable.Map.of_list
(List.combine param_vars (Parameter.List.vars freshened_params))
in
let body = Flambda_utils.toplevel_substitution subst function_decl.body in
let body = Flambda_utils.toplevel_substitution subst function_body.body in
freshened_params, body
(* CR-soon mshinwell: Add a note somewhere to explain why "bound by the closure"
@ -87,23 +88,26 @@ let copy_of_function's_body_with_freshened_params env
(= "variables bound by the closure"), and any function identifiers
introduced by the corresponding set of closures. *)
let inline_by_copying_function_body ~env ~r
~(function_decls : Flambda.function_declarations)
~lhs_of_application
~(inline_requested : Lambda.inline_attribute)
~(specialise_requested : Lambda.specialise_attribute)
~closure_id_being_applied
~(function_decl : Flambda.function_declaration) ~args ~dbg ~simplify =
~(function_decl : A.function_declaration)
~(function_body : A.function_body)
~fun_vars
~args ~dbg ~simplify =
assert (E.mem env lhs_of_application);
assert (List.for_all (E.mem env) args);
let r =
if function_decl.stub then r
if function_body.stub then r
else R.map_benefit r B.remove_call
in
let freshened_params, body =
copy_of_function's_body_with_freshened_params env ~function_decl
copy_of_function's_body_with_freshened_params env
~function_decl ~function_body
in
let body =
if function_decl.stub &&
if function_body.stub &&
((inline_requested <> Lambda.Default_inline)
|| (specialise_requested <> Lambda.Default_specialise)) then
(* When the function inlined function is a stub, the annotation
@ -124,8 +128,14 @@ let inline_by_copying_function_body ~env ~r
in
(* Add bindings for the variables bound by the closure. *)
let bindings_for_vars_bound_by_closure_and_params_to_args =
let bound_variables =
let params = Parameter.Set.vars function_decl.params in
Variable.Set.diff
(Variable.Set.diff function_body.free_variables params)
fun_vars
in
fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied
~lhs_of_application ~function_decls ~init:bindings_for_params_to_args
~lhs_of_application ~bound_variables ~init:bindings_for_params_to_args
~f:(fun ~acc:body ~var ~expr -> Flambda.create_let var expr body)
in
(* Add bindings for variables corresponding to the functions introduced by
@ -134,10 +144,10 @@ let inline_by_copying_function_body ~env ~r
applied to another closure in the same set.
*)
let expr =
Variable.Map.fold (fun another_closure_in_the_same_set _ expr ->
Variable.Set.fold (fun another_closure_in_the_same_set expr ->
let used =
Variable.Set.mem another_closure_in_the_same_set
function_decl.free_variables
function_body.free_variables
in
if used then
Flambda.create_let another_closure_in_the_same_set
@ -148,10 +158,11 @@ let inline_by_copying_function_body ~env ~r
})
expr
else expr)
function_decls.funs
fun_vars
bindings_for_vars_bound_by_closure_and_params_to_args
in
let env = E.activate_freshening (E.set_never_inline env) in
let env = E.set_never_inline env in
let env = E.activate_freshening env in
let env = E.set_inline_debuginfo ~dbg env in
simplify env r expr
@ -237,7 +248,7 @@ let register_arguments ~specialised_args ~invariant_params
true, old_outside_to_new_outside
| None ->
let worth_specialising =
Simple_value_approx.useful arg_approx
A.useful arg_approx
&& Variable.Map.mem param (Lazy.force invariant_params)
in
worth_specialising, state.old_outside_to_new_outside
@ -356,36 +367,40 @@ let add_free_var ~free_vars ~state ~free_var =
end
(* Add a function to the new set of closures iff:
1) All it's specialised parameters are available in
1) All it's specialised parameters are available in
[old_outside_to_new_outside]
2) At least one more parameter will become specialised *)
let add_function ~specialised_args ~state ~fun_var ~function_decl =
let rec loop worth_specialising = function
| [] -> worth_specialising
| param :: params -> begin
let param = Parameter.var param in
match Variable.Map.find_opt param specialised_args with
| Some (spec : Flambda.specialised_to) ->
Variable.Map.mem spec.var state.old_outside_to_new_outside
&& loop worth_specialising params
| None ->
let worth_specialising =
worth_specialising
|| Variable.Map.mem param state.old_params_to_new_outside
in
loop worth_specialising params
end
in
let worth_specialising = loop false function_decl.Flambda.params in
if not worth_specialising then None
else begin
let new_fun_var = Variable.rename ~append:"_copied" fun_var in
let old_fun_var_to_new_fun_var =
Variable.Map.add fun_var new_fun_var state.old_fun_var_to_new_fun_var
match function_decl.A.function_body with
| None -> None
| Some _ -> begin
let rec loop worth_specialising = function
| [] -> worth_specialising
| param :: params -> begin
let param = Parameter.var param in
match Variable.Map.find_opt param specialised_args with
| Some (spec : Flambda.specialised_to) ->
Variable.Map.mem spec.var state.old_outside_to_new_outside
&& loop worth_specialising params
| None ->
let worth_specialising =
worth_specialising
|| Variable.Map.mem param state.old_params_to_new_outside
in
loop worth_specialising params
end
in
let to_copy = fun_var :: state.to_copy in
let state = { state with old_fun_var_to_new_fun_var; to_copy } in
Some (state, new_fun_var)
let worth_specialising = loop false function_decl.A.params in
if not worth_specialising then None
else begin
let new_fun_var = Variable.rename ~append:"_copied" fun_var in
let old_fun_var_to_new_fun_var =
Variable.Map.add fun_var new_fun_var state.old_fun_var_to_new_fun_var
in
let to_copy = fun_var :: state.to_copy in
let state = { state with old_fun_var_to_new_fun_var; to_copy } in
Some (state, new_fun_var)
end
end
(* Lookup a function in the new set of closures, trying to add it if
@ -437,7 +452,7 @@ let rec rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates
| None -> None
| Some (state, new_fun_var) -> begin
let args = apply.args in
let params = function_decl.Flambda.params in
let params = function_decl.A.params in
let specialisable =
specialisable_call ~specialised_args ~state ~args ~params
in
@ -456,9 +471,14 @@ let rec rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates
let rewrite_function ~lhs_of_application ~closure_id_being_applied
~direct_call_surrogates ~specialised_args ~free_vars ~funs
~state fun_var =
let function_decl : Flambda.function_declaration =
let function_decl : A.function_declaration =
Variable.Map.find fun_var funs
in
let function_body =
match function_decl.function_body with
| None -> assert false
| Some function_body -> function_body
in
let new_fun_var =
Variable.Map.find fun_var state.old_fun_var_to_new_fun_var
in
@ -479,7 +499,7 @@ let rewrite_function ~lhs_of_application ~closure_id_being_applied
add_free_var ~free_vars ~state ~free_var:var
else
state)
function_decl.free_variables state
function_body.free_variables state
in
let state_ref = ref state in
let body =
@ -497,13 +517,19 @@ let rewrite_function ~lhs_of_application ~closure_id_being_applied
expr
end
| _ -> expr)
function_decl.body
function_body.body
in
let body =
Flambda_utils.toplevel_substitution state.old_inside_to_new_inside body
in
let new_function_decl =
Flambda.update_function_declaration function_decl ~params ~body
Flambda.create_function_declaration
~params ~body
~stub:function_body.stub
~dbg:function_body.dbg
~inline:function_body.inline
~specialise:function_body.specialise
~is_a_functor:function_body.is_a_functor
in
let new_funs =
Variable.Map.add new_fun_var new_function_decl state.new_funs
@ -551,13 +577,13 @@ let update_projections ~state projections =
let inline_by_copying_function_declaration
~(env : Inline_and_simplify_aux.Env.t)
~(r : Inline_and_simplify_aux.Result.t)
~(function_decls : Flambda.function_declarations)
~(function_decls : A.function_declarations)
~(lhs_of_application : Variable.t)
~(inline_requested : Lambda.inline_attribute)
~(closure_id_being_applied : Closure_id.t)
~(function_decl : Flambda.function_declaration)
~(function_decl : A.function_declaration)
~(args : Variable.t list)
~(args_approxs : Simple_value_approx.t list)
~(args_approxs : A.t list)
~(invariant_params : Variable.Set.t Variable.Map.t lazy_t)
~(specialised_args : Flambda.specialised_to Variable.Map.t)
~(free_vars : Flambda.specialised_to Variable.Map.t)
@ -594,9 +620,10 @@ let inline_by_copying_function_declaration
let state = loop state in
let closure_id = Closure_id.wrap new_fun_var in
let function_decls =
Flambda.update_function_declarations
Flambda.create_function_declarations_with_origin
~funs:state.new_funs
function_decls
~set_of_closures_origin:function_decls.set_of_closures_origin
~is_classic_mode:function_decls.is_classic_mode
in
let free_vars =
update_projections ~state

9
middle_end/inlining_transforms.mli
View File

@ -67,12 +67,13 @@
val inline_by_copying_function_body
: env:Inline_and_simplify_aux.Env.t
-> r:Inline_and_simplify_aux.Result.t
-> function_decls:Flambda.function_declarations
-> lhs_of_application:Variable.t
-> inline_requested:Lambda.inline_attribute
-> specialise_requested:Lambda.specialise_attribute
-> closure_id_being_applied:Closure_id.t
-> function_decl:Flambda.function_declaration
-> function_decl:Simple_value_approx.function_declaration
-> function_body:Simple_value_approx.function_body
-> fun_vars:Variable.Set.t
-> args:Variable.t list
-> dbg:Debuginfo.t
-> simplify:Inlining_decision_intf.simplify
@ -88,11 +89,11 @@ val inline_by_copying_function_body
val inline_by_copying_function_declaration
: env:Inline_and_simplify_aux.Env.t
-> r:Inline_and_simplify_aux.Result.t
-> function_decls:Flambda.function_declarations
-> function_decls:Simple_value_approx.function_declarations
-> lhs_of_application:Variable.t
-> inline_requested:Lambda.inline_attribute
-> closure_id_being_applied:Closure_id.t
-> function_decl:Flambda.function_declaration
-> function_decl:Simple_value_approx.function_declaration
-> args:Variable.t list
-> args_approxs:Simple_value_approx.t list
-> invariant_params:Variable.Set.t Variable.Map.t lazy_t

201
middle_end/simple_value_approx.ml
View File

@ -66,12 +66,36 @@ and value_closure = {
closure_id : Closure_id.t;
}
and function_declarations = {
is_classic_mode : bool;
set_of_closures_id : Set_of_closures_id.t;
set_of_closures_origin : Set_of_closures_origin.t;
funs : function_declaration Variable.Map.t;
}
and function_body = {
free_variables : Variable.Set.t;
free_symbols : Symbol.Set.t;
stub : bool;
dbg : Debuginfo.t;
inline : Lambda.inline_attribute;
specialise : Lambda.specialise_attribute;
is_a_functor : bool;
body : Flambda.t;
}
and function_declaration = {
params : Parameter.t list;
function_body : function_body option;
}
and value_set_of_closures = {
function_decls : Flambda.function_declarations;
function_decls : function_declarations;
bound_vars : t Var_within_closure.Map.t;
free_vars : Flambda.specialised_to Variable.Map.t;
invariant_params : Variable.Set.t Variable.Map.t lazy_t;
size : int option Variable.Map.t lazy_t;
free_vars : Flambda.specialised_to Variable.Map.t;
invariant_params : Variable.Set.t Variable.Map.t Lazy.t;
recursive : Variable.Set.t Lazy.t;
size : int option Variable.Map.t Lazy.t;
specialised_args : Flambda.specialised_to Variable.Map.t;
freshening : Freshening.Project_var.t;
direct_call_surrogates : Closure_id.t Closure_id.Map.t;
@ -89,11 +113,16 @@ and value_float_array = {
let descr t = t.descr
let print_value_set_of_closures ppf
{ function_decls = { funs }; invariant_params; freshening; _ } =
Format.fprintf ppf "(set_of_closures:@ %a invariant_params=%a freshening=%a)"
{ function_decls = { funs }; invariant_params; freshening; size; _ } =
Format.fprintf ppf "(set_of_closures:@ %a invariant_params=%a freshening=%a size=%a)"
(fun ppf -> Variable.Map.iter (fun id _ -> Variable.print ppf id)) funs
(Variable.Map.print Variable.Set.print) (Lazy.force invariant_params)
Freshening.Project_var.print freshening
(Variable.Map.print (fun ppf some_size ->
match some_size with
| None -> Format.fprintf ppf "None"
| Some size -> Format.fprintf ppf "Some %d" size))
(Lazy.force size)
let print_unresolved_value ppf = function
| Set_of_closures_id set ->
@ -101,6 +130,41 @@ let print_unresolved_value ppf = function
| Symbol symbol ->
Format.fprintf ppf "Symbol %a" Symbol.print symbol
let print_function_declaration ppf var (f : function_declaration) =
let param ppf p = Variable.print ppf (Parameter.var p) in
let params ppf = List.iter (Format.fprintf ppf "@ %a" param) in
match f.function_body with
| None ->
Format.fprintf ppf "@[<2>(%a@ =@ fun@[<2>%a@])@]@ "
Variable.print var params f.params
| Some (b : function_body) ->
let stub = if b.stub then " *stub*" else "" in
let is_a_functor = if b.is_a_functor then " *functor*" else "" in
let inline =
match b.inline with
| Always_inline -> " *inline*"
| Never_inline -> " *never_inline*"
| Unroll _ -> " *unroll*"
| Default_inline -> ""
in
let specialise =
match b.specialise with
| Always_specialise -> " *specialise*"
| Never_specialise -> " *never_specialise*"
| Default_specialise -> ""
in
let print_body ppf _ =
Format.fprintf ppf "<Function Body>"
in
Format.fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2><%a>@])@]@ "
Variable.print var stub is_a_functor inline specialise
params f.params
print_body b
let print_function_declarations ppf (fd : function_declarations) =
let funs ppf = Variable.Map.iter (print_function_declaration ppf) in
Format.fprintf ppf "@[<2>(%a)@]" funs fd.funs
let rec print_descr ppf = function
| Value_int i -> Format.pp_print_int ppf i
| Value_char c -> Format.fprintf ppf "%c" c
@ -237,31 +301,39 @@ let value_closure ?closure_var ?set_of_closures_var ?set_of_closures_symbol
}
let create_value_set_of_closures
~(function_decls : Flambda.function_declarations) ~bound_vars
~free_vars ~invariant_params ~specialised_args ~freshening
~(function_decls : function_declarations) ~bound_vars ~free_vars
~invariant_params ~recursive ~specialised_args ~freshening
~direct_call_surrogates =
let size =
lazy (
let functions = Variable.Map.keys function_decls.funs in
Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
let params = Parameter.Set.vars function_decl.params in
let free_vars =
Variable.Set.diff
(Variable.Set.diff function_decl.free_variables params)
functions
in
let num_free_vars = Variable.Set.cardinal free_vars in
let max_size =
Inlining_cost.maximum_interesting_size_of_function_body
num_free_vars
in
Inlining_cost.lambda_smaller' function_decl.body ~than:max_size)
function_decls.funs)
Variable.Map.fold
(fun fun_var function_decl sizes ->
match function_decl.function_body with
| None -> sizes
| Some function_body ->
let params = Parameter.Set.vars function_decl.params in
let free_vars =
Variable.Set.diff
(Variable.Set.diff function_body.free_variables params)
functions
in
let num_free_vars = Variable.Set.cardinal free_vars in
let max_size =
Inlining_cost.maximum_interesting_size_of_function_body
num_free_vars
in
let size =
Inlining_cost.lambda_smaller' function_body.body ~than:max_size
in
Variable.Map.add fun_var size sizes)
function_decls.funs Variable.Map.empty)
in
{ function_decls;
bound_vars;
free_vars;
invariant_params;
recursive;
size;
specialised_args;
freshening;
@ -662,15 +734,17 @@ let freshen_and_check_closure_id
value_set_of_closures.freshening closure_id
in
try
ignore (Flambda_utils.find_declaration closure_id
value_set_of_closures.function_decls);
ignore (
Variable.Map.find (Closure_id.unwrap closure_id)
value_set_of_closures.function_decls.funs
);
closure_id
with Not_found ->
Misc.fatal_error (Format.asprintf
"Function %a not found in the set of closures@ %a@.%a@."
Closure_id.print closure_id
print_value_set_of_closures value_set_of_closures
Flambda.print_function_declarations value_set_of_closures.function_decls)
print_function_declarations value_set_of_closures.function_decls)
type checked_approx_for_set_of_closures =
| Wrong
@ -861,3 +935,80 @@ let potentially_taken_block_switch_branch t tag =
Cannot_be_taken
| Value_bottom ->
Cannot_be_taken
let function_arity (fun_decl : function_declaration) =
List.length fun_decl.params
let function_declaration_approx ~keep_body fun_var
(fun_decl : Flambda.function_declaration) =
let function_body =
if not (keep_body fun_var fun_decl) then None
else begin
Some { body = fun_decl.body;
stub = fun_decl.stub;
inline = fun_decl.inline;
dbg = fun_decl.dbg;
specialise = fun_decl.specialise;
is_a_functor = fun_decl.is_a_functor;
free_variables = fun_decl.free_variables;
free_symbols = fun_decl.free_symbols; }
end
in
{ function_body;
params = fun_decl.params; }
let function_declarations_approx ~keep_body
(fun_decls : Flambda.function_declarations) =
let funs =
Variable.Map.mapi (function_declaration_approx ~keep_body) fun_decls.funs
in
{ funs;
is_classic_mode = fun_decls.is_classic_mode;
set_of_closures_id = fun_decls.set_of_closures_id;
set_of_closures_origin = fun_decls.set_of_closures_origin; }
let import_function_declarations_for_pack function_decls
import_set_of_closures_id import_set_of_closures_origin =
{ set_of_closures_id =
import_set_of_closures_id function_decls.set_of_closures_id;
set_of_closures_origin =
import_set_of_closures_origin function_decls.set_of_closures_origin;
funs = function_decls.funs;
is_classic_mode = function_decls.is_classic_mode;
}
let update_function_declarations function_decls ~funs =
let compilation_unit = Compilation_unit.get_current_exn () in
let is_classic_mode = function_decls.is_classic_mode in
let set_of_closures_id = Set_of_closures_id.create compilation_unit in
let set_of_closures_origin = function_decls.set_of_closures_origin in
{ is_classic_mode;
set_of_closures_id;
set_of_closures_origin;
funs;
}
let update_function_declaration_body
(function_decl : function_declaration)
(f : Flambda.t -> Flambda.t) =
match function_decl.function_body with
| None -> function_decl
| Some function_body ->
let new_function_body =
let body = f function_body.body in
let free_variables = Flambda.free_variables body in
let free_symbols = Flambda.free_symbols body in
{ function_body with free_variables; free_symbols; body; }
in
{ function_decl with function_body = Some new_function_body }
let make_closure_map input =
let map = ref Closure_id.Map.empty in
let add_set_of_closures _ (function_decls : function_declarations) =
Variable.Map.iter (fun var _ ->
let closure_id = Closure_id.wrap var in
map := Closure_id.Map.add closure_id function_decls !map)
function_decls.funs
in
Set_of_closures_id.Map.iter add_set_of_closures input;
!map

76
middle_end/simple_value_approx.mli
View File

@ -143,14 +143,46 @@ and value_closure = {
closure_id : Closure_id.t;
}
and function_declarations = private {
is_classic_mode: bool;
set_of_closures_id : Set_of_closures_id.t;
set_of_closures_origin : Set_of_closures_origin.t;
funs : function_declaration Variable.Map.t;
}
and function_body = private {
free_variables : Variable.Set.t;
free_symbols : Symbol.Set.t;
stub : bool;
dbg : Debuginfo.t;
inline : Lambda.inline_attribute;
specialise : Lambda.specialise_attribute;
is_a_functor : bool;
body : Flambda.t;
}
and function_declaration = private {
params : Parameter.t list;
function_body : function_body option;
}
(* CR-soon mshinwell: add support for the approximations of the results, so we
can do all of the tricky higher-order cases. *)
(* when [is_classic_mode] is [false], functions in [function_declarations]
are guranteed to have function bodies (ie:
[function_declaration.function_body] will be of the [Some] variant).
When it [is_classic_mode] is [true], however, no gurantees about the
function_bodies are given.
*)
and value_set_of_closures = private {
function_decls : Flambda.function_declarations;
function_decls : function_declarations;
bound_vars : t Var_within_closure.Map.t;
free_vars : Flambda.specialised_to Variable.Map.t;
invariant_params : Variable.Set.t Variable.Map.t lazy_t;
size : int option Variable.Map.t lazy_t;
invariant_params : Variable.Set.t Variable.Map.t Lazy.t;
recursive : Variable.Set.t Lazy.t;
size : int option Variable.Map.t Lazy.t;
(** For functions that are very likely to be inlined, the size of the
function's body. *)
specialised_args : Flambda.specialised_to Variable.Map.t;
@ -179,12 +211,22 @@ val print_value_set_of_closures
: Format.formatter
-> value_set_of_closures
-> unit
val print_function_declarations
: Format.formatter
-> function_declarations
-> unit
val function_declarations_approx
: keep_body:(Variable.t -> Flambda.function_declaration -> bool)
-> Flambda.function_declarations
-> function_declarations
val create_value_set_of_closures
: function_decls:Flambda.function_declarations
: function_decls:function_declarations
-> bound_vars:t Var_within_closure.Map.t
-> free_vars:Flambda.specialised_to Variable.Map.t
-> invariant_params:Variable.Set.t Variable.Map.t lazy_t
-> recursive:Variable.Set.t Lazy.t
-> specialised_args:Flambda.specialised_to Variable.Map.t
-> freshening:Freshening.Project_var.t
-> direct_call_surrogates:Closure_id.t Closure_id.Map.t
@ -428,3 +470,29 @@ type switch_branch_selection =
(** Check that the branch is compatible with the approximation *)
val potentially_taken_const_switch_branch : t -> int -> switch_branch_selection
val potentially_taken_block_switch_branch : t -> int -> switch_branch_selection
val function_arity : function_declaration -> int
(** Create a set of function declarations based on another set of function
declarations. *)
val update_function_declarations
: function_declarations
-> funs:function_declaration Variable.Map.t
-> function_declarations
val import_function_declarations_for_pack
: function_declarations
-> (Set_of_closures_id.t -> Set_of_closures_id.t)
-> (Set_of_closures_origin.t -> Set_of_closures_origin.t)
-> function_declarations
val update_function_declaration_body
: function_declaration
-> (Flambda.t -> Flambda.t)
-> function_declaration
(** Creates a map from closure IDs to function declarations by iterating over
all sets of closures in the given map. *)
val make_closure_map
: function_declarations Set_of_closures_id.Map.t
-> function_declarations Closure_id.Map.t