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

Tidy up new command-line parameters

master
Leo White 2016-02-10 16:52:07 +00:00
parent 04445cb4ad
commit 4253ed1530
17 changed files with 304 additions and 232 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
driver/compenv.ml
View File

@ -147,6 +147,14 @@ let int_setter ppf name option s =
(Warnings.Bad_env_variable
("OCAMLPARAM", Printf.sprintf "non-integer parameter for \"%s\"" name))
let int_option_setter ppf name option s =
try
option := Some (int_of_string s)
with _ ->
Location.print_warning Location.none ppf
(Warnings.Bad_env_variable
("OCAMLPARAM", Printf.sprintf "non-integer parameter for \"%s\"" name))
let float_setter ppf name option s =
try
option := float_of_string s
@ -155,6 +163,16 @@ let float_setter ppf name option s =
(Warnings.Bad_env_variable
("OCAMLPARAM", Printf.sprintf "non-float parameter for \"%s\"" name))
let check_bool ppf name s =
match s with
| "0" -> false
| "1" -> true
| _ ->
Location.print_warning Location.none ppf
(Warnings.Bad_env_variable ("OCAMLPARAM",
Printf.sprintf "bad value for %s" name));
false
(* 'can-discard=' specifies which arguments can be discarded without warning
because they are not understood by some versions of OCaml. *)
let can_discard = ref []
@ -232,10 +250,10 @@ let read_one_param ppf position name v =
"Bad syntax in OCAMLPARAM for 'inline-toplevel'"
inline_toplevel_threshold
| "rounds" -> int_setter ppf "rounds" simplify_rounds v
| "unroll" ->
Int_arg_helper.parse v "Bad syntax in OCAMLPARAM for 'unroll'"
unroll
| "rounds" -> int_option_setter ppf "rounds" simplify_rounds v
| "inline-max-unroll" ->
Int_arg_helper.parse v "Bad syntax in OCAMLPARAM for 'inline-max-unroll'"
inline_max_unroll
| "inline-call-cost" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-call-cost'"
@ -260,21 +278,31 @@ let read_one_param ppf position name v =
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-lifting-benefit'"
inline_lifting_benefit
| "branch-inline-factor" ->
| "inline-branch-factor" ->
Float_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'branch-inline-factor'"
branch_inline_factor
| "max-inlining-depth" ->
"Bad syntax in OCAMLPARAM for 'inline-branch-factor'"
inline_branch_factor
| "inline-max-depth" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'max-inlining-depth'"
max_inlining_depth
"Bad syntax in OCAMLPARAM for 'inline-max-depth'"
inline_max_depth
| "classic-inlining" ->
set "classic-inlining" [ classic_inlining ] v
| "Oclassic" ->
set "Oclassic" [ classic_inlining ] v
| "O2" ->
set "O2" [ o2 ] v
if check_bool ppf "O2" v then begin
default_simplify_rounds := 2;
use_inlining_arguments_set o2_arguments;
use_inlining_arguments_set ~round:0 o1_arguments
end
| "O3" ->
set "O3" [ o3 ] v
if check_bool ppf "O3" v then begin
default_simplify_rounds := 3;
use_inlining_arguments_set o3_arguments;
use_inlining_arguments_set ~round:1 o2_arguments;
use_inlining_arguments_set ~round:0 o1_arguments
end
| "unbox-closures" ->
set "unbox-closures" [ unbox_closures ] v
| "remove-unused-arguments" ->
@ -282,7 +310,7 @@ let read_one_param ppf position name v =
| "inlining-report" ->
if !native_code then
set "inlining-report" [ inlining_stats ] v
set "inlining-report" [ inlining_report ] v
| "flambda-verbose" ->
set "flambda-verbose" [ dump_flambda_verbose ] v

65
driver/main_args.ml
View File

