Save cfg to file (ocaml-flambda#257)

backend/asmgen.ml

@@ -61,24 +61,41 @@ let start_from_emit = ref true
 let should_save_before_emit () =
   should_save_ir_after Compiler_pass.Scheduling && (not !start_from_emit)
 
+let should_save_cfg_before_emit () =
+  should_save_ir_after Compiler_pass.Simplify_cfg && (not !start_from_emit)
+
 let linear_unit_info =
   { Linear_format.unit_name = "";
     items = [];
     for_pack = None;
   }
 
+let cfg_unit_info =
+  { Cfg_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;
+  if should_save_cfg_before_emit () then begin
+    cfg_unit_info.unit_name <- Compilenv.current_unit_name ();
+    cfg_unit_info.items <- [];
+    cfg_unit_info.for_pack <- !Clflags.for_package;
   end
 
 let save_data dl =
   if should_save_before_emit () then begin
     linear_unit_info.items <- Linear_format.(Data dl) :: linear_unit_info.items
   end;
+  if should_save_cfg_before_emit () then begin
+    cfg_unit_info.items <- Cfg_format.(Data dl) :: cfg_unit_info.items
+  end;
   dl
 
 let save_linear f =
@@ -87,11 +104,22 @@ let save_linear f =
   end;
   f
 
-let write_linear prefix =
+let save_cfg f =
+  if should_save_cfg_before_emit () then begin
+    cfg_unit_info.items <- Cfg_format.(Cfg f) :: cfg_unit_info.items
+  end;
+  f
+
+let write_ir prefix =
   if should_save_before_emit () then begin
     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;
+  if should_save_cfg_before_emit () then begin
+    let filename = Compiler_pass.(to_output_filename Simplify_cfg ~prefix) in
+    cfg_unit_info.items <- List.rev cfg_unit_info.items;
+    Cfg_format.save filename cfg_unit_info
   end
 
 let should_emit () =
@@ -195,6 +223,7 @@ let compile_fundecl ~ppf_dump fd_cmm =
       ++ Profile.record ~accumulate:true "linear_to_cfg"
            (Linear_to_cfg.run ~preserve_orig_labels:true)
       ++ pass_dump_cfg_if ppf_dump dump_cfg "After linear_to_cfg"
+      ++ save_cfg
       ++ Profile.record ~accumulate:true "cfg_to_linear" Cfg_to_linear.run
       ++ pass_dump_linear_if ppf_dump dump_linear "After cfg_to_linear"
     end else
@@ -238,7 +267,7 @@ let compile_unit ~output_prefix ~asm_filename ~keep_asm ~obj_filename gen =
        Misc.try_finally
          (fun () ->
             gen ();
-            write_linear output_prefix)
+            write_ir output_prefix)
          ~always:(fun () ->
              if create_asm then close_out !Emitaux.output_channel)
          ~exceptionally:(fun () ->

driver/optmaindriver.ml

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

dune

@@ -34,6 +34,8 @@
 
 (copy_files# file_formats/linear_format.ml{,i})
 
+(copy_files# file_formats/cfg_format.ml{,i})
+
 (copy_files# middle_end/*.ml{,i})
 
 (copy_files# middle_end/closure/*.ml{,i})
@@ -221,6 +223,7 @@
   cfg_equivalence
   ;; file_formats/
   linear_format
+  cfg_format
   ;; asmcomp/debug/
   reg_availability_set
   compute_ranges_intf
@@ -507,6 +510,7 @@
   (x86_proc.mli as compiler-libs/x86_proc.mli)
   (x86_binary_emitter.mli as compiler-libs/x86_binary_emitter.mli)
   (linear_format.mli as compiler-libs/linear_format.mli)
+  (cfg_format.mli as compiler-libs/cfg_format.mli)
   (reg_availability_set.mli as compiler-libs/reg_availability_set.mli)
   (available_regs.mli as compiler-libs/available_regs.mli)
   (reg_with_debug_info.mli as compiler-libs/reg_with_debug_info.mli)
@@ -545,9 +549,10 @@
   (.ocamloptcomp.objs/byte/linear_format.cmti
    as
    compiler-libs/linear_format.cmti)
-  (.ocamloptcomp.objs/native/linear_format.cmx
-   as
-   compiler-libs/linear_format.cmx)
+  (.ocamloptcomp.objs/byte/cfg_format.cmi as compiler-libs/cfg_format.cmi)
+  (.ocamloptcomp.objs/byte/cfg_format.cmo as compiler-libs/cfg_format.cmo)
+  (.ocamloptcomp.objs/byte/cfg_format.cmt as compiler-libs/cfg_format.cmt)
+  (.ocamloptcomp.objs/byte/cfg_format.cmti as compiler-libs/cfg_format.cmti)
   (.ocamloptcomp.objs/byte/afl_instrument.cmi
    as
    compiler-libs/afl_instrument.cmi)
@@ -2179,4 +2184,8 @@
   (.ocamloptcomp.objs/native/var_within_closure.cmx
    as
    compiler-libs/var_within_closure.cmx)
-  (.ocamloptcomp.objs/native/variable.cmx as compiler-libs/variable.cmx)))
+  (.ocamloptcomp.objs/native/variable.cmx as compiler-libs/variable.cmx)
+  (.ocamloptcomp.objs/native/linear_format.cmx
+   as
+   compiler-libs/linear_format.cmx)
+  (.ocamloptcomp.objs/native/cfg_format.cmx as compiler-libs/cfg_format.cmx)))

file_formats/cfg_format.ml

@@ -0,0 +1,101 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                    Greta Yorsh, Jane Street Europe                     *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Marshal and unmarshal a compilation unit in Cfg format *)
+type cfg_item_info =
+  | Cfg of Cfg_with_layout.t
+  | Data of Cmm.data_item list
+
+type cfg_unit_info =
+  {
+    mutable unit_name : string;
+    mutable items : cfg_item_info list;
+    mutable for_pack : string option
+  }
+
+type error =
+  | Wrong_format of string
+  | Wrong_version of string
+  | Corrupted of string
+  | Marshal_failed of string
+
+exception Error of error
+
+let save filename cfg_unit_info =
+  let ch = open_out_bin filename in
+  Misc.try_finally (fun () ->
+    output_string ch Config.cfg_magic_number;
+    output_value ch cfg_unit_info;
+    (* Saved because Emit depends on Cmm.label. *)
+    output_value ch (Cmm.cur_label ());
+    (* Compute digest of the contents and append it to the file. *)
+    flush ch;
+    let crc = Digest.file filename in
+    Digest.output ch crc
+  )
+    ~always:(fun () -> close_out ch)
+    ~exceptionally:(fun () -> raise (Error (Marshal_failed filename)))
+
+let restore filename =
+  let ic = open_in_bin filename in
+  Misc.try_finally
+    (fun () ->
+       let magic = Config.cfg_magic_number in
+       let buffer = really_input_string ic (String.length magic) in
+       if String.equal buffer magic then begin
+         try
+           let cfg_unit_info = (input_value ic : cfg_unit_info) in
+           let last_label = (input_value ic : Cmm.label) in
+           Cmm.reset ();
+           Cmm.set_label last_label;
+           let crc = Digest.input ic in
+           cfg_unit_info, crc
+         with End_of_file | Failure _ -> raise (Error (Corrupted filename))
+            | Error e -> raise (Error e)
+       end
+       else if String.sub buffer 0 9 = String.sub magic 0 9 then
+         raise (Error (Wrong_version filename))
+       else
+         raise (Error (Wrong_format filename))
+    )
+    ~always:(fun () -> close_in ic)
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Wrong_format filename ->
+      fprintf ppf "Expected Cfg format. Incompatible file %a"
+        Location.print_filename filename
+  | Wrong_version filename ->
+      fprintf ppf
+        "%a@ is not compatible with this version of OCaml"
+        Location.print_filename filename
+  | Corrupted filename ->
+      fprintf ppf "Corrupted format@ %a"
+        Location.print_filename filename
+  | Marshal_failed filename ->
+      fprintf ppf "Failed to marshal Cfg to file@ %a"
+        Location.print_filename filename
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )

