forked from ocaml/ocaml
/
clflags.ml
409 lines (366 loc) · 15.9 KB
/
clflags.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* Command-line parameters *)
module Int_arg_helper = Arg_helper.Make (struct
module Key = struct
include Numbers.Int
let of_string = int_of_string
end
module Value = struct
include Numbers.Int
let of_string = int_of_string
end
end)
module Float_arg_helper = Arg_helper.Make (struct
module Key = struct
include Numbers.Int
let of_string = int_of_string
end
module Value = struct
include Numbers.Float
let of_string = float_of_string
end
end)
let objfiles = ref ([] : string list) (* .cmo and .cma files *)
and ccobjs = ref ([] : string list) (* .o, .a, .so and -cclib -lxxx *)
and dllibs = ref ([] : string list) (* .so and -dllib -lxxx *)
let compile_only = ref false (* -c *)
and output_name = ref (None : string option) (* -o *)
and include_dirs = ref ([] : string list)(* -I *)
and no_std_include = ref false (* -nostdlib *)
and print_types = ref false (* -i *)
and make_archive = ref false (* -a *)
and debug = ref false (* -g *)
and fast = ref false (* -unsafe *)
and use_linscan = ref false (* -linscan *)
and link_everything = ref false (* -linkall *)
and custom_runtime = ref false (* -custom *)
and no_check_prims = ref false (* -no-check-prims *)
and bytecode_compatible_32 = ref false (* -compat-32 *)
and output_c_object = ref false (* -output-obj *)
and output_complete_object = ref false (* -output-complete-obj *)
and all_ccopts = ref ([] : string list) (* -ccopt *)
and classic = ref false (* -nolabels *)
and nopervasives = ref false (* -nopervasives *)
and match_context_rows = ref 32 (* -match-context-rows *)
and preprocessor = ref(None : string option) (* -pp *)
and all_ppx = ref ([] : string list) (* -ppx *)
let annotations = ref false (* -annot *)
let binary_annotations = ref false (* -annot *)
and use_threads = ref false (* -thread *)
and use_vmthreads = ref false (* -vmthread *)
and noassert = ref false (* -noassert *)
and verbose = ref false (* -verbose *)
and noversion = ref false (* -no-version *)
and noprompt = ref false (* -noprompt *)
and nopromptcont = ref false (* -nopromptcont *)
and init_file = ref (None : string option) (* -init *)
and noinit = ref false (* -noinit *)
and open_modules = ref [] (* -open *)
and use_prims = ref "" (* -use-prims ... *)
and use_runtime = ref "" (* -use-runtime ... *)
and principal = ref false (* -principal *)
and real_paths = ref true (* -short-paths *)
and recursive_types = ref false (* -rectypes *)
and strict_sequence = ref false (* -strict-sequence *)
and strict_formats = ref false (* -strict-formats *)
and applicative_functors = ref true (* -no-app-funct *)
and make_runtime = ref false (* -make-runtime *)
and gprofile = ref false (* -p *)
and c_compiler = ref (None: string option) (* -cc *)
and no_auto_link = ref false (* -noautolink *)
and dllpaths = ref ([] : string list) (* -dllpath *)
and make_package = ref false (* -pack *)
and for_package = ref (None: string option) (* -for-pack *)
and error_size = ref 500 (* -error-size *)
and float_const_prop = ref true (* -no-float-const-prop *)
and transparent_modules = ref false (* -trans-mod *)
let unique_ids = ref true
let dump_source = ref false (* -dsource *)
let dump_parsetree = ref false (* -dparsetree *)
and dump_typedtree = ref false (* -dtypedtree *)
and dump_rawlambda = ref false (* -drawlambda *)
and dump_lambda = ref false (* -dlambda *)
and dump_rawclambda = ref false (* -drawclambda *)
and dump_clambda = ref false (* -dclambda *)
and dump_rawflambda = ref false (* -drawflambda *)
and dump_flambda = ref false (* -dflambda *)
and dump_flambda_let = ref (None : int option) (* -dflambda-let=... *)
and dump_flambda_verbose = ref false (* -dflambda-verbose *)
and dump_instr = ref false (* -dinstr *)
and keep_camlprimc_file = ref false (* -dcamlprimc *)
let keep_asm_file = ref false (* -S *)
let optimize_for_speed = ref true (* -compact *)
and opaque = ref false (* -opaque *)
and dump_cmm = ref false (* -dcmm *)
let dump_selection = ref false (* -dsel *)
let dump_cse = ref false (* -dcse *)
let dump_live = ref false (* -dlive *)
let dump_avail = ref false (* -davail *)
let dump_spill = ref false (* -dspill *)
let dump_split = ref false (* -dsplit *)
let dump_interf = ref false (* -dinterf *)
let dump_prefer = ref false (* -dprefer *)
let dump_regalloc = ref false (* -dalloc *)
let dump_reload = ref false (* -dreload *)
let dump_scheduling = ref false (* -dscheduling *)
let dump_linear = ref false (* -dlinear *)
let dump_interval = ref false (* -dinterval *)
let keep_startup_file = ref false (* -dstartup *)
let dump_combine = ref false (* -dcombine *)
let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *)
let debug_runavail = ref false (* -drunavail *)
let native_code = ref false (* set to true under ocamlopt *)
let force_slash = ref false (* for ocamldep *)
let clambda_checks = ref false (* -clambda-checks *)
let flambda_invariant_checks =
ref Config.with_flambda_invariants (* -flambda-(no-)invariants *)
let dont_write_files = ref false (* set to true under ocamldoc *)
let std_include_flag prefix =
if !no_std_include then ""
else (prefix ^ (Filename.quote Config.standard_library))
;;
let std_include_dir () =
if !no_std_include then [] else [Config.standard_library]
;;
let shared = ref false (* -shared *)
let dlcode = ref true (* not -nodynlink *)
let pic_code = ref (match Config.architecture with (* -fPIC *)
| "amd64" -> true
| _ -> false)
let runtime_variant = ref "";; (* -runtime-variant *)
let keep_docs = ref false (* -keep-docs *)
let keep_locs = ref true (* -keep-locs *)
let unsafe_string =
if Config.safe_string then ref false
else ref (not Config.default_safe_string)
(* -safe-string / -unsafe-string *)
let classic_inlining = ref false (* -Oclassic *)
let inlining_report = ref false (* -inlining-report *)
let afl_instrument = ref Config.afl_instrument (* -afl-instrument *)
let afl_inst_ratio = ref 100 (* -afl-inst-ratio *)
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 default_inline_call_cost = 5
let default_inline_alloc_cost = 7
let default_inline_prim_cost = 3
let default_inline_branch_cost = 5
let default_inline_indirect_cost = 4
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)
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 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 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 default_unbox_closures_factor = 10
let unbox_closures_factor =
ref default_unbox_closures_factor (* -unbox-closures-factor *)
let remove_unused_arguments = ref false (* -remove-unused-arguments *)
type inlining_arguments = {
inline_call_cost : int option;
inline_alloc_cost : int option;
inline_prim_cost : int option;
inline_branch_cost : int option;
inline_indirect_cost : int option;
inline_lifting_benefit : 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) 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) 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 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 = {
inline_call_cost = None;
inline_alloc_cost = None;
inline_prim_cost = None;
inline_branch_cost = None;
inline_indirect_cost = None;
inline_lifting_benefit = None;
inline_branch_factor = None;
inline_max_depth = None;
inline_max_unroll = None;
inline_threshold = None;
inline_toplevel_threshold = None;
}
let classic_arguments = {
inline_call_cost = None;
inline_alloc_cost = None;
inline_prim_cost = None;
inline_branch_cost = None;
inline_indirect_cost = None;
inline_lifting_benefit = 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. *)
inline_threshold = Some (10. /. 8.);
(* [inline_toplevel_threshold] is not used in classic mode. *)
inline_toplevel_threshold = Some 1;
}
let o2_arguments = {
inline_call_cost = Some (2 * default_inline_call_cost);
inline_alloc_cost = Some (2 * default_inline_alloc_cost);
inline_prim_cost = Some (2 * default_inline_prim_cost);
inline_branch_cost = Some (2 * default_inline_branch_cost);
inline_indirect_cost = Some (2 * default_inline_indirect_cost);
inline_lifting_benefit = 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);
}
let o3_arguments = {
inline_call_cost = Some (3 * default_inline_call_cost);
inline_alloc_cost = Some (3 * default_inline_alloc_cost);
inline_prim_cost = Some (3 * default_inline_prim_cost);
inline_branch_cost = Some (3 * default_inline_branch_cost);
inline_indirect_cost = Some (3 * default_inline_indirect_cost);
inline_lifting_benefit = None;
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);
}
let all_passes = ref []
let dumped_passes_list = ref []
let dumped_pass s =
assert(List.mem s !all_passes);
List.mem s !dumped_passes_list
let set_dumped_pass s enabled =
if (List.mem s !all_passes) then begin
let passes_without_s = List.filter ((<>) s) !dumped_passes_list in
let dumped_passes =
if enabled then
s :: passes_without_s
else
passes_without_s
in
dumped_passes_list := dumped_passes
end
let parse_color_setting = function
| "auto" -> Some Misc.Color.Auto
| "always" -> Some Misc.Color.Always
| "never" -> Some Misc.Color.Never
| _ -> None
let color = ref None ;; (* -color *)
let unboxed_types = ref false
let arg_spec = ref []
let arg_names = ref Misc.StringMap.empty
let reset_arguments () =
arg_spec := [];
arg_names := Misc.StringMap.empty
let add_arguments loc args =
List.iter (function (arg_name, _, _) as arg ->
try
let loc2 = Misc.StringMap.find arg_name !arg_names in
Printf.eprintf
"Warning: plugin argument %s is already defined:\n" arg_name;
Printf.eprintf " First definition: %s\n" loc2;
Printf.eprintf " New definition: %s\n" loc;
with Not_found ->
arg_spec := !arg_spec @ [ arg ];
arg_names := Misc.StringMap.add arg_name loc !arg_names
) args
let print_arguments usage =
Arg.usage !arg_spec usage
(* This function is almost the same as [Arg.parse_expand], except
that [Arg.parse_expand] could not be used because it does not take a
reference for [arg_spec].*)
let parse_arguments f msg =
try
let argv = ref Sys.argv in
let current = ref (!Arg.current) in
Arg.parse_and_expand_argv_dynamic current argv arg_spec f msg
with
| Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2
| Arg.Help msg -> Printf.printf "%s" msg; exit 0