ability to restart compilation from .cmir-linear IR files

.depend

@@ -5721,7 +5721,8 @@ driver/compenv.cmx : \
     utils/clflags.cmx \
     utils/ccomp.cmx \
     driver/compenv.cmi
-driver/compenv.cmi :
+driver/compenv.cmi : \
+    utils/clflags.cmi
 driver/compile.cmo : \
     lambda/translmod.cmi \
     lambda/simplif.cmi \
@@ -5752,7 +5753,8 @@ driver/compile.cmi : \
     typing/typedtree.cmi \
     bytecomp/instruct.cmi \
     typing/ident.cmi \
-    driver/compile_common.cmi
+    driver/compile_common.cmi \
+    utils/clflags.cmi
 driver/compile_common.cmo : \
     utils/warnings.cmi \
     typing/typemod.cmi \
@@ -5945,6 +5947,7 @@ driver/optcompile.cmx : \
 driver/optcompile.cmi : \
     typing/typedtree.cmi \
     driver/compile_common.cmi \
+    utils/clflags.cmi \
     middle_end/backend_intf.cmi
 driver/opterrors.cmo : \
     parsing/location.cmi \

Changes

@@ -460,6 +460,9 @@ Working version
 - #8939: Command-line option to save Linear IR before emit.
   (Greta Yorsh, review by Mark Shinwell, Sébastien Hinderer and Frédéric Bour)
 
+- #9003: Start compilation from Emit when the input file is in Linear IR format.
+  (Greta Yorsh, review by Jérémie Dimino, Gabriel Scherer and Frédéric Bour)
+
 ### Build system:
 
 - #7121, #9558: Always the autoconf-discovered ld in PACKLD. For

asmcomp/asmgen.ml

@@ -23,7 +23,9 @@ open Clflags
 open Misc
 open Cmm
 
-type error = Assembler_error of string
+type error =
+  | Assembler_error of string
+  | Mismatched_for_pack of string option
 
 exception Error of error
 
@@ -39,18 +41,23 @@ let pass_dump_linear_if ppf flag message phrase =
   if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase;
   phrase
 
+let start_from_emit = ref true
+
 let should_save_before_emit () =
-  should_save_ir_after Compiler_pass.Scheduling
+  should_save_ir_after Compiler_pass.Scheduling && (not !start_from_emit)
 
 let linear_unit_info =
   { Linear_format.unit_name = "";
     items = [];
+    for_pack = None;
   }
 
 let reset () =
+  start_from_emit := false;
   if should_save_before_emit () then begin
     linear_unit_info.unit_name <- Compilenv.current_unit_name ();
     linear_unit_info.items <- [];
+    linear_unit_info.for_pack <- !Clflags.for_package;
   end
 
 let save_data dl =
@@ -65,9 +72,9 @@ let save_linear f =
   end;
   f
 
-let write_linear output_prefix =
+let write_linear prefix =
   if should_save_before_emit () then begin
-    let filename = output_prefix ^ Clflags.Compiler_ir.(extension Linear) in
+    let filename = Compiler_pass.(to_output_filename Scheduling ~prefix) in
     linear_unit_info.items <- List.rev linear_unit_info.items;
     Linear_format.save filename linear_unit_info
   end
@@ -218,14 +225,15 @@ type middle_end =
   -> Lambda.program
   -> Clambda.with_constants
 
-let compile_implementation ?toplevel ~backend ~filename ~prefixname ~middle_end
-      ~ppf_dump (program : Lambda.program) =
-  let asm_filename =
+let asm_filename output_prefix =
     if !keep_asm_file || !Emitaux.binary_backend_available
-    then prefixname ^ ext_asm
+    then output_prefix ^ ext_asm
     else Filename.temp_file "camlasm" ext_asm
-  in
-  compile_unit ~output_prefix:prefixname ~asm_filename ~keep_asm:!keep_asm_file
+
+let compile_implementation ?toplevel ~backend ~filename ~prefixname ~middle_end
+      ~ppf_dump (program : Lambda.program) =
+  compile_unit ~output_prefix:prefixname
+    ~asm_filename:(asm_filename prefixname) ~keep_asm:!keep_asm_file
     ~obj_filename:(prefixname ^ ext_obj)
     (fun () ->
       Ident.Set.iter Compilenv.require_global program.required_globals;
@@ -234,12 +242,43 @@ let compile_implementation ?toplevel ~backend ~filename ~prefixname ~middle_end
       in
       end_gen_implementation ?toplevel ~ppf_dump clambda_with_constants)
 
