Add a promotion trace event

bin/common.ml

@@ -1271,7 +1271,8 @@ let build (root : Workspace_root.t) (builder : Builder.t) =
     Option.map builder.stats_trace_file ~f:(fun f ->
       let cats =
         match Sys.getenv_opt "DUNE_TRACE" with
-        | None -> Dune_trace.Category.[ Sandbox; Persistent; Process; Rules; Pkg ]
+        | None ->
+          Dune_trace.Category.[ Sandbox; Persistent; Process; Rules; Pkg; Promote ]
         | Some s ->
           String.split ~on:',' s
           |> List.map ~f:(fun x ->

doc/changes/changed/12949.md

@@ -0,0 +1,2 @@
+- Introduce a promotion trace event and remove the corresponding verbose log
+  message. (#12949, @rgrinberg)

flake.nix

@@ -176,6 +176,7 @@
               mercurial
               unzip
               perl
+              jq
             ]
             ++ lib.optionals stdenv.isLinux [ strace ];
           testNativeBuildInputs =

src/dune_engine/target_promotion.ml

@@ -74,12 +74,7 @@ let promote_target_if_not_up_to_date
          this, perhaps, by making artifact substitution a field of [promote]. *)
       Fiber.return false
     | _ ->
-      Log.info
-        [ Pp.textf
-            "Promoting %S to %S"
-            (Path.Build.to_string src)
-            (Path.Source.to_string dst)
-        ];
+      Dune_trace.emit Promote (fun () -> Dune_trace.Event.promote src dst);
       if promote_until_clean then To_delete.add dst;
       (* The file in the build directory might be read-only if it comes from the
          shared cache. However, we want the file in the source tree to be

src/dune_trace/category.ml

@@ -10,8 +10,9 @@ type t =
   | Rules
   | Pkg
   | Scheduler
+  | Promote
 
-let all = [ Rpc; Gc; Fd; Sandbox; Persistent; Process; Rules; Pkg; Scheduler ]
+let all = [ Rpc; Gc; Fd; Sandbox; Persistent; Process; Rules; Pkg; Scheduler; Promote ]
 
 let to_string = function
   | Rpc -> "rpc"
@@ -23,6 +24,7 @@ let to_string = function
   | Rules -> "rules"
   | Pkg -> "pkg"
   | Scheduler -> "scheduler"
+  | Promote -> "promote"
 ;;
 
 let of_string =
@@ -48,5 +50,6 @@ module Set = Bit_set.Make (struct
       | Rules -> 6
       | Pkg -> 7
       | Scheduler -> 8
+      | Promote -> 9
     ;;
   end)

src/dune_trace/category.mli

@@ -8,6 +8,7 @@ type t =
   | Rules
   | Pkg
   | Scheduler
+  | Promote
 
 val to_string : t -> string
 val of_string : string -> t option

src/dune_trace/dune_trace.mli

@@ -11,6 +11,7 @@ module Category : sig
     | Rules
     | Pkg
     | Scheduler
+    | Promote
 
   val of_string : string -> t option
 end
@@ -70,6 +71,7 @@ module Event : sig
   val config : version:string option -> t
   val gc : unit -> t
   val fd_count : unit -> t option
+  val promote : Path.Build.t -> Path.Source.t -> t
 
   module Rpc : sig
     type stage =

src/dune_trace/event.ml

@@ -340,3 +340,17 @@ let fd_count () =
     let common = Event.common_fields ~cat:[ Category.to_string Fd ] ~name:"fds" ~ts () in
     Some (Event.counter common args)
 ;;
+
+let promote src dst =
+  let module Event = Chrome_trace.Event in
+  let common =
+    let ts = Event.Timestamp.of_float_seconds (Time.now () |> Time.to_secs) in
+    Event.common_fields ~cat:[ Category.to_string Promote ] ~name:"promote" ~ts ()
+  in
+  let args =
+    [ "src", `String (Path.Build.to_string src)
+    ; "dst", `String (Path.Source.to_string dst)
+    ]
+  in
+  Event.instant ~args common
+;;

test/blackbox-tests/test-cases/promote/dune

@@ -0,0 +1,3 @@
+(cram
+ (applies_to promote-variables promote-only-when-needed)
+ (deps %{bin:jq}))

test/blackbox-tests/test-cases/promote/promote-only-when-needed.t

@@ -8,8 +8,16 @@ Test that targets aren't re-promoted if they are up to date.
   >  (action (with-stdout-to promoted (echo "Hello, world!"))))
   > EOF
 
-  $ dune build promoted --verbose 2>&1 | grep "Promoting"
-  Promoting "_build/default/promoted" to "promoted"
+  $ showPromotions() {
+  > jq '.[] | select(.name == "promote") | .args' trace.json
+  > }
+
+  $ dune build promoted --trace-file trace.json
+  $ showPromotions
+  {
+    "src": "_build/default/promoted",
+    "dst": "promoted"
+  }
   $ cat promoted
   Hello, world!
 
@@ -23,8 +31,12 @@ Dune doesn't promote the file again if it's unchanged.
 Dune does promotes the file again if it's changed.
 
   $ echo hi > promoted
-  $ dune build promoted --verbose 2>&1 | grep "Promoting"
-  Promoting "_build/default/promoted" to "promoted"
+  $ dune build promoted --trace-file trace.json
+  $ showPromotions
+  {
+    "src": "_build/default/promoted",
+    "dst": "promoted"
+  }
   $ cat promoted
   Hello, world!
 
@@ -46,8 +58,14 @@ Now test behaviour for executables, which use artifact substitution.
   >   | None -> print_endline "Has no version info")
   > EOF
 
-  $ dune build hello.exe --verbose 2>&1 | grep "Promoting"
-  Promoting "_build/default/hello.exe" to "hello.exe"
+  $ dune build hello.exe --trace-file trace.json
+
+  $ showPromotions
+  {
+    "src": "_build/default/hello.exe",
+    "dst": "hello.exe"
+  }
+
   $ ./hello.exe
   Hello, World!
   Has version info
@@ -56,5 +74,12 @@ Bug: Dune currently re-promotes versioned executables on every restart.
 
 # CR-someday amokhov: Fix this.
 
-  $ dune build hello.exe --verbose 2>&1 | grep "Promoting"
-  Promoting "_build/default/hello.exe" to "hello.exe"
+  $ dune build hello.exe --trace-file trace.json
+
+  $ showPromotions
+  {
+    "src": "_build/default/hello.exe",
+    "dst": "hello.exe"
+  }
+
+  $ jq '.[] | select(.name == "promote") | .args'

test/blackbox-tests/test-cases/promote/promote-variables.t

@@ -12,8 +12,14 @@ Test expanding variables in `(promote (into ..))`
   >   (with-stdout-to promoted (echo "Hello, world!"))))
   > EOF
 
-  $ dune build a/b/promoted --verbose 2>&1 | grep "Promoting"
-  Promoting "_build/default/a/b/promoted" to "another/promoted"
+  $ dune build a/b/promoted --trace-file trace.json
+
+  $ jq '.[] | select(.name == "promote") | .args' trace.json
+  {
+    "src": "_build/default/a/b/promoted",
+    "dst": "another/promoted"
+  }
+
   $ cat another/promoted
   Hello, world!