Merge pull request #10575 from Octachron/dump-dir

Add a `-dump-dir` flag

Changes

@@ -285,6 +285,10 @@ OCaml 4.14.0
   (Jacques Garrigue and Takafumi Saikawa,
    review by Thomas Refis and Florian Angeletti)
 
+- #10575: add a -dump-dir flag, which redirects all debugging printer
+   (`-dprofile`, `-dlambda`, ...) to the target directory
+  (Florian Angeletti, review by Thomas Refis and Gabriel Scherer)
+
 * #10627: Make row_field abstract
   Completes #10474 by making row_field abstract too.
   An immutable view row_field_view is provided, and one converts between it

driver/compenv.ml

@@ -474,6 +474,8 @@ let read_one_param ppf position name v =
       | None -> ()
       | Some pass -> set_save_ir_after pass true
     end
+  | "dump-into-file" -> Clflags.dump_into_file := true
+  | "dump-dir" -> Clflags.dump_dir := Some v
 
   | _ ->
     if not (List.mem name !can_discard) then begin

driver/compmisc.ml

@@ -76,16 +76,31 @@ let read_clflags_from_env () =
   set_from_env Clflags.error_style Clflags.error_style_reader;
   ()
 
+let rec make_directory dir =
+  if Sys.file_exists dir then () else
+    begin
+      make_directory (Filename.dirname dir);
+      Sys.mkdir dir 0o777
+    end
+
 let with_ppf_dump ~file_prefix f =
+  let with_ch ch =
+    let ppf = Format.formatter_of_out_channel ch in
+    ppf,
+    (fun () ->
+       Format.pp_print_flush ppf ();
+       close_out ch)
+  in
   let ppf_dump, finally =
-    if not !Clflags.dump_into_file
-    then Format.err_formatter, ignore
-    else
-       let ch = open_out (file_prefix ^ ".dump") in
-       let ppf = Format.formatter_of_out_channel ch in
-       ppf,
-       (fun () ->
-         Format.pp_print_flush ppf ();
-         close_out ch)
+    match !Clflags.dump_dir, !Clflags.dump_into_file with
+    | None, false -> Format.err_formatter, ignore
+    | None, true -> with_ch (open_out (file_prefix ^ ".dump"))
+    | Some d, _ ->
+        let () = make_directory Filename.(dirname @@ concat d @@ file_prefix) in
+        let _, ch =
+          Filename.open_temp_file ~temp_dir:d (file_prefix ^ ".")  ".dump"
+        in
+        with_ch ch
+
   in
   Misc.try_finally (fun () -> f ppf_dump) ~always:finally

driver/main_args.ml

@@ -708,6 +708,11 @@ let mk_dump_into_file f =
   "-dump-into-file", Arg.Unit f, " dump output like -dlambda into <target>.dump"
 ;;
 
+let mk_dump_dir f =
+  "-dump-dir", Arg.String f,
+  "<dir> dump output like -dlambda into <dir>/<target>.dump"
+;;
+
 let mk_dparsetree f =
   "-dparsetree", Arg.Unit f, " (undocumented)"
 ;;
@@ -1012,6 +1017,7 @@ module type Compiler_options = sig
   val _dtimings : unit -> unit
   val _dprofile : unit -> unit
   val _dump_into_file : unit -> unit
+  val _dump_dir : string -> unit
 
   val _args: string -> string array
   val _args0: string -> string array
@@ -1262,6 +1268,7 @@ struct
     mk_dtimings F._dtimings;
     mk_dprofile F._dprofile;
     mk_dump_into_file F._dump_into_file;
+    mk_dump_dir F._dump_dir;
 
     mk_args F._args;
     mk_args0 F._args0;
@@ -1485,6 +1492,7 @@ struct
     mk_dtimings F._dtimings;
     mk_dprofile F._dprofile;
     mk_dump_into_file F._dump_into_file;
+    mk_dump_dir F._dump_dir;
     mk_dump_pass F._dump_pass;
 
     mk_args F._args;
@@ -1866,6 +1874,7 @@ module Default = struct
     let _dprofile () = profile_columns := Profile.all_columns
     let _dtimings () = profile_columns := [`Time]
     let _dump_into_file = set dump_into_file
+    let _dump_dir s = dump_dir := Some s
     let _for_pack s = for_package := (Some s)
     let _g = set debug
     let _i = set print_types

driver/main_args.mli

@@ -121,6 +121,7 @@ module type Compiler_options = sig
   val _dtimings : unit -> unit
   val _dprofile : unit -> unit
   val _dump_into_file : unit -> unit
+  val _dump_dir : string -> unit
 
   val _args: string -> string array
   val _args0: string -> string array

driver/maindriver.ml

@@ -110,5 +110,6 @@ let main argv ppf =
     Location.report_exception ppf x;
     2
   | () ->
-    Profile.print Format.std_formatter !Clflags.profile_columns;
+    Compmisc.with_ppf_dump ~file_prefix:"profile"
+      (fun ppf -> Profile.print ppf !Clflags.profile_columns);
     0

driver/optmaindriver.ml

@@ -136,5 +136,6 @@ let main argv ppf =
     Location.report_exception ppf x;
     2
   | () ->
-    Profile.print Format.std_formatter !Clflags.profile_columns;
-    0
+      Compmisc.with_ppf_dump ~file_prefix:"profile"
+        (fun ppf -> Profile.print ppf !Clflags.profile_columns);
+      0

utils/clflags.ml

@@ -375,6 +375,7 @@ let set_dumped_pass s enabled =
   end
 
 let dump_into_file = ref false (* -dump-into-file *)
+let dump_dir: string option ref = ref None (* -dump-dir *)
 
 type 'a env_reader = {
   parse : string -> 'a option;

utils/clflags.mli

@@ -218,6 +218,7 @@ val dumped_pass : string -> bool
 val set_dumped_pass : string -> bool -> unit
 
 val dump_into_file : bool ref
+val dump_dir : string option ref
 
 (* Support for flags that can also be set from an environment variable *)
 type 'a env_reader = {