+let linear_gen_implementation filename =
+  let open Linear_format in
+  let linear_unit_info, _ = restore filename in
+  (match !Clflags.for_package, linear_unit_info.for_pack with
+   | None, None -> ()
+   | Some expected, Some saved when String.equal expected saved -> ()
+   | _, saved -> raise(Error(Mismatched_for_pack saved)));
+  let emit_item = function
+    | Data dl -> emit_data dl
+    | Func f -> emit_fundecl f
+  in
+  start_from_emit := true;
+  emit_begin_assembly ();
+  Profile.record "Emit" (List.iter emit_item) linear_unit_info.items;
+  emit_end_assembly ()
+
+let compile_implementation_linear output_prefix ~progname =
+  compile_unit ~output_prefix
+    ~asm_filename:(asm_filename output_prefix) ~keep_asm:!keep_asm_file
+    ~obj_filename:(output_prefix ^ ext_obj)
+    (fun () ->
+      linear_gen_implementation progname)
+
 (* Error report *)
 
 let report_error ppf = function
   | Assembler_error file ->
       fprintf ppf "Assembler error, input left in file %a"
         Location.print_filename file
+  | Mismatched_for_pack saved ->
+    let msg = function
+       | None -> "without -for-pack"
+       | Some s -> "with -for-pack "^s
+     in
+     fprintf ppf
+       "This input file cannot be compiled %s: it was generated %s."
+       (msg !Clflags.for_package) (msg saved)
 
 let () =
   Location.register_error_of_exn

asmcomp/asmgen.mli

@@ -35,10 +35,16 @@ val compile_implementation
   -> Lambda.program
   -> unit
 
+val compile_implementation_linear :
+    string -> progname:string -> unit
+
 val compile_phrase :
     ppf_dump:Format.formatter -> Cmm.phrase -> unit
 
-type error = Assembler_error of string
+type error =
+  | Assembler_error of string
+  | Mismatched_for_pack of string option
+
 exception Error of error
 val report_error: Format.formatter -> error -> unit
 

driver/compenv.ml

@@ -193,6 +193,30 @@ let check_bool ppf name s =
       "bad value %s for %s" s name;
     false
 
+let decode_compiler_pass ppf v ~name ~filter =
+  let module P = Clflags.Compiler_pass in
+  let passes = P.available_pass_names ~filter ~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 \"%s\" (expected one of: %s)"
+      v name (String.concat ", " passes);
+    None
+  | Some v -> P.of_string v
+  end
+
+let set_compiler_pass ppf ~name v flag ~filter =
+  match decode_compiler_pass ppf v ~name ~filter with
+  | None -> ()
+  | Some pass ->
+    match !flag with
+    | None -> flag := Some pass
+    | Some p ->
+      if not (p = pass) then begin
+        Printf.ksprintf (print_error ppf)
+          "Please specify at most one %s <pass>." name
+      end
+
 (* 'can-discard=' specifies which arguments can be discarded without warning
    because they are not understood by some versions of OCaml. *)
 let can_discard = ref []
@@ -436,35 +460,14 @@ let read_one_param ppf position name v =
      profile_columns := if check_bool ppf name v then if_on else []
 
   | "stop-after" ->
-    let module P = Clflags.Compiler_pass in
-    let passes = P.available_pass_names
-                   ~filter:(fun _ -> true)
-                   ~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 ", " passes)
-    | Some v ->
-        let pass = Option.get (P.of_string v)  in
-        Clflags.stop_after := Some pass
-    end
+    set_compiler_pass ppf v ~name Clflags.stop_after ~filter:(fun _ -> true)
 
   | "save-ir-after" ->
     if !native_code then begin
-      let module P = Clflags.Compiler_pass in
-      let passes = P.available_pass_names
-                     ~filter:P.can_save_ir_after
-                     ~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 \"save-ir-after\" (expected one of: %s)"
-            v (String.concat ", " passes)
-      | Some v ->
-          let pass = Option.get (P.of_string v)  in
-          set_save_ir_after pass true
-      end
+      let filter = Clflags.Compiler_pass.can_save_ir_after in
+      match decode_compiler_pass ppf v ~name ~filter with
+      | None -> ()
+      | Some pass -> set_save_ir_after pass true
     end
 
   | _ ->
@@ -475,6 +478,7 @@ let read_one_param ppf position name v =
         name
     end
 
+
 let read_OCAMLPARAM ppf position =
   try
     let s = Sys.getenv "OCAMLPARAM" in
@@ -614,12 +618,15 @@ let c_object_of_filename name =
 
 let process_action
     (ppf, implementation, interface, ocaml_mod_ext, ocaml_lib_ext) action =
+  let impl ~start_from name =
+    readenv ppf (Before_compile name);
+    let opref = output_prefix name in
+    implementation ~start_from ~source_file:name ~output_prefix:opref;
+    objfiles := (opref ^ ocaml_mod_ext) :: !objfiles
+  in
   match action with
   | ProcessImplementation name ->
-      readenv ppf (Before_compile name);
-      let opref = output_prefix name in
-      implementation ~source_file:name ~output_prefix:opref;
-      objfiles := (opref ^ ocaml_mod_ext) :: !objfiles
+      impl ~start_from:Compiler_pass.Parsing name
   | ProcessInterface name ->
       readenv ppf (Before_compile name);
       let opref = output_prefix name in
@@ -646,7 +653,11 @@ let process_action
       else if not !native_code && Filename.check_suffix name Config.ext_dll then
         dllibs := name :: !dllibs
       else