@ -127,15 +127,18 @@ let mk_inline_toplevel f =
toplevel (higher numbers mean more aggressive)"
;;
let mk_inlining_stats f =
let mk_inlining_report f =
"-inlining-report", Arg.Unit f, " Emit `.<round>.inlining' file(s) (one per \
round) showing the inliner's decisions"
;;
let mk_dump_pass f =
"-dump-pass", Arg.String f,
Format.asprintf " Record transformations performed by these passes: %a"
(Format.pp_print_list Format.pp_print_string)
Format.asprintf
" @[<4>Record transformations performed by these passes:@ @[%a@]@]"
(Format.pp_print_list
~pp_sep:Format.pp_print_space
Format.pp_print_string)
!Clflags.all_passes
;;
@ -152,20 +155,20 @@ let mk_rounds f =
"-rounds", Arg.Int f,
Printf.sprintf "<n> Repeat tree optimization and inlining phases this \
many times (default %d). Rounds are numbered starting from zero."
!Clflags.simplify_rounds
!Clflags.default_simplify_rounds
;;
let mk_unroll f =
"-unroll", Arg.String f,
let mk_inline_max_unroll f =
"-inline-max-unroll", Arg.String f,
Printf.sprintf "<n>|<round>=<n>[,...] Unroll recursive functions at most \
this many times (default %d)"
Clflags.default_unroll
this many times (default %d)"
Clflags.default_inline_max_unroll
;;
let mk_classic_inlining f =
"-classic-inlining", Arg.Unit f, " Make inlining decisions at function \
definition time rather than at the call site (replicates previous \
behaviour of the compiler)"
"-Oclassic", Arg.Unit f, " Make inlining decisions at function definition \
time rather than at the call site (replicates previous behaviour of the \
compiler)"
;;
let mk_inline_cost arg descr default f =
@ -197,11 +200,11 @@ let mk_inline_lifting_benefit f =
Clflags.default_inline_lifting_benefit
;;
let mk_branch_inline_factor f =
"-branch-inline-factor", Arg.String f,
let mk_inline_branch_factor f =
"-inline-branch-factor", Arg.String f,
Printf.sprintf "<n>|<round>=<n>[,...] Estimate the probability of a \
branch being cold as 1/(1+n) (used for inlining) (default %.2f)"
Clflags.default_branch_inline_factor
Clflags.default_inline_branch_factor
;;
let mk_intf f =
@ -242,11 +245,11 @@ let mk_make_runtime_2 f =
"-make_runtime", Arg.Unit f, " (deprecated) same as -make-runtime"
;;
let mk_max_inlining_depth f =
"-max-inlining-depth", Arg.String f,
Printf.sprintf "<n>|<round>=<n>[,...] Maximum depth of search for
inlining opportunities inside inlined functions (default %d)"
Clflags.default_max_inlining_depth
let mk_inline_max_depth f =
"-inline-max-depth", Arg.String f,
Printf.sprintf "<n>|<round>=<n>[,...] Maximum depth of search for \
inlining opportunities inside inlined functions (default %d)"
Clflags.default_inline_max_depth
;;
let mk_modern f =
@ -548,7 +551,7 @@ let mk_dflambda f =
;;
let mk_drawflambda f =
"-dflambda", Arg.Unit f, " Print Flambda terms after closure conversion"
"-drawflambda", Arg.Unit f, " Print Flambda terms after closure conversion"
;;
let mk_dflambda_no_invariants f =
@ -753,11 +756,11 @@ module type Optcommon_options = sig
val _compact : unit -> unit
val _inline : string -> unit
val _inline_toplevel : string -> unit
val _inlining_stats : unit -> unit
val _inlining_report : unit -> unit
val _dump_pass : string -> unit
val _max_inlining_depth : string -> unit
val _inline_max_depth : string -> unit
val _rounds : int -> unit
val _unroll : string -> unit
val _inline_max_unroll : string -> unit
val _classic_inlining : unit -> unit
val _inline_call_cost : string -> unit
val _inline_alloc_cost : string -> unit
@ -766,7 +769,7 @@ module type Optcommon_options = sig
val _inline_indirect_cost : string -> unit
val _inline_lifting_benefit : string -> unit
val _unbox_closures : unit -> unit
val _branch_inline_factor : string -> unit
val _inline_branch_factor : string -> unit
val _remove_unused_arguments : unit -> unit
val _no_unbox_free_vars_of_closures : unit -> unit
val _no_unbox_specialised_args : unit -> unit
@ -974,7 +977,7 @@ struct
mk_absname F._absname;
mk_annot F._annot;
mk_binannot F._binannot;
mk_branch_inline_factor F._branch_inline_factor;
mk_inline_branch_factor F._inline_branch_factor;
mk_c F._c;
mk_cc F._cc;
mk_cclib F._cclib;
@ -998,14 +1001,14 @@ struct
mk_inline_prim_cost F._inline_prim_cost;
mk_inline_indirect_cost F._inline_indirect_cost;
mk_inline_lifting_benefit F._inline_lifting_benefit;
mk_inlining_stats F._inlining_stats;
mk_inlining_report F._inlining_report;
mk_intf F._intf;
mk_intf_suffix F._intf_suffix;
mk_keep_docs F._keep_docs;
mk_keep_locs F._keep_locs;
mk_labels F._labels;
mk_linkall F._linkall;
mk_max_inlining_depth F._max_inlining_depth;
mk_inline_max_depth F._inline_max_depth;
mk_no_alias_deps F._no_alias_deps;
mk_no_app_funct F._no_app_funct;
mk_no_float_const_prop F._no_float_const_prop;
@ -1040,7 +1043,7 @@ struct
mk_strict_formats F._strict_formats;
mk_thread F._thread;
mk_unbox_closures F._unbox_closures;
mk_unroll F._unroll;
mk_inline_max_unroll F._inline_max_unroll;
mk_unsafe F._unsafe;
mk_unsafe_string F._unsafe_string;
mk_v F._v;
@ -1094,9 +1097,9 @@ module Make_opttop_options (F : Opttop_options) = struct
mk_init F._init;
mk_inline F._inline;
mk_inline_toplevel F._inline_toplevel;
mk_inlining_stats F._inlining_stats;
mk_inlining_report F._inlining_report;
mk_rounds F._rounds;
mk_unroll F._unroll;
mk_inline_max_unroll F._inline_max_unroll;
mk_classic_inlining F._classic_inlining;
mk_inline_call_cost F._inline_call_cost;
mk_inline_alloc_cost F._inline_alloc_cost;
@ -1104,7 +1107,7 @@ module Make_opttop_options (F : Opttop_options) = struct
mk_inline_branch_cost F._inline_branch_cost;
mk_inline_indirect_cost F._inline_indirect_cost;
mk_inline_lifting_benefit F._inline_lifting_benefit;
mk_branch_inline_factor F._branch_inline_factor;
mk_inline_branch_factor F._inline_branch_factor;
mk_labels F._labels;
mk_no_alias_deps F._no_alias_deps;
mk_no_app_funct F._no_app_funct;

8
driver/main_args.mli
View File

