feature: Trace more data

This allows Dune to generate trace files which contain the same
information as .jenga/debug files about processes that Dune runs. This
can be quite a bit of information (including stdout and stderr) so this
is controlled by the `--trace-extended` flag.

Signed-off-by: Roman Leshchinskiy <rleshchinskiy@janestreet.com>

CHANGES.md

@@ -1,6 +1,12 @@
 Unreleased
 ----------
 
+- Add additional metadata to the traces provided by `--trace-file` whenever
+  `--trace-extended` is passed (#7778, @rleshchinskiy)
+
+3.8.0 (2023-05-23)
+------------------
+
 - Fix string quoting in the json file written by `--trace-file` (#7773,
   @rleshchinskiy)
 

bin/common.ml

@@ -535,6 +535,7 @@ module Builder = struct
     ; store_digest_preimage : bool
     ; root : string option
     ; stats_trace_file : string option
+    ; stats_trace_extended : bool
     }
 
   let set_root t root = { t with root = Some root }
@@ -738,6 +739,11 @@ module Builder = struct
             ~doc:
               "Output trace data in catapult format\n\
               \                   (compatible with chrome://tracing)")
+    and+ stats_trace_extended =
+      Arg.(
+        value & flag
+        & info [ "trace-extended" ] ~docs
+            ~doc:"Output extended trace data (requires trace-file)")
     and+ no_print_directory =
       Arg.(
         value & flag
@@ -851,6 +857,9 @@ module Builder = struct
             [ "display-separate-messages" ]
             ~doc:"Separate error messages with a blank line.")
     in
+    if Option.is_none stats_trace_file && stats_trace_extended then
+      User_error.raise
+        [ Pp.text "--trace-extended can only be used with --trace" ];
     { debug_dep_path
     ; debug_backtraces
     ; debug_artifact_substitution
@@ -895,6 +904,7 @@ module Builder = struct
     ; store_digest_preimage
     ; root
     ; stats_trace_file
+    ; stats_trace_extended
     }
 end
 
@@ -1095,6 +1105,19 @@ let init ?action_runner ?log_file c =
         (Path.to_absolute_filename Path.root |> String.maybe_quoted)
     ];
   Dune_console.separate_messages c.builder.separate_error_messages;
