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 asm_filename output_prefix =
+    if !keep_asm_file || !Emitaux.binary_backend_available
+    then output_prefix ^ ext_asm
+    else Filename.temp_file "camlasm" ext_asm
+
 let compile_implementation ?toplevel ~backend ~filename ~prefixname ~middle_end
       ~ppf_dump (program : Lambda.program) =
-  let asm_filename =
+  compile_unit ~output_prefix:prefixname
-    if !keep_asm_file || !Emitaux.binary_backend_available
+    ~asm_filename:(asm_filename prefixname) ~keep_asm:!keep_asm_file
-    then prefixname ^ ext_asm
-    else Filename.temp_file "camlasm" ext_asm
-  in
-  compile_unit ~output_prefix:prefixname ~asm_filename ~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
+    set_compiler_pass ppf v ~name Clflags.stop_after ~filter:(fun _ -> true)
-    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
 
   | "save-ir-after" ->
     if !native_code then begin
-      let module P = Clflags.Compiler_pass in
+      let filter = Clflags.Compiler_pass.can_save_ir_after in
-      let passes = P.available_pass_names
+      match decode_compiler_pass ppf v ~name ~filter with
-                     ~filter:P.can_save_ir_after
+      | None -> ()
-                     ~native:!native_code in
+      | Some pass -> set_save_ir_after pass true
-      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
     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);
+      impl ~start_from:Compiler_pass.Parsing name
-      let opref = output_prefix name in
-      implementation ~source_file:name ~output_prefix:opref;
-      objfiles := (opref ^ ocaml_mod_ext) :: !objfiles
   | 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,7 +85,12 @@ 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
@@ -93,4 +98,8 @@ let implementation ~backend ~source_file ~output_prefix =
     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.

testsuite/tests/tool-ocamlopt-save-ir/check_for_pack.ml

@@ -0,0 +1,19 @@
+(* TEST
+ * native-compiler
+ ** setup-ocamlopt.byte-build-env
+ *** ocamlopt.byte
+   flags = "-save-ir-after scheduling"
+   ocamlopt_byte_exit_status = "0"
+ **** script
+   script = "touch empty.ml"
+ ***** ocamlopt.byte
+   flags = "-S check_for_pack.cmir-linear -for-pack foo"
+   module = "empty.ml"
+   ocamlopt_byte_exit_status = "2"
+ ****** check-ocamlopt.byte-output
+*)
+
+let foo f x =
+  if x > 0 then x * 7 else f x
+
+let bar x y = x + y

testsuite/tests/tool-ocamlopt-save-ir/start_from_emit.ml

@@ -0,0 +1,31 @@
+(* TEST
+ * native-compiler
+ ** setup-ocamlopt.byte-build-env
+ *** ocamlopt.byte
+   flags = "-save-ir-after scheduling -stop-after scheduling"
+   ocamlopt_byte_exit_status = "0"
+ **** script
+   script = "touch empty.ml"
+ ***** ocamlopt.byte
+   flags = "-S start_from_emit.cmir-linear"
+   module = "empty.ml"
+   ocamlopt_byte_exit_status = "0"
+ ****** check-ocamlopt.byte-output
+ ******* script
+   script = "sh ${test_source_directory}/start_from_emit.sh"
+ ******** ocamlopt.byte
+   flags = "-S start_from_emit.cmir-linear -save-ir-after scheduling"
+   module = "empty.ml"
+   ocamlopt_byte_exit_status = "0"
+ ********* script
+  script = "cp start_from_emit.cmir-linear expected.cmir_linear"
+ ********** check-ocamlopt.byte-output
+ *********** script
+   script = "cmp start_from_emit.cmir-linear expected.cmir_linear"
+
+*)
+
+let foo f x =
+  if x > 0 then x * 7 else f x
+
+let bar x y = x + y

testsuite/tests/tool-ocamlopt-save-ir/start_from_emit.sh

@@ -0,0 +1,14 @@
+#!/bin/sh
+
+set -e
+
+obj=start_from_emit.${objext}
+
+# Check that obj is generated
+if [ -e "$obj" ] ; then
+    test_result=${TEST_PASS}
+else
+    echo "not found $obj" > ${ocamltest_response}
+    test_result=${TEST_FAIL}
+fi
+exit ${test_result}

utils/clflags.ml

