Add option to dump the output of e.g. -dlambda in a file

Changes

@@ -108,6 +108,10 @@ Working version
   returns a syntax tree, to replace the print that was there already
   (Valentin Gatien-Baron)
 
+- GPR#1913: new flag -dump-into-file to print debug output like -dlambda into
+  a file named after the file being built, instead of on stderr.
+  (Valentin Gatien-Baron, review by Thomas Refis)
+
 - GPR#1921: in the compilation context passed to ppx extensions,
   add more configuration options related to type-checking:
   -rectypes, -principal, -alias-deps, -unboxed-types, -unsafe-string

asmcomp/asmgen.ml

@@ -74,73 +74,73 @@ let raw_clambda_dump_if ppf
     end;
   if !dump_cmm then Format.fprintf ppf "@.cmm:@."
 
-let rec regalloc ppf round fd =
+let rec regalloc ~ppf_dump round fd =
   if round > 50 then
     fatal_error(fd.Mach.fun_name ^
                 ": function too complex, cannot complete register allocation");
-  dump_if ppf dump_live "Liveness analysis" fd;
+  dump_if ppf_dump dump_live "Liveness analysis" fd;
   if !use_linscan then begin
     (* Linear Scan *)
     Interval.build_intervals fd;
-    if !dump_interval then Printmach.intervals ppf ();
+    if !dump_interval then Printmach.intervals ppf_dump ();
     Linscan.allocate_registers()
   end else begin
     (* Graph Coloring *)
     Interf.build_graph fd;
-    if !dump_interf then Printmach.interferences ppf ();
-    if !dump_prefer then Printmach.preferences ppf ();
+    if !dump_interf then Printmach.interferences ppf_dump ();
+    if !dump_prefer then Printmach.preferences ppf_dump ();
     Coloring.allocate_registers()
   end;
-  dump_if ppf dump_regalloc "After register allocation" fd;
+  dump_if ppf_dump dump_regalloc "After register allocation" fd;
   let (newfd, redo_regalloc) = Reload.fundecl fd in
-  dump_if ppf dump_reload "After insertion of reloading code" newfd;
+  dump_if ppf_dump dump_reload "After insertion of reloading code" newfd;
   if redo_regalloc then begin
-    Reg.reinit(); Liveness.fundecl newfd; regalloc ppf (round + 1) newfd
+    Reg.reinit(); Liveness.fundecl newfd; regalloc ~ppf_dump (round + 1) newfd
   end else newfd
 
 let (++) x f = f x
 
-let compile_fundecl (ppf : formatter) fd_cmm =
+let compile_fundecl ~ppf_dump fd_cmm =
   Proc.init ();
   Reg.reset();
   fd_cmm
   ++ Profile.record ~accumulate:true "selection" Selection.fundecl
-  ++ pass_dump_if ppf dump_selection "After instruction selection"
+  ++ pass_dump_if ppf_dump dump_selection "After instruction selection"
   ++ Profile.record ~accumulate:true "comballoc" Comballoc.fundecl
-  ++ pass_dump_if ppf dump_combine "After allocation combining"
+  ++ pass_dump_if ppf_dump dump_combine "After allocation combining"
   ++ Profile.record ~accumulate:true "cse" CSE.fundecl
-  ++ pass_dump_if ppf dump_cse "After CSE"
+  ++ pass_dump_if ppf_dump dump_cse "After CSE"
   ++ Profile.record ~accumulate:true "liveness" liveness
   ++ Profile.record ~accumulate:true "deadcode" Deadcode.fundecl
-  ++ pass_dump_if ppf dump_live "Liveness analysis"
+  ++ pass_dump_if ppf_dump dump_live "Liveness analysis"
   ++ Profile.record ~accumulate:true "spill" Spill.fundecl
   ++ Profile.record ~accumulate:true "liveness" liveness
-  ++ pass_dump_if ppf dump_spill "After spilling"
+  ++ pass_dump_if ppf_dump dump_spill "After spilling"
   ++ Profile.record ~accumulate:true "split" Split.fundecl
-  ++ pass_dump_if ppf dump_split "After live range splitting"
+  ++ pass_dump_if ppf_dump dump_split "After live range splitting"
   ++ Profile.record ~accumulate:true "liveness" liveness
-  ++ Profile.record ~accumulate:true "regalloc" (regalloc ppf 1)
+  ++ Profile.record ~accumulate:true "regalloc" (regalloc ~ppf_dump 1)
   ++ Profile.record ~accumulate:true "available_regs" Available_regs.fundecl
   ++ Profile.record ~accumulate:true "linearize" Linearize.fundecl