@ -120,11 +120,11 @@ module type Optcommon_options = sig
val _compact : unit -> unit
val _inline : string -> unit
val _inline_toplevel : string -> unit
val _inlining_stats : unit -> unit
val _inlining_report : unit -> unit
val _dump_pass : string -> unit
val _max_inlining_depth : string -> unit
val _inline_max_depth : string -> unit
val _rounds : int -> unit
val _unroll : string -> unit
val _inline_max_unroll : string -> unit
val _classic_inlining : unit -> unit
val _inline_call_cost : string -> unit
val _inline_alloc_cost : string -> unit
@ -133,7 +133,7 @@ module type Optcommon_options = sig
val _inline_indirect_cost : string -> unit
val _inline_lifting_benefit : string -> unit
val _unbox_closures : unit -> unit
val _branch_inline_factor : string -> unit
val _inline_branch_factor : string -> unit
val _remove_unused_arguments : unit -> unit
val _no_unbox_free_vars_of_closures : unit -> unit
val _no_unbox_specialised_args : unit -> unit

14
driver/optcompile.ml
View File

@ -81,18 +81,8 @@ let implementation ppf sourcefile outputprefix ~backend =
in
if not !Clflags.print_types then begin
if Config.flambda then begin
if !Clflags.o3 then begin
Clflags.simplify_rounds := 3;
Clflags.use_inlining_arguments_set ~round:0 Clflags.o1_arguments;
Clflags.use_inlining_arguments_set ~round:1 Clflags.o2_arguments;
Clflags.use_inlining_arguments_set ~round:2 Clflags.o3_arguments
end
else if !Clflags.o2 then begin
Clflags.simplify_rounds := 2;
Clflags.use_inlining_arguments_set ~round:0 Clflags.o1_arguments;
Clflags.use_inlining_arguments_set ~round:1 Clflags.o2_arguments
end
else if !Clflags.classic_inlining then begin
if !Clflags.classic_inlining then begin
Clflags.default_simplify_rounds := 1;
Clflags.use_inlining_arguments_set Clflags.classic_arguments;
Clflags.unbox_free_vars_of_closures := false;
Clflags.unbox_specialised_args := false

33
driver/optmain.ml
View File