@@ -417,21 +417,43 @@ let unboxed_types = ref false
 (* This is used by the -save-ir-after option. *)
 module Compiler_ir = struct
   type t = Linear
-  let extension t =
-    let ext =
-    match t with
-    | Linear -> "linear"
-    in
-    ".cmir-" ^ ext
-
-  let magic t =
-    let open Config in
-    match t with
-    | Linear -> linear_magic_number
 
   let all = [
     Linear;
   ]
+
+  let extension t =
+    let ext =
+    match t with
+      | Linear -> "linear"
+    in
+    ".cmir-" ^ ext
+
+  (** [extract_extension_with_pass filename] returns the IR whose extension
+      is a prefix of the extension of [filename], and the suffix,
+      which can be used to distinguish different passes on the same IR.
+      For example, [extract_extension_with_pass "foo.cmir-linear123"]
+      returns [Some (Linear, "123")]. *)
+  let extract_extension_with_pass filename =
+    let ext = Filename.extension filename in
+    let ext_len = String.length ext in
+    if ext_len <= 0 then None
+    else begin
+      let is_prefix ir =
+        let s = extension ir in
+        let s_len = String.length s in
+        s_len <= ext_len && s = String.sub ext 0 s_len
+      in
+      let drop_prefix ir =
+        let s = extension ir in
+        let s_len = String.length s in
+        String.sub ext s_len (ext_len - s_len)
+      in
+      let ir = List.find_opt is_prefix all in
+      match ir with
+      | None -> None
+      | Some ir -> Some (ir, drop_prefix ir)
+    end
 end
 
 (* This is used by the -stop-after option. *)
@@ -441,32 +463,37 @@ module Compiler_pass = struct
      - the manpages in man/ocaml{c,opt}.m
      - the manual manual/manual/cmds/unified-options.etex
   *)
-  type t = Parsing | Typing | Scheduling
+  type t = Parsing | Typing | Scheduling | Emit
 
   let to_string = function
     | Parsing -> "parsing"
     | Typing -> "typing"
     | Scheduling -> "scheduling"
+    | Emit -> "emit"
 
   let of_string = function
     | "parsing" -> Some Parsing
     | "typing" -> Some Typing
     | "scheduling" -> Some Scheduling
+    | "emit" -> Some Emit
     | _ -> None
 
   let rank = function
     | Parsing -> 0
     | Typing -> 1
     | Scheduling -> 50
+    | Emit -> 60
 
   let passes = [
     Parsing;
     Typing;
     Scheduling;
+    Emit;
   ]
   let is_compilation_pass _ = true
   let is_native_only = function
     | Scheduling -> true
+    | Emit -> true
     | _ -> false
 
   let enabled is_native t = not (is_native_only t) || is_native
@@ -479,6 +506,19 @@ module Compiler_pass = struct
     |> List.filter (enabled native)
     |> List.filter filter
     |> List.map to_string
+
+  let compare a b =
+    compare (rank a) (rank b)
+
+  let to_output_filename t ~prefix =
+    match t with
+    | Scheduling -> prefix ^ Compiler_ir.(extension Linear)
+    | _ -> Misc.fatal_error "Not supported"
+
+  let of_input_filename name =
+    match Compiler_ir.extract_extension_with_pass name with
+    | Some (Linear, _) -> Some Emit
+    | None -> None
 end
 
 let stop_after = ref None (* -stop-after *)

utils/clflags.mli

@@ -235,20 +235,16 @@ val unboxed_types : bool ref
 val insn_sched : bool ref
 val insn_sched_default : bool
 
-module Compiler_ir : sig
-  type t = Linear
-  val extension : t -> string
-  val magic : t -> string
-  val all : t list
-end
-
 module Compiler_pass : sig
-  type t = Parsing | Typing | Scheduling
+  type t = Parsing | Typing | Scheduling | Emit
   val of_string : string -> t option
   val to_string : t -> string
   val is_compilation_pass : t -> bool
   val available_pass_names : filter:(t -> bool) -> native:bool -> string list
   val can_save_ir_after : t -> bool
+  val compare : t -> t -> int
+  val to_output_filename: t -> prefix:string -> string
+  val of_input_filename: string -> t option
 end
 val stop_after : Compiler_pass.t option ref
 val should_stop_after : Compiler_pass.t -> bool