Stop before emit

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)

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

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 ();

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 ()

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

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 *)

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