@ -116,12 +116,12 @@ module Options = Main_args.Make_optcomp_options (struct
let _inline_toplevel spec =
Int_arg_helper.parse spec ~update:inline_toplevel_threshold
~help_text:"Syntax: -inline-toplevel <n> | <round>=<n>[,...]"
let _inlining_stats () = inlining_stats := true
let _inlining_report () = inlining_report := true
let _dump_pass pass = set_dumped_pass pass true
let _rounds n = simplify_rounds := n
let _unroll spec =
Int_arg_helper.parse spec ~update:unroll
~help_text:"Syntax: -unroll <n> | <round>=<n>[,...]"
let _rounds n = simplify_rounds := Some n
let _inline_max_unroll spec =
Int_arg_helper.parse spec ~update:inline_max_unroll
~help_text:"Syntax: -inline-max-unroll <n> | <round>=<n>[,...]"
let _classic_inlining () = classic_inlining := true
let _inline_call_cost spec =
Int_arg_helper.parse spec ~update:inline_call_cost
@ -141,18 +141,18 @@ module Options = Main_args.Make_optcomp_options (struct
let _inline_lifting_benefit spec =
Int_arg_helper.parse spec ~update:inline_lifting_benefit
~help_text:"Syntax: -inline-lifting-benefit <n> | <round>=<n>[,...]"
let _branch_inline_factor spec =
Float_arg_helper.parse spec ~update:branch_inline_factor
~help_text:"Syntax: -branch-inline-factor <n> | <round>=<n>[,...]"
let _inline_branch_factor spec =
Float_arg_helper.parse spec ~update:inline_branch_factor
~help_text:"Syntax: -inline-branch-factor <n> | <round>=<n>[,...]"
let _intf = intf
let _intf_suffix s = Config.interface_suffix := s
let _keep_docs = set keep_docs
let _keep_locs = set keep_locs
let _labels = clear classic
let _linkall = set link_everything
let _max_inlining_depth spec =
Int_arg_helper.parse spec ~update:max_inlining_depth
~help_text:"Syntax: -max-inlining-depth <n> | <round>=<n>[,...]"
let _inline_max_depth spec =
Int_arg_helper.parse spec ~update:inline_max_depth
~help_text:"Syntax: -inline-max-depth <n> | <round>=<n>[,...]"
let _no_alias_deps = set transparent_modules
let _no_app_funct = clear applicative_functors
let _no_float_const_prop = clear float_const_prop
@ -167,8 +167,15 @@ module Options = Main_args.Make_optcomp_options (struct
(* CR mshinwell: should stop e.g. -O2 -classic-inlining
lgesbert: could be done in main() below, like for -pack and -c, but that
would prevent overriding using OCAMLPARAM. *)
let _o2 = set o2
let _o3 = set o3
let _o2 () =
default_simplify_rounds := 2;
use_inlining_arguments_set o2_arguments;
use_inlining_arguments_set ~round:0 o1_arguments
let _o3 () =
default_simplify_rounds := 3;
use_inlining_arguments_set o3_arguments;
use_inlining_arguments_set ~round:1 o2_arguments;
use_inlining_arguments_set ~round:0 o1_arguments
let _open s = open_modules := s :: !open_modules
let _output_obj = set output_c_object
let _output_complete_obj () =

8
middle_end/inline_and_simplify.ml
View File

@ -1613,8 +1613,8 @@ let add_predef_exns_to_environment ~env ~backend =
let run ~never_inline ~backend ~prefixname ~round program =
let r = R.create () in
let stats = !Clflags.inlining_stats in
if never_inline then Clflags.inlining_stats := false;
let report = !Clflags.inlining_report in
if never_inline then Clflags.inlining_report := false;
let initial_env =
add_predef_exns_to_environment
~env:(E.create ~never_inline ~backend ~round)
@ -1629,9 +1629,9 @@ let run ~never_inline ~backend ~prefixname ~round program =
Flambda.print_program result)
end;
assert (Static_exception.Set.is_empty (R.used_static_exceptions r));
if !Clflags.inlining_stats then begin
if !Clflags.inlining_report then begin
let output_prefix = Printf.sprintf "%s.%d" prefixname round in
Inlining_stats.save_then_forget_decisions ~output_prefix
end;
Clflags.inlining_stats := stats;
Clflags.inlining_report := report;
result

17
middle_end/inline_and_simplify_aux.ml
View File

@ -77,7 +77,7 @@ module Env = struct
let inlining_level_up env =
let max_level =
Clflags.Int_arg_helper.get ~key:(env.round) !Clflags.max_inlining_depth
Clflags.Int_arg_helper.get ~key:(env.round) !Clflags.inline_max_depth
in
if (env.inlining_level + 1) > max_level then
Misc.fatal_error "Inlining level increased above maximum";
@ -302,7 +302,8 @@ module Env = struct
try
Set_of_closures_origin.Map.find origin t.unroll_counts
with Not_found ->
Clflags.Int_arg_helper.get ~key:t.round !Clflags.unroll
Clflags.Int_arg_helper.get
~key:t.round !Clflags.inline_max_unroll
in
unroll_count > 0
@ -311,10 +312,12 @@ module Env = struct
try
Set_of_closures_origin.Map.find origin t.unroll_counts
with Not_found ->
Clflags.Int_arg_helper.get ~key:t.round !Clflags.unroll
Clflags.Int_arg_helper.get
~key:t.round !Clflags.inline_max_unroll
in
let unroll_counts =
Set_of_closures_origin.Map.add origin (unroll_count - 1) t.unroll_counts
Set_of_closures_origin.Map.add
origin (unroll_count - 1) t.unroll_counts
in
{ t with unroll_counts }
@ -323,7 +326,8 @@ module Env = struct
try
Closure_id.Map.find id t.inlining_counts
with Not_found ->
max 1 (Clflags.Int_arg_helper.get ~key:t.round !Clflags.unroll)
max 1 (Clflags.Int_arg_helper.get
~key:t.round !Clflags.inline_max_unroll)
in
inlining_count > 0
@ -332,7 +336,8 @@ module Env = struct
try
Closure_id.Map.find id t.inlining_counts
with Not_found ->
max 1 (Clflags.Int_arg_helper.get ~key:t.round !Clflags.unroll)
max 1 (Clflags.Int_arg_helper.get
~key:t.round !Clflags.inline_max_unroll)
in
let inlining_counts =
Closure_id.Map.add id (inlining_count - 1) t.inlining_counts

14
middle_end/inlining_cost.ml
View File

@ -439,20 +439,20 @@ module Whether_sufficient_benefit = struct
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 =
let inline_branch_factor =
let factor =
Clflags.Float_arg_helper.get ~key:t.round
!Clflags.branch_inline_factor
!Clflags.inline_branch_factor
in
if not (factor = factor) (* nan *) then
Clflags.default_branch_inline_factor
Clflags.default_inline_branch_factor
else if factor < 0. then
0.
else
factor
in
assert (correct_branch_factor branch_inline_factor);
1. /. (1. +. branch_inline_factor)
assert (correct_branch_factor inline_branch_factor);
1. /. (1. +. inline_branch_factor)
in
let call_estimated_probability =
branch_never_taken_estimated_probability ** float t.branch_depth
@ -650,7 +650,7 @@ let default_toplevel_multiplier = 8
let maximum_interesting_size_of_function_body_base =
lazy begin
let max_cost = ref 0 in
for round = 0 to !Clflags.simplify_rounds - 1 do
for round = 0 to (Clflags.rounds ()) - 1 do
let max_size =
let inline_call_cost = cost !Clflags.inline_call_cost ~round in
direct_call_size + (inline_call_cost * benefit_factor)
@ -663,7 +663,7 @@ let maximum_interesting_size_of_function_body_base =
let maximum_interesting_size_of_function_body_multiplier =
lazy begin
let max_cost = ref 0 in
for round = 0 to !Clflags.simplify_rounds - 1 do
for round = 0 to (Clflags.rounds ()) - 1 do
let max_size =
let inline_prim_cost = cost !Clflags.inline_prim_cost ~round in
inline_prim_cost * benefit_factor

2
middle_end/inlining_decision.ml
View File

@ -542,7 +542,7 @@ let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
~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
Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.inline_max_depth
in
let raw_inlining_threshold = R.inlining_threshold r in
let max_inlining_threshold =

12
middle_end/inlining_stats.ml
View File

@ -28,7 +28,7 @@ module Closure_stack = struct
let create () = []
let note_entering_closure t ~closure_id ~debuginfo =
if not !Clflags.inlining_stats then t
if not !Clflags.inlining_report then t
else
match t with
| [] | (Closure _ | Inlined | Specialised _) :: _->
@ -39,7 +39,7 @@ module Closure_stack = struct
(* 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
if not !Clflags.inlining_report then t
else
match t with
| [] | (Closure _ | Inlined | Specialised _) :: _ ->
@ -48,7 +48,7 @@ module Closure_stack = struct
Misc.fatal_errorf "note_entering_call: unexpected Call node"
let note_entering_inlined t =
if not !Clflags.inlining_stats then t
if not !Clflags.inlining_report then t
else
match t with
| [] | (Closure _ | Inlined | Specialised _) :: _->
@ -56,7 +56,7 @@ module Closure_stack = struct
| (Call _) :: _ -> Inlined :: t
let note_entering_specialised t ~closure_ids =
if not !Clflags.inlining_stats then t
if not !Clflags.inlining_report then t
else
match t with
| [] | (Closure _ | Inlined | Specialised _) :: _ ->
@ -70,7 +70,7 @@ let log
= ref []
let record_decision decision ~closure_stack =
if !Clflags.inlining_stats then begin
if !Clflags.inlining_report then begin
match closure_stack with
| []
| Closure_stack.Closure _ :: _
@ -252,6 +252,6 @@ let really_save_then_forget_decisions ~output_prefix =
log := []
let save_then_forget_decisions ~output_prefix =
if !Clflags.inlining_stats then begin
if !Clflags.inlining_report then begin
really_save_then_forget_decisions ~output_prefix
end

2
middle_end/middle_end.ml
View File

@ -102,7 +102,7 @@ let middle_end ppf ~source_provenance ~prefixname ~backend
pass_number := 0;
let round = !round_number in
incr round_number;
if !round_number > !Clflags.simplify_rounds then flam
if !round_number > (Clflags.rounds ()) then flam
else
flam
(* Beware: [Lift_constants] must be run before any pass that might

10
tools/ocamloptp.ml
View File

@ -64,19 +64,19 @@ module Options = Main_args.Make_optcomp_options (struct
let _impl s = with_impl := true; option_with_arg "-impl" s
let _inline s = option_with_arg "-inline" s
let _inline_toplevel n = option_with_arg "-inline-toplevel" n
let _inlining_stats = option "-inlining-report"
let _inlining_report = option "-inlining-report"
let _dump_pass = option_with_arg "-dump-pass"
let _max_inlining_depth n = option_with_arg "-max-inlining-depth" n
let _inline_max_depth n = option_with_arg "-inline-max-depth" n
let _rounds n = option_with_int "-rounds" n
let _unroll n = option_with_arg "-unroll" n
let _inline_max_unroll n = option_with_arg "-unroll" n
let _inline_call_cost n = option_with_arg "-inline-call-cost" n
let _inline_alloc_cost n = option_with_arg "-inline-alloc-cost" n
let _inline_prim_cost n = option_with_arg "-inline-prim-cost" n
let _inline_branch_cost n = option_with_arg "-inline-branch-cost" n
let _inline_indirect_cost n = option_with_arg "-inline-indirect-cost" n
let _inline_lifting_benefit n = option_with_arg "-inline-lifting-benefit" n
let _branch_inline_factor n = option_with_arg "-branch-inline-factor" n
let _classic_inlining = option "-classic-inlining"
let _inline_branch_factor n = option_with_arg "-inline-branch-factor" n
let _classic_inlining = option "-Oclassic"
let _intf s = with_intf := true; option_with_arg "-intf" s
let _intf_suffix s = option_with_arg "-intf-suffix" s
let _keep_docs = option "-keep-docs"

36
toplevel/opttopmain.ml
View File

@ -78,12 +78,12 @@ module Options = Main_args.Make_opttop_options (struct
let _inline_toplevel spec =
Int_arg_helper.parse spec ~update:inline_toplevel_threshold
~help_text:"Syntax: -inline-toplevel <n> | <round>=<n>[,...]"
let _inlining_stats () = inlining_stats := true
let _inlining_report () = inlining_report := true
let _dump_pass pass = set_dumped_pass pass true
let _rounds n = simplify_rounds := n
let _unroll spec =
Int_arg_helper.parse spec ~update:unroll
~help_text:"Syntax: -unroll <n> | <round>=<n>[,...]"
let _rounds n = simplify_rounds := Some n
let _inline_max_unroll spec =
Int_arg_helper.parse spec ~update:inline_max_unroll
~help_text:"Syntax: -inline-max-unroll <n> | <round>=<n>[,...]"
let _classic_inlining () = classic_inlining := true
let _inline_call_cost spec =
Int_arg_helper.parse spec ~update:inline_call_cost
@ -100,24 +100,24 @@ module Options = Main_args.Make_opttop_options (struct
let _inline_lifting_benefit spec =
Int_arg_helper.parse spec ~update:inline_lifting_benefit
~help_text:"Syntax: -inline-lifting-benefit <n> | <round>=<n>[,...]"
let _branch_inline_factor spec =
Float_arg_helper.parse spec ~update:branch_inline_factor
~help_text:"Syntax: -branch-inline-factor <n> | <round>=<n>[,...]"
let _max_inlining_depth spec =
Int_arg_helper.parse spec ~update:max_inlining_depth
~help_text:"Syntax: -max-inlining-depth <n> | <round>=<n>[,...]"
let _inline_branch_factor spec =
Float_arg_helper.parse spec ~update:inline_branch_factor
~help_text:"Syntax: -inline-branch-factor <n> | <round>=<n>[,...]"
let _inline_max_depth spec =
Int_arg_helper.parse spec ~update:inline_max_depth
~help_text:"Syntax: -inline-max-depth <n> | <round>=<n>[,...]"
let _no_unbox_free_vars_of_closures = clear unbox_free_vars_of_closures
let _no_unbox_specialised_args = clear unbox_specialised_args
let _o s = output_name := Some s
let _o2 () =
simplify_rounds := 2;
use_inlining_arguments_set ~round:1 o1_arguments;
use_inlining_arguments_set ~round:2 o2_arguments
default_simplify_rounds := 2;
use_inlining_arguments_set o2_arguments;
use_inlining_arguments_set ~round:0 o1_arguments
let _o3 () =
simplify_rounds := 3;
use_inlining_arguments_set ~round:1 o1_arguments;
use_inlining_arguments_set ~round:2 o2_arguments;
use_inlining_arguments_set ~round:3 o3_arguments
default_simplify_rounds := 3;
use_inlining_arguments_set o3_arguments;
use_inlining_arguments_set ~round:1 o2_arguments;
use_inlining_arguments_set ~round:0 o1_arguments
let _remove_unused_arguments = set remove_unused_arguments
let _unbox_closures = set unbox_closures
let _drawclambda = set dump_rawclambda

43
utils/arg_helper.ml
View File

@ -31,11 +31,32 @@ module Make (S : sig
end
end) = struct
type parsed = {
default : S.Value.t;
override : S.Value.t S.Key.Map.t;
base_default : S.Value.t;
base_override : S.Value.t S.Key.Map.t;
user_default : S.Value.t option;
user_override : S.Value.t S.Key.Map.t;
}
let default v = { default = v; override = S.Key.Map.empty }
let default v =
{ base_default = v;
base_override = S.Key.Map.empty;
user_default = None;
user_override = S.Key.Map.empty; }
let set_base_default value t =
{ t with base_default = value }
let add_base_override key value t =
{ t with base_override = S.Key.Map.add key value t.base_override }
let reset_base_overrides t =
{ t with base_override = S.Key.Map.empty }
let set_user_default value t =
{ t with user_default = Some value }
let add_user_override key value t =
{ t with user_override = S.Key.Map.add key value t.user_override }
let no_equals value =
match String.index value '=' with
@ -51,7 +72,7 @@ end) = struct
match String.index value '=' with
| exception Not_found ->
begin match S.Value.of_string value with
| value -> { acc with default = value }
| value -> set_user_default value acc
| exception exn -> raise (Parse_failure exn)
end
| equals ->
@ -74,7 +95,7 @@ end) = struct
try S.Value.of_string value
with exn -> raise (Parse_failure exn)
in
{ acc with override = S.Key.Map.add key value acc.override })
add_user_override key value acc)
!update
values
in
@ -96,8 +117,14 @@ end) = struct
| exception (Parse_failure exn) -> Parse_failed exn
let get ~key parsed =
match S.Key.Map.find key parsed.override with
| provided -> provided
match S.Key.Map.find key parsed.user_override with
| value -> value
| exception Not_found ->
parsed.default
match parsed.user_default with
| Some value -> value
| None ->
match S.Key.Map.find key parsed.base_override with
| value -> value
| exception Not_found -> parsed.base_default
end

15
utils/arg_helper.mli
View File

@ -37,13 +37,20 @@ module Make (S : sig
val of_string : string -> t
end
end) : sig
type parsed = {
default : S.Value.t;
override : S.Value.t S.Key.Map.t;
}
type parsed
val default : S.Value.t -> parsed
val set_base_default : S.Value.t -> parsed -> parsed
val add_base_override : S.Key.t -> S.Value.t -> parsed -> parsed
val reset_base_overrides : parsed -> parsed
val set_user_default : S.Value.t -> parsed -> parsed
val add_user_override : S.Key.t -> S.Value.t -> parsed -> parsed
val parse : string -> help_text:string -> update:parsed ref -> unit
type parse_result =

163
utils/clflags.ml
View File

@ -118,18 +118,15 @@ let dump_scheduling = ref false (* -dscheduling *)
let dump_linear = ref false (* -dlinear *)
let keep_startup_file = ref false (* -dstartup *)
let dump_combine = ref false (* -dcombine *)
let print_timings = ref false (* -dtimings *)
let native_code = ref false (* set to true under ocamlopt *)
let o2 = ref false (* -O2 *)
let o3 = ref false (* -O3 *)
let default_inline_threshold = if Config.flambda then 10. else 10. /. 8.
let inline_threshold = ref (Float_arg_helper.default default_inline_threshold)
let inlining_stats = ref false
let simplify_rounds = ref 1
let default_unroll = 0
let unroll = ref (Int_arg_helper.default default_unroll)
let force_slash = ref false (* for ocamldep *)
let clambda_checks = ref false (* -clambda-checks *)
let flambda_invariant_checks = ref true (* -flambda-invariants *)
let dont_write_files = ref false (* set to true under ocamldoc *)
let std_include_flag prefix =
@ -154,20 +151,33 @@ let keep_docs = ref false (* -keep-docs *)
let keep_locs = ref false (* -keep-locs *)
let unsafe_string = ref true;; (* -safe-string / -unsafe-string *)
let classic_inlining = ref false (* -Oclassic *)
let inlining_report = ref false (* -inlining-report *)
let simplify_rounds = ref None (* -rounds *)
let default_simplify_rounds = ref 1 (* -rounds *)
let rounds () =
match !simplify_rounds with
| None -> !default_simplify_rounds
| Some r -> r
let default_inline_threshold = if Config.flambda then 10. else 10. /. 8.
let inline_toplevel_multiplier = 16
let default_inline_toplevel_threshold =
int_of_float ((float inline_toplevel_multiplier) *. default_inline_threshold)
let inline_toplevel_threshold =
ref (Int_arg_helper.default default_inline_toplevel_threshold)
let default_inline_call_cost = 5
let default_inline_alloc_cost = 3
let default_inline_prim_cost = 3
let default_inline_branch_cost = 5
let default_inline_indirect_cost = 4
let default_branch_inline_factor = 0.1
let default_inline_branch_factor = 0.1
let default_inline_lifting_benefit = 1300
let default_inline_max_unroll = 0
let default_inline_max_depth = 1
let inline_threshold = ref (Float_arg_helper.default default_inline_threshold)
let inline_toplevel_threshold =
ref (Int_arg_helper.default default_inline_toplevel_threshold)
let inline_call_cost = ref (Int_arg_helper.default default_inline_call_cost)
let inline_alloc_cost = ref (Int_arg_helper.default default_inline_alloc_cost)
let inline_prim_cost = ref (Int_arg_helper.default default_inline_prim_cost)
@ -175,24 +185,21 @@ let inline_branch_cost =
ref (Int_arg_helper.default default_inline_branch_cost)
let inline_indirect_cost =
ref (Int_arg_helper.default default_inline_indirect_cost)
let branch_inline_factor =
ref (Float_arg_helper.default default_branch_inline_factor)
let inline_branch_factor =
ref (Float_arg_helper.default default_inline_branch_factor)
let inline_lifting_benefit =
ref (Int_arg_helper.default default_inline_lifting_benefit)
let inline_max_unroll =
ref (Int_arg_helper.default default_inline_max_unroll)
let inline_max_depth =
ref (Int_arg_helper.default default_inline_max_depth)
let print_timings = ref false (* -timings *)
let unbox_specialised_args = ref true
let unbox_specialised_args = ref true (* -no-unbox-specialised-args *)
let unbox_free_vars_of_closures = ref true
let unbox_closures = ref false (* -unbox-closures *)
let remove_unused_arguments = ref false (* -remove-unused-arguments *)
let classic_inlining = ref false (* -classic-inlining *)
let default_max_inlining_depth = 1
let max_inlining_depth =
ref (Int_arg_helper.default default_max_inlining_depth)
type inlining_arguments = {
inline_call_cost : int option;
inline_alloc_cost : int option;
@ -200,55 +207,61 @@ type inlining_arguments = {
inline_branch_cost : int option;
inline_indirect_cost : int option;
inline_lifting_benefit : int option;
branch_inline_factor : float option;
max_inlining_depth : int option;
unroll : int option;
inline_branch_factor : float option;
inline_max_depth : int option;
inline_max_unroll : int option;
inline_threshold : float option;
inline_toplevel_threshold : int option;
}
let set_int_arg round (arg:Int_arg_helper.parsed ref) value =
let open Int_arg_helper in
match value with
| None -> ()
| Some value ->
let parsed =
match round with
| None -> { !arg with default = value }
| Some round ->
{ !arg with
override = Numbers.Int.Map.add round value !arg.override }
in
arg := parsed
let set_int_arg round (arg:Int_arg_helper.parsed ref) default value =
let value : int =
match value with
| None -> default
| Some value -> value
in
match round with
| None ->
arg := Int_arg_helper.set_base_default value
(Int_arg_helper.reset_base_overrides !arg)
| Some round ->
arg := Int_arg_helper.add_base_override round value !arg
let set_float_arg round (arg:Float_arg_helper.parsed ref) value =
let open Float_arg_helper in
match value with
| None -> ()
| Some value ->
let parsed =
match round with
| None -> { !arg with default = value }
| Some round ->
{ !arg with
override = Numbers.Int.Map.add round value !arg.override }
in
arg := parsed
let set_float_arg round (arg:Float_arg_helper.parsed ref) default value =
let value =
match value with
| None -> default
| Some value -> value
in
match round with
| None ->
arg := Float_arg_helper.set_base_default value
(Float_arg_helper.reset_base_overrides !arg)
| Some round ->
arg := Float_arg_helper.add_base_override round value !arg
let use_inlining_arguments_set ?round (arg:inlining_arguments) =
let set_int = set_int_arg round in
let set_float = set_float_arg round in
set_int inline_call_cost arg.inline_call_cost;
set_int inline_alloc_cost arg.inline_alloc_cost;
set_int inline_prim_cost arg.inline_prim_cost;
set_int inline_branch_cost arg.inline_branch_cost;
set_int inline_indirect_cost arg.inline_indirect_cost;
set_int inline_lifting_benefit arg.inline_lifting_benefit;
set_float branch_inline_factor arg.branch_inline_factor;
set_int max_inlining_depth arg.max_inlining_depth;
set_int unroll arg.unroll;
set_float inline_threshold arg.inline_threshold;
set_int inline_toplevel_threshold arg.inline_toplevel_threshold
set_int inline_call_cost default_inline_call_cost arg.inline_call_cost;
set_int inline_alloc_cost default_inline_alloc_cost arg.inline_alloc_cost;
set_int inline_prim_cost default_inline_prim_cost arg.inline_prim_cost;
set_int inline_branch_cost
default_inline_branch_cost arg.inline_branch_cost;
set_int inline_indirect_cost
default_inline_indirect_cost arg.inline_indirect_cost;
set_int inline_lifting_benefit
default_inline_lifting_benefit arg.inline_lifting_benefit;
set_float inline_branch_factor
default_inline_branch_factor arg.inline_branch_factor;
set_int inline_max_depth
default_inline_max_depth arg.inline_max_depth;
set_int inline_max_unroll
default_inline_max_unroll arg.inline_max_unroll;
set_float inline_threshold
default_inline_threshold arg.inline_threshold;
set_int inline_toplevel_threshold
default_inline_toplevel_threshold arg.inline_toplevel_threshold
(* o1 is the default *)
let o1_arguments = {
@ -258,9 +271,9 @@ let o1_arguments = {
inline_branch_cost = None;
inline_indirect_cost = None;
inline_lifting_benefit = None;
branch_inline_factor = None;
max_inlining_depth = None;
unroll = None;
inline_branch_factor = None;
inline_max_depth = None;
inline_max_unroll = None;
inline_threshold = None;
inline_toplevel_threshold = None;
}
@ -272,9 +285,9 @@ let classic_arguments = {
inline_branch_cost = None;
inline_indirect_cost = None;
inline_lifting_benefit = None;
branch_inline_factor = None;
max_inlining_depth = None;
unroll = None;
inline_branch_factor = None;
inline_max_depth = None;
inline_max_unroll = None;
(* [inline_threshold] matches the current compiler's default.
Note that this particular fraction can be expressed exactly in
floating point. *)
@ -290,9 +303,9 @@ let o2_arguments = {
inline_branch_cost = Some (2 * default_inline_branch_cost);
inline_indirect_cost = Some (2 * default_inline_indirect_cost);
inline_lifting_benefit = None;
branch_inline_factor = None;
max_inlining_depth = Some 2;
unroll = None;
inline_branch_factor = None;
inline_max_depth = Some 2;
inline_max_unroll = None;
inline_threshold = Some 25.;
inline_toplevel_threshold = Some (25 * inline_toplevel_multiplier);
}
@ -304,9 +317,9 @@ let o3_arguments = {
inline_branch_cost = Some (3 * default_inline_branch_cost);
inline_indirect_cost = Some (3 * default_inline_indirect_cost);
inline_lifting_benefit = None;
branch_inline_factor = Some 0.;
max_inlining_depth = Some 3;
unroll = Some 1;
inline_branch_factor = Some 0.;
inline_max_depth = Some 3;
inline_max_unroll = Some 1;
inline_threshold = Some 50.;
inline_toplevel_threshold = Some (50 * inline_toplevel_multiplier);
}
@ -329,8 +342,6 @@ let set_dumped_pass s enabled =
dumped_passes_list := dumped_passes
end
let flambda_invariant_checks = ref true
let parse_color_setting = function
| "auto" -> Some Misc.Color.Auto
| "always" -> Some Misc.Color.Always

36
utils/clflags.mli
View File

@ -12,10 +12,7 @@
(** Optimization parameters represented as ints indexed by round number. *)
module Int_arg_helper : sig
type parsed = {
default : int;
override : int Numbers.Int.Map.t;
}
type parsed
val parse : string -> help_text:string -> update:parsed ref -> unit
@ -29,10 +26,7 @@ end
(** Optimization parameters represented as floats indexed by round number. *)
module Float_arg_helper : sig
type parsed = {
default : float;
override : float Numbers.Int.Map.t;
}
type parsed
val parse : string -> help_text:string -> update:parsed ref -> unit
@ -51,9 +45,9 @@ type inlining_arguments = {
inline_branch_cost : int option;
inline_indirect_cost : int option;
inline_lifting_benefit : int option;
branch_inline_factor : float option;
max_inlining_depth : int option;
unroll : int option;
inline_branch_factor : float option;
inline_max_depth : int option;
inline_max_unroll : int option;
inline_threshold : float option;
inline_toplevel_threshold : int option;
}
@ -146,14 +140,14 @@ val dump_linear : bool ref
val keep_startup_file : bool ref
val dump_combine : bool ref
val native_code : bool ref
val o2 : bool ref
val o3 : bool ref
val default_inline_threshold : float
val inline_threshold : Float_arg_helper.parsed ref
val inlining_stats : bool ref
val simplify_rounds : int ref
val default_unroll : int
val unroll : Int_arg_helper.parsed ref
val inlining_report : bool ref
val simplify_rounds : int option ref
val default_simplify_rounds : int ref
val rounds : unit -> int
val default_inline_max_unroll : int
val inline_max_unroll : Int_arg_helper.parsed ref
val default_inline_toplevel_threshold : int
val inline_toplevel_threshold : Int_arg_helper.parsed ref
val default_inline_call_cost : int
@ -168,8 +162,8 @@ val inline_prim_cost : Int_arg_helper.parsed ref
val inline_branch_cost : Int_arg_helper.parsed ref
val inline_indirect_cost : Int_arg_helper.parsed ref
val inline_lifting_benefit : Int_arg_helper.parsed ref
val default_branch_inline_factor : float
val branch_inline_factor : Float_arg_helper.parsed ref
val default_inline_branch_factor : float
val inline_branch_factor : Float_arg_helper.parsed ref
val dont_write_files : bool ref
val std_include_flag : string -> string
val std_include_dir : unit -> string list
@ -188,8 +182,8 @@ val unbox_closures : bool ref
val unbox_free_vars_of_closures : bool ref
val unbox_specialised_args : bool ref
val clambda_checks : bool ref
val default_max_inlining_depth : int
val max_inlining_depth : Int_arg_helper.parsed ref
val default_inline_max_depth : int
val inline_max_depth : Int_arg_helper.parsed ref
val remove_unused_arguments : bool ref
val dump_flambda_verbose : bool ref
val classic_inlining : bool ref