-        raise(Arg.Bad("don't know what to do with " ^ name))
+        match Compiler_pass.of_input_filename name with
+        | Some start_from ->
+          Location.input_name := name;
+          impl ~start_from name
+        | None -> raise(Arg.Bad("don't know what to do with " ^ name))
 
 
 let action_of_file name =

driver/compenv.mli

@@ -71,7 +71,8 @@ val intf : string -> unit
 
 val process_deferred_actions :
   Format.formatter *
-  (source_file:string -> output_prefix:string -> unit) *
+  (start_from:Clflags.Compiler_pass.t ->
+   source_file:string -> output_prefix:string -> unit) *
   (* compile implementation *)
   (source_file:string -> output_prefix:string -> unit) *
   (* compile interface *)

driver/compile.ml

@@ -54,10 +54,13 @@ let emit_bytecode i (bytecode, required_globals) =
          (Emitcode.to_file oc i.module_name cmofile ~required_globals);
     )
 
-let implementation ~source_file ~output_prefix =
+let implementation ~start_from ~source_file ~output_prefix =
   let backend info typed =
     let bytecode = to_bytecode info typed in
     emit_bytecode info bytecode
   in
   with_info ~source_file ~output_prefix ~dump_ext:"cmo" @@ fun info ->
-  Compile_common.implementation info ~backend
+  match (start_from : Clflags.Compiler_pass.t) with
+  | Parsing -> Compile_common.implementation info ~backend
+  | _ -> Misc.fatal_errorf "Cannot start from %s"
+           (Clflags.Compiler_pass.to_string start_from)

driver/compile.mli

@@ -18,6 +18,7 @@
 val interface:
   source_file:string -> output_prefix:string -> unit
 val implementation:
+  start_from:Clflags.Compiler_pass.t ->
   source_file:string -> output_prefix:string -> unit
 
 (** {2 Internal functions} **)

driver/maindriver.ml

@@ -63,7 +63,7 @@ let main argv ppf =
            are  incompatible with -pack, -a, -output-obj"
           (String.concat "|"
              (P.available_pass_names ~filter:(fun _ -> true) ~native:false))
-      | Some P.Scheduling -> assert false (* native only *)
+      | Some (P.Scheduling | P.Emit) -> assert false (* native only *)
     end;
     if !make_archive then begin
       Compmisc.init_path ();

driver/optcompile.ml

@@ -85,12 +85,21 @@ let clambda i backend typed =
             ~ppf_dump:i.ppf_dump;
        Compilenv.save_unit_info (cmx i))
 
-let implementation ~backend ~source_file ~output_prefix =
+(* Emit assembly directly from Linear IR *)
+let emit i =
+  Compilenv.reset ?packname:!Clflags.for_package i.module_name;
+  Asmgen.compile_implementation_linear i.output_prefix ~progname:i.source_file
+
+let implementation ~backend ~start_from ~source_file ~output_prefix =
   let backend info typed =
     Compilenv.reset ?packname:!Clflags.for_package info.module_name;
     if Config.flambda
     then flambda info backend typed
     else clambda info backend typed
   in
   with_info ~source_file ~output_prefix ~dump_ext:"cmx" @@ fun info ->
-  Compile_common.implementation info ~backend
+  match (start_from:Clflags.Compiler_pass.t) with
+  | Parsing -> Compile_common.implementation info ~backend
+  | Emit -> emit info
+  | _ -> Misc.fatal_errorf "Cannot start from %s"
+           (Clflags.Compiler_pass.to_string start_from)

driver/optcompile.mli

@@ -19,6 +19,7 @@ val interface: source_file:string -> output_prefix:string -> unit
 
 val implementation:
    backend:(module Backend_intf.S)
+   -> start_from:Clflags.Compiler_pass.t
    -> source_file:string -> output_prefix:string -> unit
 
 (** {2 Internal functions} **)

driver/optmaindriver.ml

@@ -75,7 +75,7 @@ let main argv ppf =
       | None ->
           Compenv.fatal "Please specify at most one of -pack, -a, -shared, -c, \
                          -output-obj";
-      | Some ((P.Parsing | P.Typing | P.Scheduling) as p) ->
+      | Some ((P.Parsing | P.Typing | P.Scheduling | P.Emit) as p) ->
         assert (P.is_compilation_pass p);
         Printf.ksprintf Compenv.fatal
           "Options -i and -stop-after (%s) \

file_formats/linear_format.ml

@@ -24,6 +24,7 @@ type linear_unit_info =
   {
     mutable unit_name : string;
     mutable items : linear_item_info list;
+    mutable for_pack : string option
   }
 
 type error =

file_formats/linear_format.mli

@@ -27,6 +27,7 @@ type linear_unit_info =
   {
     mutable unit_name : string;
     mutable items : linear_item_info list;
+    mutable for_pack : string option
   }
 
 (* Marshal and unmarshal a compilation unit in Linear format.

testsuite/tests/tool-ocamlopt-save-ir/check_for_pack.compilers.reference

@@ -0,0 +1,2 @@
+File "check_for_pack.cmir-linear", line 1:
+Error: This input file cannot be compiled with -for-pack foo: it was generated without -for-pack.