1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *)
6 (* *)
7 (* Copyright 2013 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 open Clflags
17
18 let output_prefix name =
19 let oname =
20 match !output_name with
21 | None -> name
22 | Some n -> if !compile_only then (output_name := None; n) else name in
23 Filename.remove_extension oname
24
25 let print_version_and_library compiler =
26 Printf.printf "The OCaml %s, version " compiler;
27 print_string Config.version; print_newline();
28 print_string "Standard library directory: ";
29 print_string Config.standard_library; print_newline();
30 exit 0
31
32 let print_version_string () =
33 print_string Config.version; print_newline(); exit 0
34
35 let print_standard_library () =
36 print_string Config.standard_library; print_newline(); exit 0
37
38 let fatal err =
39 prerr_endline err;
40 exit 2
41
42 let extract_output = function
43 | Some s -> s
44 | None ->
45 fatal "Please specify the name of the output file, using option -o"
46
47 let default_output = function
48 | Some s -> s
49 | None -> Config.default_executable_name
50
51 let first_include_dirs = ref []
52 let last_include_dirs = ref []
53 let first_ccopts = ref []
54 let last_ccopts = ref []
55 let first_ppx = ref []
56 let last_ppx = ref []
57 let first_objfiles = ref []
58 let last_objfiles = ref []
59
60 (* Check validity of module name *)
61 let is_unit_name name =
62 try
63 if name = "" then raise Exit;
64 begin match name.[0] with
65 | 'A'..'Z' -> ()
66 | _ ->
67 raise Exit;
68 end;
69 for i = 1 to String.length name - 1 do
70 match name.[i] with
71 | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> ()
72 | _ ->
73 raise Exit;
74 done;
75 true
76 with Exit -> false
77 ;;
78
79 let check_unit_name filename name =
80 if not (is_unit_name name) then
81 Location.prerr_warning (Location.in_file filename)
82 (Warnings.Bad_module_name name);;
83
84 (* Compute name of module from output file name *)
85 let module_of_filename inputfile outputprefix =
86 let basename = Filename.basename outputprefix in
87 let name =
88 try
89 let pos = String.index basename '.' in
90 String.sub basename 0 pos
91 with Not_found -> basename
92 in
93 let name = String.capitalize_ascii name in
94 check_unit_name inputfile name;
95 name
96 ;;
97
98 type filename = string
99
100 type readenv_position =
101 Before_args | Before_compile of filename | Before_link
102
103 (* Syntax of OCAMLPARAM: SEP?(name=VALUE SEP)* _ (SEP name=VALUE)*
104 where VALUE should not contain SEP, and SEP is ',' if unspecified,
105 or ':', '|', ';', ' ' or ',' *)
106 exception SyntaxError of string
107
108 let print_error ppf msg =
109 Location.print_warning Location.none ppf
110 (Warnings.Bad_env_variable ("OCAMLPARAM", msg))
111
112 let parse_args s =
113 let args =
114 let len = String.length s in
115 if len = 0 then []
116 else
117 (* allow first char to specify an alternative separator in ":|; ," *)
118 match s.[0] with
119 | ( ':' | '|' | ';' | ' ' | ',' ) as c ->
120 List.tl (String.split_on_char c s)
121 | _ -> String.split_on_char ',' s
122 in
123 let rec iter is_after args before after =
124 match args with
125 [] ->
126 if not is_after then
127 raise (SyntaxError "no '_' separator found")
128 else
129 (List.rev before, List.rev after)
130 | "" :: tail -> iter is_after tail before after
131 | "_" :: _ when is_after -> raise (SyntaxError "too many '_' separators")
132 | "_" :: tail -> iter true tail before after
133 | arg :: tail ->
134 let binding = try
135 Misc.cut_at arg '='
136 with Not_found ->
137 raise (SyntaxError ("missing '=' in " ^ arg))
138 in
139 if is_after then
140 iter is_after tail before (binding :: after)
141 else
142 iter is_after tail (binding :: before) after
143 in
144 iter false args [] []
145
146 let setter ppf f name options s =
147 try
148 let bool = match s with
149 | "0" -> false
150 | "1" -> true
151 | _ -> raise Not_found
152 in
153 List.iter (fun b -> b := f bool) options
154 with Not_found ->
155 Printf.ksprintf (print_error ppf)
156 "bad value %s for %s" s name
157
158 let int_setter ppf name option s =
159 try
160 option := int_of_string s
161 with _ ->
162 Printf.ksprintf (print_error ppf)
163 "non-integer parameter %s for %S" s name
164
165 let int_option_setter ppf name option s =
166 try
167 option := Some (int_of_string s)
168 with _ ->
169 Printf.ksprintf (print_error ppf)
170 "non-integer parameter %s for %S" s name
171
172 (*
173 let float_setter ppf name option s =
174 try
175 option := float_of_string s
176 with _ ->
177 Location.print_warning Location.none ppf
178 (Warnings.Bad_env_variable
179 ("OCAMLPARAM", Printf.sprintf "non-float parameter for \"%s\"" name))
180 *)
181
182 let check_bool ppf name s =
183 match s with
184 | "0" -> false
185 | "1" -> true
186 | _ ->
187 Printf.ksprintf (print_error ppf)
188 "bad value %s for %s" s name;
189 false
190
191 (* 'can-discard=' specifies which arguments can be discarded without warning
192 because they are not understood by some versions of OCaml. *)
193 let can_discard = ref []
194
195 let read_one_param ppf position name v =
196 let set name options s = setter ppf (fun b -> b) name options s in
197 let clear name options s = setter ppf (fun b -> not b) name options s in
198 match name with
199 | "g" -> set "g" [ Clflags.debug ] v
200 | "bin-annot" -> set "bin-annot" [ Clflags.binary_annotations ] v
201 | "afl-instrument" -> set "afl-instrument" [ Clflags.afl_instrument ] v
202 | "afl-inst-ratio" ->
203 int_setter ppf "afl-inst-ratio" afl_inst_ratio v
204 | "annot" -> set "annot" [ Clflags.annotations ] v
205 | "absname" -> set "absname" [ Clflags.absname ] v
206 | "compat-32" -> set "compat-32" [ bytecode_compatible_32 ] v
207 | "noassert" -> set "noassert" [ noassert ] v
208 | "noautolink" -> set "noautolink" [ no_auto_link ] v
209 | "nostdlib" -> set "nostdlib" [ no_std_include ] v
210 | "linkall" -> set "linkall" [ link_everything ] v
211 | "nolabels" -> set "nolabels" [ classic ] v
212 | "principal" -> set "principal" [ principal ] v
213 | "rectypes" -> set "rectypes" [ recursive_types ] v
214 | "safe-string" -> clear "safe-string" [ unsafe_string ] v
215 | "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v
216 | "strict-formats" -> set "strict-formats" [ strict_formats ] v
217 | "thread" -> set "thread" [ use_threads ] v
218 | "unboxed-types" -> set "unboxed-types" [ unboxed_types ] v
219 | "unsafe" -> set "unsafe" [ unsafe ] v
220 | "verbose" -> set "verbose" [ verbose ] v
221 | "nopervasives" -> set "nopervasives" [ nopervasives ] v
222 | "slash" -> set "slash" [ force_slash ] v (* for ocamldep *)
223 | "keep-docs" -> set "keep-docs" [ Clflags.keep_docs ] v
224 | "keep-locs" -> set "keep-locs" [ Clflags.keep_locs ] v
225
226 | "compact" -> clear "compact" [ optimize_for_speed ] v
227 | "no-app-funct" -> clear "no-app-funct" [ applicative_functors ] v
228 | "nodynlink" -> clear "nodynlink" [ dlcode ] v
229 | "short-paths" -> clear "short-paths" [ real_paths ] v
230 | "trans-mod" -> set "trans-mod" [ transparent_modules ] v
231 | "opaque" -> set "opaque" [ opaque ] v
232
233 | "pp" -> preprocessor := Some v
234 | "runtime-variant" -> runtime_variant := v
235 | "with-runtime" -> set "with-runtime" [ with_runtime ] v
236 | "open" ->
237 open_modules := List.rev_append (String.split_on_char ',' v) !open_modules
238 | "cc" -> c_compiler := Some v
239
240 | "clambda-checks" -> set "clambda-checks" [ clambda_checks ] v
241
242 | "function-sections" ->
243 set "function-sections" [ Clflags.function_sections ] v
244 (* assembly sources *)
245 | "s" ->
246 set "s" [ Clflags.keep_asm_file ; Clflags.keep_startup_file ] v
247 | "S" -> set "S" [ Clflags.keep_asm_file ] v
248 | "dstartup" -> set "dstartup" [ Clflags.keep_startup_file ] v
249
250 (* warn-errors *)
251 | "we" | "warn-error" -> Warnings.parse_options true v
252 (* warnings *)
253 | "w" -> Warnings.parse_options false v
254 (* warn-errors *)
255 | "wwe" -> Warnings.parse_options false v
256 (* alerts *)
257 | "alert" -> Warnings.parse_alert_option v
258
259 (* inlining *)
260 | "inline" ->
261 let module F = Float_arg_helper in
262 begin match F.parse_no_error v inline_threshold with
263 | F.Ok -> ()
264 | F.Parse_failed exn ->
265 Printf.ksprintf (print_error ppf)
266 "bad syntax %s for \"inline\": %s" v (Printexc.to_string exn)
267 end
268
269 | "inline-toplevel" ->
270 Int_arg_helper.parse v
271 "Bad syntax in OCAMLPARAM for 'inline-toplevel'"
272 inline_toplevel_threshold
273
274 | "rounds" -> int_option_setter ppf "rounds" simplify_rounds v
275 | "inline-max-unroll" ->
276 Int_arg_helper.parse v "Bad syntax in OCAMLPARAM for 'inline-max-unroll'"
277 inline_max_unroll
278 | "inline-call-cost" ->
279 Int_arg_helper.parse v
280 "Bad syntax in OCAMLPARAM for 'inline-call-cost'"
281 inline_call_cost
282 | "inline-alloc-cost" ->
283 Int_arg_helper.parse v
284 "Bad syntax in OCAMLPARAM for 'inline-alloc-cost'"
285 inline_alloc_cost
286 | "inline-prim-cost" ->
287 Int_arg_helper.parse v
288 "Bad syntax in OCAMLPARAM for 'inline-prim-cost'"
289 inline_prim_cost
290 | "inline-branch-cost" ->
291 Int_arg_helper.parse v
292 "Bad syntax in OCAMLPARAM for 'inline-branch-cost'"
293 inline_branch_cost
294 | "inline-indirect-cost" ->
295 Int_arg_helper.parse v
296 "Bad syntax in OCAMLPARAM for 'inline-indirect-cost'"
297 inline_indirect_cost
298 | "inline-lifting-benefit" ->
299 Int_arg_helper.parse v
300 "Bad syntax in OCAMLPARAM for 'inline-lifting-benefit'"
301 inline_lifting_benefit
302 | "inline-branch-factor" ->
303 Float_arg_helper.parse v
304 "Bad syntax in OCAMLPARAM for 'inline-branch-factor'"
305 inline_branch_factor
306 | "inline-max-depth" ->
307 Int_arg_helper.parse v
308 "Bad syntax in OCAMLPARAM for 'inline-max-depth'"
309 inline_max_depth
310
311 | "Oclassic" ->
312 set "Oclassic" [ classic_inlining ] v
313 | "O2" ->
314 if check_bool ppf "O2" v then begin
315 default_simplify_rounds := 2;
316 use_inlining_arguments_set o2_arguments;
317 use_inlining_arguments_set ~round:0 o1_arguments
318 end
319
320 | "O3" ->
321 if check_bool ppf "O3" v then begin
322 default_simplify_rounds := 3;
323 use_inlining_arguments_set o3_arguments;
324 use_inlining_arguments_set ~round:1 o2_arguments;
325 use_inlining_arguments_set ~round:0 o1_arguments
326 end
327 | "unbox-closures" ->
328 set "unbox-closures" [ unbox_closures ] v
329 | "unbox-closures-factor" ->
330 int_setter ppf "unbox-closures-factor" unbox_closures_factor v
331 | "remove-unused-arguments" ->
332 set "remove-unused-arguments" [ remove_unused_arguments ] v
333
334 | "inlining-report" ->
335 if !native_code then
336 set "inlining-report" [ inlining_report ] v
337
338 | "flambda-verbose" ->
339 set "flambda-verbose" [ dump_flambda_verbose ] v
340 | "flambda-invariants" ->
341 set "flambda-invariants" [ flambda_invariant_checks ] v
342 | "linscan" ->
343 set "linscan" [ use_linscan ] v
344 | "insn-sched" -> set "insn-sched" [ insn_sched ] v
345 | "no-insn-sched" -> clear "insn-sched" [ insn_sched ] v
346
347 (* color output *)
348 | "color" ->
349 begin match color_reader.parse v with
350 | None ->
351 Printf.ksprintf (print_error ppf)
352 "bad value %s for \"color\", (%s)" v color_reader.usage
353 | Some setting -> color := Some setting
354 end
355
356 | "error-style" ->
357 begin match error_style_reader.parse v with
358 | None ->
359 Printf.ksprintf (print_error ppf)
360 "bad value %s for \"error-style\", (%s)" v error_style_reader.usage
361 | Some setting -> error_style := Some setting
362 end
363
364 | "intf-suffix" -> Config.interface_suffix := v
365
366 | "I" -> begin
367 match position with
368 | Before_args -> first_include_dirs := v :: !first_include_dirs
369 | Before_link | Before_compile _ ->
370 last_include_dirs := v :: !last_include_dirs
371 end
372
373 | "cclib" ->
374 begin
375 match position with
376 | Before_compile _ -> ()
377 | Before_link | Before_args ->
378 ccobjs := Misc.rev_split_words v @ !ccobjs
379 end
380
381 | "ccopt"
382 | "ccopts"
383 ->
384 begin
385 match position with
386 | Before_link | Before_compile _ ->
387 last_ccopts := v :: !last_ccopts
388 | Before_args ->
389 first_ccopts := v :: !first_ccopts
390 end
391
392 | "ppx" ->
393 begin
394 match position with
395 | Before_link | Before_compile _ ->
396 last_ppx := v :: !last_ppx
397 | Before_args ->
398 first_ppx := v :: !first_ppx
399 end
400
401
402 | "cmo" | "cma" ->
403 if not !native_code then
404 begin
405 match position with
406 | Before_link | Before_compile _ ->
407 last_objfiles := v ::! last_objfiles
408 | Before_args ->
409 first_objfiles := v :: !first_objfiles
410 end
411
412 | "cmx" | "cmxa" ->
413 if !native_code then
414 begin
415 match position with
416 | Before_link | Before_compile _ ->
417 last_objfiles := v ::! last_objfiles
418 | Before_args ->
419 first_objfiles := v :: !first_objfiles
420 end
421
422 | "pic" ->
423 if !native_code then
424 set "pic" [ pic_code ] v
425
426 | "can-discard" ->
427 can_discard := v ::!can_discard
428
429 | "timings" | "profile" ->
430 let if_on = if name = "timings" then [ `Time ] else Profile.all_columns in
431 profile_columns := if check_bool ppf name v then if_on else []
432
433 | "stop-after" ->
434 let module P = Clflags.Compiler_pass in
435 begin match P.of_string v with
436 | None ->
437 Printf.ksprintf (print_error ppf)
438 "bad value %s for option \"stop-after\" (expected one of: %s)"
439 v (String.concat ", " P.pass_names)
440 | Some pass ->
441 Clflags.stop_after := Some pass;
442 begin match pass with
443 | P.Parsing | P.Typing ->
444 compile_only := true
445 end;
446 end
447 | _ ->
448 if not (List.mem name !can_discard) then begin
449 can_discard := name :: !can_discard;
450 Printf.ksprintf (print_error ppf)
451 "Warning: discarding value of variable %S in OCAMLPARAM\n%!"
452 name
453 end
454
455 let read_OCAMLPARAM ppf position =
456 try
457 let s = Sys.getenv "OCAMLPARAM" in
458 let (before, after) =
459 try
460 parse_args s
461 with SyntaxError s ->
462 print_error ppf s;
463 [],[]
464 in
465 List.iter (fun (name, v) -> read_one_param ppf position name v)
466 (match position with
467 Before_args -> before
468 | Before_compile _ | Before_link -> after)
469 with Not_found -> ()
470
471 (* OCAMLPARAM passed as file *)
472
473 type pattern =
474 | Filename of string
475 | Any
476
477 type file_option = {
478 pattern : pattern;
479 name : string;
480 value : string;
481 }
482
483 let scan_line ic =
484 Scanf.bscanf ic "%[0-9a-zA-Z_.*] : %[a-zA-Z_-] = %s "
485 (fun pattern name value ->
486 let pattern =
487 match pattern with
488 | "*" -> Any
489 | _ -> Filename pattern
490 in
491 { pattern; name; value })
492
493 let load_config ppf filename =
494 match open_in_bin filename with
495 | exception e ->
496 Location.errorf ~loc:(Location.in_file filename)
497 "Cannot open file %s" (Printexc.to_string e)
498 |> Location.print_report ppf;
499 raise Exit
500 | ic ->
501 let sic = Scanf.Scanning.from_channel ic in
502 let rec read line_number line_start acc =
503 match scan_line sic with
504 | exception End_of_file ->
505 close_in ic;
506 acc
507 | exception Scanf.Scan_failure error ->
508 let position = Lexing.{
509 pos_fname = filename;
510 pos_lnum = line_number;
511 pos_bol = line_start;
512 pos_cnum = pos_in ic;
513 }
514 in
515 let loc = Location.{
516 loc_start = position;
517 loc_end = position;
518 loc_ghost = false;
519 }
520 in
521 Location.errorf ~loc "Configuration file error %s" error
522 |> Location.print_report ppf;
523 close_in ic;
524 raise Exit
525 | line ->
526 read (line_number + 1) (pos_in ic) (line :: acc)
527 in
528 let lines = read 0 0 [] in
529 lines
530
531 let matching_filename filename { pattern } =
532 match pattern with
533 | Any -> true
534 | Filename pattern ->
535 let filename = String.lowercase_ascii filename in
536 let pattern = String.lowercase_ascii pattern in
537 filename = pattern
538
539 let apply_config_file ppf position =
540 let config_file =
541 Filename.concat Config.standard_library "ocaml_compiler_internal_params"
542 in
543 let config =
544 if Sys.file_exists config_file then
545 load_config ppf config_file
546 else
547 []
548 in
549 let config =
550 match position with
551 | Before_compile filename ->
552 List.filter (matching_filename filename) config
553 | Before_args | Before_link ->
554 List.filter (fun { pattern } -> pattern = Any) config
555 in
556 List.iter (fun { name; value } -> read_one_param ppf position name value)
557 config
558
559 let readenv ppf position =
560 last_include_dirs := [];
561 last_ccopts := [];
562 last_ppx := [];
563 last_objfiles := [];
564 apply_config_file ppf position;
565 read_OCAMLPARAM ppf position;
566 all_ccopts := !last_ccopts @ !first_ccopts;
567 all_ppx := !last_ppx @ !first_ppx
568
569 let get_objfiles ~with_ocamlparam =
570 if with_ocamlparam then
571 List.rev (!last_objfiles @ !objfiles @ !first_objfiles)
572 else
573 List.rev !objfiles
574
575
576
577
578
579
580 type deferred_action =
581 | ProcessImplementation of string
582 | ProcessInterface of string
583 | ProcessCFile of string
584 | ProcessOtherFile of string
585 | ProcessObjects of string list
586 | ProcessDLLs of string list
587
588 let c_object_of_filename name =
589 Filename.chop_suffix (Filename.basename name) ".c" ^ Config.ext_obj
590
591 let process_action
592 (ppf, implementation, interface, ocaml_mod_ext, ocaml_lib_ext) action =
593 match action with
594 | ProcessImplementation name ->
595 readenv ppf (Before_compile name);
596 let opref = output_prefix name in
597 implementation ~source_file:name ~output_prefix:opref;
598 objfiles := (opref ^ ocaml_mod_ext) :: !objfiles
599 | ProcessInterface name ->
600 readenv ppf (Before_compile name);
601 let opref = output_prefix name in
602 interface ~source_file:name ~output_prefix:opref;
603 if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles
604 | ProcessCFile name ->
605 readenv ppf (Before_compile name);
606 Location.input_name := name;
607 if Ccomp.compile_file name <> 0 then exit 2;
608 ccobjs := c_object_of_filename name :: !ccobjs
609 | ProcessObjects names ->
610 ccobjs := names @ !ccobjs
611 | ProcessDLLs names ->
612 dllibs := names @ !dllibs
613 | ProcessOtherFile name ->
614 if Filename.check_suffix name ocaml_mod_ext
615 || Filename.check_suffix name ocaml_lib_ext then
616 objfiles := name :: !objfiles
617 else if Filename.check_suffix name ".cmi" && !make_package then
618 objfiles := name :: !objfiles
619 else if Filename.check_suffix name Config.ext_obj
620 || Filename.check_suffix name Config.ext_lib then
621 ccobjs := name :: !ccobjs
622 else if not !native_code && Filename.check_suffix name Config.ext_dll then
623 dllibs := name :: !dllibs
624 else
625 raise(Arg.Bad("don't know what to do with " ^ name))
626
627
628 let action_of_file name =
629 if Filename.check_suffix name ".ml"
630 || Filename.check_suffix name ".mlt" then
631 ProcessImplementation name
632 else if Filename.check_suffix name !Config.interface_suffix then
633 ProcessInterface name
634 else if Filename.check_suffix name ".c" then
635 ProcessCFile name
636 else
637 ProcessOtherFile name
638
639 let deferred_actions = ref []
640 let defer action =
641 deferred_actions := action :: !deferred_actions
642
643 let anonymous filename = defer (action_of_file filename)
644 let impl filename = defer (ProcessImplementation filename)
645 let intf filename = defer (ProcessInterface filename)
646
647 let process_deferred_actions env =
648 let final_output_name = !output_name in
649 (* Make sure the intermediate products don't clash with the final one
650 when we're invoked like: ocamlopt -o foo bar.c baz.ml. *)
651 if not !compile_only then output_name := None;
652 begin
653 match final_output_name with
654 | None -> ()
655 | Some output_name ->
656 if !compile_only then begin
657 if List.filter (function
658 | ProcessCFile name -> c_object_of_filename name <> output_name
659 | _ -> false) !deferred_actions <> [] then
660 fatal "Options -c and -o are incompatible when compiling C files";
661
662 if List.length (List.filter (function
663 | ProcessImplementation _
664 | ProcessInterface _ -> true
665 | _ -> false) !deferred_actions) > 1 then
666 fatal "Options -c -o are incompatible with compiling multiple files"
667 end;
668 end;
669 if !make_archive && List.exists (function
670 | ProcessOtherFile name -> Filename.check_suffix name ".cmxa"
671 | _ -> false) !deferred_actions then
672 fatal "Option -a cannot be used with .cmxa input files.";
673 List.iter (process_action env) (List.rev !deferred_actions);
674 output_name := final_output_name;
675