-  ++ pass_dump_linear_if ppf dump_linear "Linearized code"
+  ++ pass_dump_linear_if ppf_dump dump_linear "Linearized code"
   ++ Profile.record ~accumulate:true "scheduling" Scheduling.fundecl
-  ++ pass_dump_linear_if ppf dump_scheduling "After instruction scheduling"
+  ++ pass_dump_linear_if ppf_dump dump_scheduling "After instruction scheduling"
   ++ Profile.record ~accumulate:true "emit" Emit.fundecl
 
-let compile_phrase ppf p =
-  if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p;
+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 fd
+  | Cfunction fd -> compile_fundecl ~ppf_dump fd
   | Cdata dl -> Emit.data dl
 
 
 (* For the native toplevel: generates generic functions unless
    they are already available in the process *)
-let compile_genfuns ppf f =
+let compile_genfuns ~ppf_dump f =
   List.iter
     (function
        | (Cfunction {fun_name = name}) as ph when f name ->
-           compile_phrase ppf ph
+           compile_phrase ~ppf_dump ph
        | _ -> ())
     (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
 
@@ -173,41 +173,41 @@ let set_export_info (ulambda, prealloc, structured_constants, export) =
   Compilenv.set_export_info export;
   (ulambda, prealloc, structured_constants)
 
-let end_gen_implementation ?toplevel ppf
+let end_gen_implementation ?toplevel ~ppf_dump
     (clambda:clambda_and_constants) =
   Emit.begin_assembly ();
   clambda
-  ++ Profile.record "cmm" Cmmgen.compunit
-  ++ Profile.record "compile_phrases" (List.iter (compile_phrase ppf))
+  ++ Profile.record "cmm" (Cmmgen.compunit ~ppf_dump)
+  ++ Profile.record "compile_phrases" (List.iter (compile_phrase ~ppf_dump))
   ++ (fun () -> ());
-  (match toplevel with None -> () | Some f -> compile_genfuns ppf f);
+  (match toplevel with None -> () | Some f -> compile_genfuns ~ppf_dump f);
 
   (* We add explicit references to external primitive symbols.  This
      is to ensure that the object files that define these symbols,
      when part of a C library, won't be discarded by the linker.
      This is important if a module that uses such a symbol is later
      dynlinked. *)
 
-  compile_phrase ppf
+  compile_phrase ~ppf_dump
     (Cmmgen.reference_symbols
        (List.filter (fun s -> s <> "" && s.[0] <> '%')
           (List.map Primitive.native_name !Translmod.primitive_declarations))
     );
   Emit.end_assembly ()
 
-let flambda_gen_implementation ?toplevel ~backend ppf
+let flambda_gen_implementation ?toplevel ~backend ~ppf_dump
     (program:Flambda.program) =
   let export = Build_export_info.build_transient ~backend program in
   let (clambda, preallocated, constants) =
     Profile.record_call "backend" (fun () ->
       (program, export)
       ++ Flambda_to_clambda.convert
-      ++ flambda_raw_clambda_dump_if ppf
+      ++ flambda_raw_clambda_dump_if ppf_dump
       ++ (fun { Flambda_to_clambda. expr; preallocated_blocks;
                 structured_constants; exported; } ->
              (* "init_code" following the name used in
                 [Cmmgen.compunit_and_constants]. *)
-           Un_anf.apply expr ~what:"init_code", preallocated_blocks,
+           Un_anf.apply ~ppf_dump expr ~what:"init_code", preallocated_blocks,
            structured_constants, exported)
       ++ set_export_info)
   in
@@ -218,10 +218,10 @@ let flambda_gen_implementation ?toplevel ~backend ppf
           definition })
       (Symbol.Map.bindings constants)
   in
-  end_gen_implementation ?toplevel ppf
+  end_gen_implementation ?toplevel ~ppf_dump
     (clambda, preallocated, constants)
 
-let lambda_gen_implementation ?toplevel ppf
+let lambda_gen_implementation ?toplevel ~ppf_dump
     (lambda:Lambda.program) =
   let clambda = Closure.intro lambda.main_module_block_size lambda.code in
   let preallocated_block =
@@ -235,11 +235,11 @@ let lambda_gen_implementation ?toplevel ppf
   let clambda_and_constants =
     clambda, [preallocated_block], []
   in
-  raw_clambda_dump_if ppf clambda_and_constants;
-  end_gen_implementation ?toplevel ppf clambda_and_constants
+  raw_clambda_dump_if ppf_dump clambda_and_constants;
+  end_gen_implementation ?toplevel ~ppf_dump clambda_and_constants
 
 let compile_implementation_gen ?toplevel prefixname
-    ~required_globals ppf gen_implementation program =
+    ~required_globals ~ppf_dump gen_implementation program =
   let asmfile =
     if !keep_asm_file || !Emitaux.binary_backend_available
     then prefixname ^ ext_asm