file_formats/cfg_format.mli

@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                    Greta Yorsh, Jane Street Europe                     *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Format of .cmir-cfg files *)
+
+(* Compiler can optionally save Cfg representation of a compilation unit,
+   along with other information required to emit assembly. *)
+type cfg_item_info =
+  | Cfg of Cfg_with_layout.t
+  | Data of Cmm.data_item list
+
+type cfg_unit_info =
+  {
+    mutable unit_name : string;
+    mutable items : cfg_item_info list;
+    mutable for_pack : string option
+  }
+
+(* Marshal and unmarshal a compilation unit in Cfg format.
+   It includes saving and restoring global state required for Emit,
+   that currently consists of Cmm.label_counter.
+*)
+val save : string -> cfg_unit_info -> unit
+val restore : string -> cfg_unit_info * Digest.t

file_formats/linear_format.ml

@@ -45,7 +45,7 @@ let save filename linear_unit_info =
     (* Compute digest of the contents and append it to the file. *)
     flush ch;
     let crc = Digest.file filename in
-    output_value ch crc
+    Digest.output ch crc
   )
     ~always:(fun () -> close_out ch)
     ~exceptionally:(fun () -> raise (Error (Marshal_failed filename)))
@@ -62,7 +62,7 @@ let restore filename =
            let last_label = (input_value ic : Cmm.label) in
            Cmm.reset ();
            Cmm.set_label last_label;
-           let crc = (input_value ic : Digest.t) in
+           let crc = Digest.input ic in
            linear_unit_info, crc
          with End_of_file | Failure _ -> raise (Error (Corrupted filename))
             | Error e -> raise (Error e)

ocaml/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 | P.Emit) -> assert false (* native only *)
+      | Some (P.Scheduling | P.Simplify_cfg | P.Emit) -> assert false (* native only *)
     end;
     if !make_archive then begin
       Compmisc.init_path ();

ocaml/driver/optmaindriver.ml

@@ -75,7 +75,8 @@ 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 | P.Emit) as p) ->
+      | Some ((P.Parsing | P.Typing | P.Scheduling
+              | P.Simplify_cfg | P.Emit) as p) ->
         assert (P.is_compilation_pass p);
         Printf.ksprintf Compenv.fatal
           "Options -i and -stop-after (%s) \

ocaml/testsuite/tests/tool-ocamlopt-save-ir/save_ir_after_typing.compilers.reference

@@ -1 +1 @@
-wrong argument 'typing'; option '-save-ir-after' expects one of: scheduling.
+wrong argument 'typing'; option '-save-ir-after' expects one of: scheduling simplify_cfg.