feature: sandbox snapshot event

doc/changes/added/13541.md

@@ -0,0 +1 @@
+- Add a trace event for snapshotting the asndbox (#13541, @rgrinberg)

src/dune_engine/sandbox.ml

@@ -147,19 +147,26 @@ let link_deps t ~mode ~deps =
 
 let snapshot t =
   let root = Path.build t.dir in
-  Fpath.traverse
-    ~dir:(Path.to_string root)
-    ~init:Path.Map.empty
-    ~on_dir:(fun ~dir fname acc ->
-      let path = Path.relative root (Filename.concat dir fname) in
-      Path.Map.add_exn acc path `Dir)
-    ~on_file:(fun ~dir fname acc ->
-      let p = Path.relative root (Filename.concat dir fname) in
-      let stats = Unix.stat (Path.to_string p) in
-      Path.Map.add_exn acc p (`File (Cached_digest.Reduced_stats.of_unix_stats stats)))
-    ~on_other:`Ignore
-    ~on_symlink:`Ignore
-    ()
+  let start = Time.now () in
+  let snapshot =
+    Fpath.traverse
+      ~dir:(Path.to_string root)
+      ~init:Path.Map.empty
+      ~on_dir:(fun ~dir fname acc ->
+        let path = Path.relative root (Filename.concat dir fname) in
+        Path.Map.add_exn acc path `Dir)
+      ~on_file:(fun ~dir fname acc ->
+        let p = Path.relative root (Filename.concat dir fname) in
+        let stats = Unix.stat (Path.to_string p) in
+        Path.Map.add_exn acc p (`File (Cached_digest.Reduced_stats.of_unix_stats stats)))
+      ~on_other:`Ignore
+      ~on_symlink:`Ignore
+      ()
+  in
+  let stop = Time.now () in
+  Dune_trace.emit ~buffered:true Sandbox (fun () ->
+    Dune_trace.Event.sandbox `Snapshot ~start ~stop ~queued:None t.loc ~dir:t.dir);
+  snapshot
 ;;
 
 let create ~mode ~rule_loc ~dirs ~deps ~rule_dir ~rule_digest =
@@ -316,5 +323,5 @@ let destroy t =
   in
   Dune_trace.emit ~buffered:true Sandbox (fun () ->
     let queued = Time.diff start queue_start in
-    Dune_trace.Event.sandbox_destroy ~start ~stop ~queued t.loc ~dir:t.dir)
+    Dune_trace.Event.sandbox `Destroy ~start ~stop ~queued:(Some queued) t.loc ~dir:t.dir)
 ;;

src/dune_trace/dune_trace.mli

@@ -37,10 +37,11 @@ module Event : sig
 
   type t
 
-  val sandbox_destroy
-    :  start:Time.t
+  val sandbox
+    :  [ `Snapshot | `Destroy ]
+    -> start:Time.t
     -> stop:Time.t
-    -> queued:Time.Span.t
+    -> queued:Time.Span.t option
     -> Loc.t
     -> dir:Path.Build.t
     -> t

src/dune_trace/event.ml

@@ -746,13 +746,20 @@ let spawn_thread ~name =
   Event.instant ~args ~name:"spawn_thread" now Thread
 ;;
 
-let sandbox_destroy ~start ~stop ~queued loc ~dir =
+let sandbox name ~start ~stop ~queued loc ~dir =
   let args =
-    [ "queued", Arg.span queued
-    ; "loc", Arg.string (Loc.to_file_colon_line loc)
-    ; "dir", Arg.build_path dir
-    ]
+    [ "loc", Arg.string (Loc.to_file_colon_line loc); "dir", Arg.build_path dir ]
+  in
+  let args =
+    match queued with
+    | None -> args
+    | Some queued -> ("queued", Arg.span queued) :: args
   in
   let dur = Time.diff stop start in
-  Event.complete ~args ~name:"destroy" ~start ~dur Sandbox
+  let name =
+    match name with
+    | `Destroy -> "destroy"
+    | `Snapshot -> "snapshot"
+  in
+  Event.complete ~args ~name ~start ~dur Sandbox
 ;;

test/blackbox-tests/dune.jq

@@ -75,3 +75,6 @@ def fsUpdateWithPath($path):
     select(.name == "fs_update")
   | .args
   | select(.path == $path);
+
+def censorDigestDir:
+  .args.dir |= (if . then sub("[0-9a-f]{32}"; "$DIGEST") else . end);

test/blackbox-tests/test-cases/sandbox/patch-back-source-tree.t

@@ -34,6 +34,22 @@ All modified dependencies are promoted
 
   $ echo blah > x
   $ dune build
+
+  $ dune trace cat | jq '
+  > include "dune";
+  >   select(.cat == "sandbox" and .name == "snapshot")
+  > | censorDigestDir
+  > | .args
+  > '
+  {
+    "loc": "dune:1",
+    "dir": "_build/.sandbox/$DIGEST"
+  }
+  {
+    "loc": "dune:1",
+    "dir": "_build/.sandbox/$DIGEST"
+  }
+
   $ dune promote x
   Promoting _build/default/x to x.
   $ cat x

test/blackbox-tests/test-cases/sandbox/sandbox-events.t

@@ -12,9 +12,10 @@ Demonstrate sandbox events:
   $ dune build @foo
 
   $ dune trace cat | jq '
+  >  include "dune";
   >   select(.cat == "sandbox")
   > | del(.ts,.dur, .args.queued)
-  > | .args.dir |= (if . then sub("[0-9a-f]{32}"; "$DIGEST") else . end)
+  > | censorDigestDir
   > '
   {
     "cat": "sandbox",