diff options
author | Greta Yorsh <gyorsh@janestreet.com> | 2019-08-26 17:12:14 +0100 |
---|---|---|
committer | Greta Yorsh <gyorsh@janestreet.com> | 2019-10-30 15:27:29 +0000 |
commit | 7c11fcbdd1c0c00ee056737eb9be577c5cde7b33 (patch) | |
tree | 3f8910efb9fd3c4bc3d4fe5249074bf56a979d65 | |
parent | 03c33f500563f3e12355694f1add98e7bd1096ae (diff) | |
download | ocaml-7c11fcbdd1c0c00ee056737eb9be577c5cde7b33.tar.gz |
Stop before emit
-rw-r--r-- | asmcomp/asmgen.ml | 39 | ||||
-rw-r--r-- | driver/compenv.ml | 13 | ||||
-rw-r--r-- | driver/main.ml | 15 | ||||
-rw-r--r-- | driver/main_args.ml | 12 | ||||
-rw-r--r-- | driver/optmain.ml | 14 | ||||
-rw-r--r-- | utils/clflags.ml | 21 | ||||
-rw-r--r-- | utils/clflags.mli | 6 |
7 files changed, 83 insertions, 37 deletions
diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 1f209a5030..a6468b6c19 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -39,6 +39,17 @@ let pass_dump_linear_if ppf flag message phrase = if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase; phrase +let should_emit () = + not (should_stop_after Compiler_pass.Scheduling) + +let if_emit_do f x = if should_emit () then f x else () +let emit_begin_assembly = if_emit_do Emit.begin_assembly +let emit_end_assembly = if_emit_do Emit.end_assembly +let emit_data = if_emit_do Emit.data +let emit_fundecl = + if_emit_do + (Profile.record ~accumulate:true "emit" Emit.fundecl) + let rec regalloc ~ppf_dump round fd = if round > 50 then fatal_error(fd.Mach.fun_name ^ @@ -92,13 +103,13 @@ let compile_fundecl ~ppf_dump fd_cmm = ++ pass_dump_linear_if ppf_dump dump_linear "Linearized code" ++ Profile.record ~accumulate:true "scheduling" Scheduling.fundecl ++ pass_dump_linear_if ppf_dump dump_scheduling "After instruction scheduling" - ++ Profile.record ~accumulate:true "emit" Emit.fundecl + ++ emit_fundecl let compile_phrase ~ppf_dump p = if !dump_cmm then fprintf ppf_dump "%a@." Printcmm.phrase p; match p with | Cfunction fd -> compile_fundecl ~ppf_dump fd - | Cdata dl -> Emit.data dl + | Cdata dl -> emit_data dl (* For the native toplevel: generates generic functions unless @@ -111,8 +122,10 @@ let compile_genfuns ~ppf_dump f = | _ -> ()) (Cmm_helpers.generic_functions true [Compilenv.current_unit_infos ()]) -let compile_unit asm_filename keep_asm obj_filename gen = - let create_asm = keep_asm || not !Emitaux.binary_backend_available in +let compile_unit asm_filename keep_asm + obj_filename gen = + let create_asm = should_emit () && + (keep_asm || not !Emitaux.binary_backend_available) in Emitaux.create_asm_file := create_asm; Misc.try_finally ~exceptionally:(fun () -> remove_file obj_filename) @@ -123,18 +136,20 @@ let compile_unit asm_filename keep_asm obj_filename gen = if create_asm then close_out !Emitaux.output_channel) ~exceptionally:(fun () -> if create_asm && not keep_asm then remove_file asm_filename); - let assemble_result = - Profile.record "assemble" - (Proc.assemble_file asm_filename) obj_filename - in - if assemble_result <> 0 - then raise(Error(Assembler_error asm_filename)); + if should_emit () then begin + let assemble_result = + Profile.record "assemble" + (Proc.assemble_file asm_filename) obj_filename + in + if assemble_result <> 0 + then raise(Error(Assembler_error asm_filename)); + end; if create_asm && not keep_asm then remove_file asm_filename ) let end_gen_implementation ?toplevel ~ppf_dump (clambda : Clambda.with_constants) = - Emit.begin_assembly (); + emit_begin_assembly (); clambda ++ Profile.record "cmm" Cmmgen.compunit ++ Profile.record "compile_phrases" (List.iter (compile_phrase ~ppf_dump)) @@ -151,7 +166,7 @@ let end_gen_implementation ?toplevel ~ppf_dump if not (Primitive.native_name_is_external prim) then None else Some (Primitive.native_name prim)) !Translmod.primitive_declarations)); - Emit.end_assembly () + emit_end_assembly () type middle_end = backend:(module Backend_intf.S) diff --git a/driver/compenv.ml b/driver/compenv.ml index 90f42d8ced..efa27117dd 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -432,17 +432,16 @@ let read_one_param ppf position name v = | "stop-after" -> let module P = Clflags.Compiler_pass in - begin match P.of_string v with + let passes = P.stop_after_pass_names ~native:!native_code in + begin match List.find_opt (String.equal v) passes with | None -> Printf.ksprintf (print_error ppf) "bad value %s for option \"stop-after\" (expected one of: %s)" - v (String.concat ", " P.pass_names) - | Some pass -> + v (String.concat ", " passes) + | Some v -> + let pass = Option.get (P.of_string v) in Clflags.stop_after := Some pass; - begin match pass with - | P.Parsing | P.Typing -> - compile_only := true - end; + compile_only := P.is_compilation_pass pass end | _ -> if not (List.mem name !can_discard) then begin diff --git a/driver/main.ml b/driver/main.ml index adf66644f6..86ccb997e1 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -49,21 +49,24 @@ let main () = end end; readenv ppf Before_link; + let module P = Clflags.Compiler_pass in if List.length (List.filter (fun x -> !x) [make_archive;make_package;compile_only;output_c_object]) > 1 then begin - let module P = Clflags.Compiler_pass in match !stop_after with | None -> fatal "Please specify at most one of -pack, -a, -c, -output-obj"; - | Some (P.Parsing | P.Typing) -> - Printf.ksprintf fatal - "Options -i and -stop-after (%s)\ - are incompatible with -pack, -a, -output-obj" - (String.concat "|" P.pass_names) + | Some ((P.Parsing | P.Typing) as p) -> + assert (P.is_compilation_pass p); + Printf.ksprintf fatal + "Options -i and -stop-after (%s) \ + are incompatible with -pack, -a, -output-obj" + (String.concat "|" + (Clflags.Compiler_pass.stop_after_pass_names ~native:false)) + | Some P.Scheduling -> assert false (* native only *) end; if !make_archive then begin Compmisc.init_path (); diff --git a/driver/main_args.ml b/driver/main_args.ml index 8a6c1b8350..2ec591fad2 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -106,8 +106,9 @@ let mk_function_sections f = "-function-sections", Arg.Unit err, " (option not available)" ;; -let mk_stop_after f = - "-stop-after", Arg.Symbol (Clflags.Compiler_pass.pass_names, f), +let mk_stop_after ~native f = + "-stop-after", + Arg.Symbol (Clflags.Compiler_pass.stop_after_pass_names ~native, f), " Stop after the given compilation pass." ;; @@ -1141,7 +1142,7 @@ struct mk_dtypes F._annot; mk_for_pack_byt F._for_pack; mk_g_byt F._g; - mk_stop_after F._stop_after; + mk_stop_after ~native:false F._stop_after; mk_i F._i; mk_I F._I; mk_impl F._impl; @@ -1316,7 +1317,7 @@ struct mk_for_pack_opt F._for_pack; mk_g_opt F._g; mk_function_sections F._function_sections; - mk_stop_after F._stop_after; + mk_stop_after ~native:true F._stop_after; mk_i F._i; mk_I F._I; mk_impl F._impl; @@ -1840,8 +1841,7 @@ module Default = struct | None -> () (* this should not occur as we use Arg.Symbol *) | Some pass -> stop_after := (Some pass); - match pass with - | P.Parsing | P.Typing -> compile_only := true + compile_only := P.is_compilation_pass pass let _thread = set use_threads let _verbose = set verbose let _version () = print_version_string () diff --git a/driver/optmain.ml b/driver/optmain.ml index f26631d756..3c7d991a83 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -66,13 +66,25 @@ let main () = end end; readenv ppf Before_link; + let module P = Clflags.Compiler_pass in if List.length (List.filter (fun x -> !x) [make_package; make_archive; shared; compile_only; output_c_object]) > 1 then - fatal "Please specify at most one of -pack, -a, -shared, -c, \ + begin + match !stop_after with + | None -> + fatal "Please specify at most one of -pack, -a, -shared, -c, \ -output-obj"; + | Some ((P.Parsing | P.Typing | P.Scheduling) as p) -> + assert (P.is_compilation_pass p); + Printf.ksprintf fatal + "Options -i and -stop-after (%s) \ + are incompatible with -pack, -a, -shared, -output-obj" + (String.concat "|" + (Clflags.Compiler_pass.stop_after_pass_names ~native:true)) + end; if !make_archive then begin Compmisc.init_path (); let target = extract_output !output_name in diff --git a/utils/clflags.ml b/utils/clflags.ml index cc376147f3..c382f94a45 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -420,26 +420,43 @@ module Compiler_pass = struct - the manpages in man/ocaml{c,opt}.m - the manual manual/manual/cmds/unified-options.etex *) - type t = Parsing | Typing + type t = Parsing | Typing | Scheduling let to_string = function | Parsing -> "parsing" | Typing -> "typing" + | Scheduling -> "scheduling" let of_string = function | "parsing" -> Some Parsing | "typing" -> Some Typing + | "scheduling" -> Some Scheduling | _ -> None let rank = function | Parsing -> 0 | Typing -> 1 + | Scheduling -> 50 let passes = [ Parsing; Typing; + Scheduling; ] - let pass_names = List.map to_string passes + let is_compilation_pass _ = true + let is_native_only = function + | Scheduling -> true + | _ -> false + + let enabled is_native t = not (is_native_only t) || is_native + + let pass_names is_native = + passes + |> List.filter (enabled is_native) + |> List.map to_string + + let stop_after_pass_names ~native = + pass_names native end let stop_after = ref None (* -stop-after *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 1743fc1c70..3357bb1877 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -235,11 +235,11 @@ val insn_sched : bool ref val insn_sched_default : bool module Compiler_pass : sig - type t = Parsing | Typing + type t = Parsing | Typing | Scheduling val of_string : string -> t option val to_string : t -> string - val passes : t list - val pass_names : string list + val is_compilation_pass : t -> bool + val stop_after_pass_names : native:bool -> string list end val stop_after : Compiler_pass.t option ref val should_stop_after : Compiler_pass.t -> bool |