+  Option.iter c.stats ~f:(fun stats ->
+      if Dune_stats.extended_build_job_info stats then
+        (* Communicate config settings as an instant event here. *)
+        let open Chrome_trace in
+        let args =
+          [ ("build_dir", `String (Path.Build.to_string Path.Build.root)) ]
+        in
+        let ts = Event.Timestamp.of_float_seconds (Unix.gettimeofday ()) in
+        let common =
+          Event.common_fields ~cat:[ "config" ] ~name:"config" ~ts ()
+        in
+        let event = Event.instant ~args common in
+        Dune_stats.emit stats event);
   config
 
 let footer =
@@ -1144,7 +1167,11 @@ let build (builder : Builder.t) ~default_root_is_cwd =
   in
   let stats =
     Option.map builder.stats_trace_file ~f:(fun f ->
-        let stats = Dune_stats.create (Out (open_out f)) in
+        let stats =
+          Dune_stats.create
+            ~extended_build_job_info:builder.stats_trace_extended
+            (Out (open_out f))
+        in
         at_exit (fun () -> Dune_stats.close stats);
         stats)
   in

otherlibs/chrome-trace/test/chrome_trace_tests.ml

@@ -9,7 +9,9 @@ let c =
   let write s = Buffer.add_string buf s in
   let close () = () in
   let flush () = () in
-  Dune_stats.create (Custom { write; close; flush })
+  Dune_stats.create
+    (Custom { write; close; flush })
+    ~extended_build_job_info:false
 
 let () =
   let module Event = Chrome_trace.Event in

src/dune_engine/process.ml

@@ -578,8 +578,8 @@ end = struct
       fail ~loc ~annots paragraphs
 end
 
-let report_process_finished stats ~metadata ~prog ~pid ~args ~started_at
-    (times : Proc.Times.t) =
+let report_process_finished stats ~metadata ~dir ~prog ~pid ~args ~started_at
+    ~exit_status ~stdout ~stderr (times : Proc.Times.t) =
   let common =
     let name =
       match metadata.name with
@@ -589,11 +589,61 @@ let report_process_finished stats ~metadata ~prog ~pid ~args ~started_at
     let ts = Timestamp.of_float_seconds started_at in
     Event.common_fields ~cat:("process" :: metadata.categories) ~name ~ts ()
   in
-  let args =
+  let always =
     [ ("process_args", `List (List.map args ~f:(fun arg -> `String arg)))
     ; ("pid", `Int (Pid.to_int pid))
     ]
   in
+  let extended =
+    if not (Dune_stats.extended_build_job_info stats) then []
+    else
+      let targets =
+        match metadata.purpose with
+        | Internal_job -> []
+        | Build_job None -> []
+        | Build_job (Some { files; dirs }) ->
+          let mkset s xs =
+            match
+              Path.Build.Set.to_list_map
+                ~f:(fun x -> `String (Path.Build.to_string x))
+                xs
+            with
+            | [] -> []
+            | xs -> [ (s, `List xs) ]
+          in
+          [ ("targets", `Assoc (mkset "files" files @ mkset "dirs" dirs)) ]
+      in
+      let exit =
+        match exit_status with
+        | Ok n -> [ ("exit", `Int n) ]
+        | Error (Exit_status.Failed n) ->
+          [ ("exit", `Int n)
+          ; ("error", `String (sprintf "exited with code %d" n))
+          ]
+        | Error (Signaled s) ->
+          [ ("exit", `Int (Signal.to_int s))
+          ; ("error", `String (sprintf "got signal %s" (Signal.name s)))
+          ]
+      in
+      let output name s =
+        match Lazy.force s with
+        | "" -> []
+        | s -> [ (name, `String s) ]
+      in
+      List.concat
+        [ [ ("prog", `String prog)
+          ; ( "dir"
+            , `String
+                (Option.map ~f:Path.to_string dir |> Option.value ~default:".")
+            )
+          ]
+        ; targets
+        ; exit
+        ; output "stdout" stdout
+        ; output "stderr" stderr
+        ]
+  in
+  let args = always @ extended in
   let dur = Event.Timestamp.of_float_seconds times.elapsed_time in
   let event = Event.complete ~args ~dur common in
   Dune_stats.emit stats event
@@ -724,9 +774,6 @@ let run_internal ?dir ~(display : Display.t) ?(stdout_to = Io.stdout)
         ; resource_usage = process_info.resource_usage
         }
       in
-      Option.iter config.stats ~f:(fun stats ->
-          report_process_finished stats ~metadata ~prog:prog_str ~pid ~args
-            ~started_at times);
       Option.iter response_file ~f:Path.unlink;
       let actual_stdout =
         match stdout_capture with
@@ -759,6 +806,10 @@ let run_internal ?dir ~(display : Display.t) ?(stdout_to = Io.stdout)
         | WSIGNALED n -> Error (Signaled (Signal.of_int n))
         | WSTOPPED _ -> assert false
       in
+      Option.iter config.stats ~f:(fun stats ->
+          report_process_finished stats ~metadata ~dir ~prog:prog_str ~pid ~args
+            ~started_at ~exit_status:exit_status' ~stdout:actual_stdout
+            ~stderr:actual_stderr times);
       let success = Result.is_ok exit_status' in
       let swallow_on_success_if_requested fn actual_output
           (on_success : Action_output_on_success.t) =

src/dune_stats/dune_stats.ml

@@ -108,6 +108,7 @@ type t =
   { print : string -> unit
   ; close : unit -> unit
   ; flush : unit -> unit
+  ; extended_build_job_info : bool
   ; mutable after_first_event : bool
   }
 
@@ -117,7 +118,7 @@ let close { print; close; _ } =
   print "]\n";
   close ()
 
-let create dst =
+let create ~extended_build_job_info dst =
   let print =
     match dst with
     | Out out -> Stdlib.output_string out
@@ -133,10 +134,12 @@ let create dst =
     | Out out -> fun () -> flush out
     | Custom c -> c.flush
   in
-  { print; close; after_first_event = false; flush }
+  { print; close; after_first_event = false; flush; extended_build_job_info }
 
 let flush t = t.flush ()
 
+let extended_build_job_info t = t.extended_build_job_info
+
 let next_leading_char t =
   match t.after_first_event with
   | true -> ','

src/dune_stats/dune_stats.mli

@@ -12,14 +12,16 @@ type dst =
       ; flush : unit -> unit
       }
 
-val create : dst -> t
+val create : extended_build_job_info:bool -> dst -> t
 
 val emit : t -> Chrome_trace.Event.t -> unit
 
 val record_gc_and_fd : t -> unit
 
 val close : t -> unit
 
+val extended_build_job_info : t -> bool
+
 type event
 
 type event_data =