@@ -248,18 +248,18 @@ let compile_implementation_gen ?toplevel prefixname
   compile_unit prefixname asmfile !keep_asm_file
       (prefixname ^ ext_obj) (fun () ->
         Ident.Set.iter Compilenv.require_global required_globals;
-        gen_implementation ?toplevel ppf program)
+        gen_implementation ?toplevel ~ppf_dump program)
 
 let compile_implementation_clambda ?toplevel prefixname
-    ppf (program:Lambda.program) =
+    ~ppf_dump (program:Lambda.program) =
   compile_implementation_gen ?toplevel prefixname
     ~required_globals:program.Lambda.required_globals
-    ppf lambda_gen_implementation program
+    ~ppf_dump lambda_gen_implementation program
 
 let compile_implementation_flambda ?toplevel prefixname
-    ~required_globals ~backend ppf (program:Flambda.program) =
+    ~required_globals ~backend ~ppf_dump (program:Flambda.program) =
   compile_implementation_gen ?toplevel prefixname
-    ~required_globals ppf (flambda_gen_implementation ~backend) program
+    ~required_globals ~ppf_dump (flambda_gen_implementation ~backend) program
 
 (* Error report *)
 

asmcomp/asmgen.mli

@@ -20,15 +20,15 @@ val compile_implementation_flambda :
     string ->
     required_globals:Ident.Set.t ->
     backend:(module Backend_intf.S) ->
-    Format.formatter -> Flambda.program -> unit
+    ppf_dump:Format.formatter -> Flambda.program -> unit
 
 val compile_implementation_clambda :
     ?toplevel:(string -> bool) ->
     string ->
-    Format.formatter -> Lambda.program -> unit
+    ppf_dump:Format.formatter -> Lambda.program -> unit
 
 val compile_phrase :
-    Format.formatter -> Cmm.phrase -> unit
+    ppf_dump:Format.formatter -> Cmm.phrase -> unit
 
 type error = Assembler_error of string
 exception Error of error

asmcomp/asmlink.ml

@@ -203,11 +203,12 @@ let scan_file obj_name tolink = match read_file obj_name with
 
 (* Second pass: generate the startup file and link it with everything else *)
 
-let force_linking_of_startup ppf =
-  Asmgen.compile_phrase ppf (Cmm.Cdata ([Cmm.Csymbol_address "caml_startup"]))
+let force_linking_of_startup ~ppf_dump =
+  Asmgen.compile_phrase ~ppf_dump
+    (Cmm.Cdata ([Cmm.Csymbol_address "caml_startup"]))
 
-let make_startup_file ppf units_list =
-  let compile_phrase p = Asmgen.compile_phrase ppf p in
+let make_startup_file ~ppf_dump units_list =
+  let compile_phrase p = Asmgen.compile_phrase ~ppf_dump p in
   Location.input_name := "caml_startup"; (* set name of "current" input *)
   Compilenv.reset "_startup";
   (* set the name of the "current" compunit *)
@@ -242,11 +243,11 @@ let make_startup_file ppf units_list =
     compile_phrase (Cmmgen.spacetime_shapes all_names);
   end;
   if !Clflags.output_complete_object then
-    force_linking_of_startup ppf;
+    force_linking_of_startup ~ppf_dump;
   Emit.end_assembly ()
 
-let make_shared_startup_file ppf units =
-  let compile_phrase p = Asmgen.compile_phrase ppf p in
+let make_shared_startup_file ~ppf_dump units =
+  let compile_phrase p = Asmgen.compile_phrase ~ppf_dump p in
   Location.input_name := "caml_startup";
   Compilenv.reset "_shared_startup";
   Emit.begin_assembly ();
@@ -257,7 +258,7 @@ let make_shared_startup_file ppf units =
     (Cmmgen.global_table
        (List.map (fun (ui,_) -> ui.ui_symbol) units));
   if !Clflags.output_complete_object then
-    force_linking_of_startup ppf;
+    force_linking_of_startup ~ppf_dump;
   (* this is to force a reference to all units, otherwise the linker
      might drop some of them (in case of libraries) *)
   Emit.end_assembly ()
@@ -266,7 +267,7 @@ let call_linker_shared file_list output_name =
   if not (Ccomp.call_linker Ccomp.Dll output_name file_list "")
   then raise(Error Linking_error)
 
-let link_shared ppf objfiles output_name =
+let link_shared ~ppf_dump objfiles output_name =
   Profile.record_call output_name (fun () ->
     let units_tolink = List.fold_right scan_file objfiles [] in
     List.iter
@@ -285,7 +286,7 @@ let link_shared ppf objfiles output_name =
     Asmgen.compile_unit output_name
       startup !Clflags.keep_startup_file startup_obj
       (fun () ->
-         make_shared_startup_file ppf
+         make_shared_startup_file ~ppf_dump
            (List.map (fun (ui,_,crc) -> (ui,crc)) units_tolink)
       );
     call_linker_shared (startup_obj :: objfiles) output_name;
@@ -321,7 +322,7 @@ let call_linker file_list startup_file output_name =
 
 (* Main entry point *)
 
-let link ppf objfiles output_name =
+let link ~ppf_dump objfiles output_name =
   Profile.record_call output_name (fun () ->
     let stdlib =
       if !Clflags.gprofile then "stdlib.p.cmxa" else "stdlib.cmxa" in
@@ -350,7 +351,7 @@ let link ppf objfiles output_name =
     let startup_obj = Filename.temp_file "camlstartup" ext_obj in
     Asmgen.compile_unit output_name
       startup !Clflags.keep_startup_file startup_obj
-      (fun () -> make_startup_file ppf units_tolink);
+      (fun () -> make_startup_file ~ppf_dump units_tolink);
     Misc.try_finally
       (fun () ->
         call_linker (List.map object_file_name objfiles)

asmcomp/asmlink.mli

@@ -17,9 +17,9 @@
 
 open Format
 
-val link: formatter -> string list -> string -> unit
+val link: ppf_dump:formatter -> string list -> string -> unit
 
-val link_shared: formatter -> string list -> string -> unit
+val link_shared: ppf_dump:formatter -> string list -> string -> unit
 
 val call_linker_shared: string list -> string -> unit
 

asmcomp/asmpackager.ml

@@ -79,7 +79,7 @@ let check_units members =
 
 (* Make the .o file for the package *)
 
-let make_package_object ppf members targetobj targetname coercion
+let make_package_object ~ppf_dump members targetobj targetname coercion
       ~backend =
   Profile.record_call (Printf.sprintf "pack(%s)" targetname) (fun () ->
     let objtemp =
@@ -102,7 +102,7 @@ let make_package_object ppf members targetobj targetname coercion
     if Config.flambda then begin
       let size, lam = Translmod.transl_package_flambda components coercion in
       let flam =
-        Middle_end.middle_end ppf
+        Middle_end.middle_end ~ppf_dump
           ~prefixname
           ~backend
           ~size
@@ -111,13 +111,13 @@ let make_package_object ppf members targetobj targetname coercion
           ~module_initializer:lam
       in
       Asmgen.compile_implementation_flambda
-        prefixname ~backend ~required_globals:Ident.Set.empty ppf flam;
+        prefixname ~backend ~required_globals:Ident.Set.empty ~ppf_dump flam;
     end else begin
       let main_module_block_size, code =
         Translmod.transl_store_package
           components (Ident.create_persistent targetname) coercion in
       Asmgen.compile_implementation_clambda
-        prefixname ppf { Lambda.code; main_module_block_size;
+        prefixname ~ppf_dump { Lambda.code; main_module_block_size;
                          module_ident; required_globals = Ident.Set.empty }
     end;
     let objfiles =
@@ -220,20 +220,20 @@ let build_package_cmx members cmxfile =
 
 (* Make the .cmx and the .o for the package *)
 
-let package_object_files ppf files targetcmx
+let package_object_files ~ppf_dump files targetcmx
                          targetobj targetname coercion ~backend =
   let pack_path =
     match !Clflags.for_package with
     | None -> targetname
     | Some p -> p ^ "." ^ targetname in
   let members = map_left_right (read_member_info pack_path) files in
   check_units members;
-  make_package_object ppf members targetobj targetname coercion ~backend;
+  make_package_object ~ppf_dump members targetobj targetname coercion ~backend;
   build_package_cmx members targetcmx
 
 (* The entry point *)
 
-let package_files ppf initial_env files targetcmx ~backend =
+let package_files ~ppf_dump initial_env files targetcmx ~backend =
   let files =
     List.map
       (fun f ->
@@ -251,7 +251,7 @@ let package_files ppf initial_env files targetcmx ~backend =
   try
     let coercion =
       Typemod.package_units initial_env files targetcmi targetname in
-    package_object_files ppf files targetcmx targetobj targetname coercion
+    package_object_files ~ppf_dump files targetcmx targetobj targetname coercion
       ~backend
   with x ->
     remove_file targetcmx; remove_file targetobj;

asmcomp/asmpackager.mli

@@ -17,7 +17,7 @@
    original compilation units as sub-modules. *)
 
 val package_files
-   : Format.formatter
+   : ppf_dump:Format.formatter
   -> Env.t
   -> string list
   -> string