pkg: add chrome tracing events

Alizter · Alizter · commit 78b721bbc2af · 2025-11-14T17:20:53.000Z
We add some more chrome tracing events to various pkg related areas. In
order to do this ergonomically, we inroduce some convenience wrappers
for `Dune_stat` which appear to be quite pleasant to use.

Signed-off-by: Ali Caglayan &lt;alizter@gmail.com&gt;
diff --git a/src/dune_engine/sandbox.ml b/src/dune_engine/sandbox.ml
@@ -183,9 +183,9 @@ let snapshot t =
 let create ~mode ~dune_stats ~rule_loc ~dirs ~deps ~rule_dir ~rule_digest =
   let event =
     Dune_stats.start dune_stats (fun () ->
-      let cat = Some [ "create-sandbox" ] in
+      let cat = [ "create-sandbox" ] in
       let name = Loc.to_file_colon_line rule_loc in
-      let args = None in
+      let args = [] in
       { cat; name; args })
   in
   init ();
diff --git a/src/dune_pkg/archive_driver.ml b/src/dune_pkg/archive_driver.ml
@@ -72,6 +72,16 @@ let choose_for_filename_default_to_tar filename =
 ;;
 
 let extract t ~archive ~target =
+  let open Dune_stats.Fiber.O in
+  let& () =
+    { Dune_stats.name = "extract"
+    ; cat = [ "fetch" ]
+    ; args =
+        [ "archive", `String (Path.to_string archive)
+        ; "target", `String (Path.to_string target)
+        ]
+    }
+  in
   let* () = Fiber.return () in
   let command = Lazy.force t.command in
   let prefix = Path.basename target in
diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml
@@ -253,19 +253,17 @@ let fetch ~unpack ~checksum ~target ~url:(url_loc, url) =
   let event =
     Dune_stats.(
       start (global ()) (fun () ->
-        { cat = None
+        { cat = [ "fetch" ]
         ; name = label
         ; args =
-            (let args =
-               [ "url", `String (OpamUrl.to_string url)
-               ; "target", `String (Path.to_string target)
-               ]
-             in
-             Some
-               (match checksum with
-                | None -> args
-                | Some checksum ->
-                  ("checksum", `String (Checksum.to_string checksum)) :: args))
+            List.concat
+              [ Option.map checksum ~f:(fun checksum ->
+                  "checksum", `String (Checksum.to_string checksum))
+                |> Option.to_list
+              ; [ "url", `String (OpamUrl.to_string url)
+                ; "target", `String (Path.to_string target)
+                ]
+              ]
         }))
   in
   let unsupported_backend s =
diff --git a/src/dune_pkg/lock_dir.ml b/src/dune_pkg/lock_dir.ml
@@ -1457,6 +1457,16 @@ module Write_disk = struct
         ~(files : File_entry.t Package_version.Map.Multi.t Package_name.Map.t)
         lock_dir
     =
+    let open Dune_stats.Not_a_fiber.O in
+    let& () =
+      { cat = [ "lock_dir" ]
+      ; name = "write_lock_dir"
+      ; args =
+          [ "lock_dir", `String (Path.to_string lock_dir_path_external)
+          ; "package_count", `Int (Package_name.Map.cardinal files)
+          ]
+      }
+    in
     let lock_dir_hidden =
       (* The original lockdir path with the lockdir renamed to begin with a ".". *)
       let hidden_basename = sprintf ".%s" (Path.basename lock_dir_path_external) in
@@ -1710,7 +1720,17 @@ module Load_immediate = Make_load (struct
   end)
 
 let read_disk = Load_immediate.load
-let read_disk_exn = Load_immediate.load_exn
+
+let read_disk_exn path =
+  let open Dune_stats.Not_a_fiber.O in
+  let& () =
+    { Dune_stats.name = "load_lock_dir"
+    ; cat = [ "lock_dir" ]
+    ; args = [ "lock_dir", `String (Path.to_string path) ]
+    }
+  in
+  Load_immediate.load_exn path
+;;
 
 let transitive_dependency_closure t ~platform start =
   let missing_packages =
diff --git a/src/dune_pkg/opam_repo.ml b/src/dune_pkg/opam_repo.ml
@@ -243,6 +243,13 @@ let all_packages_versions_map ts opam_package_name =
 ;;
 
 let load_all_versions_by_keys ts =
+  let open Dune_stats.Fiber.O in
+  let& () =
+    { Dune_stats.name = "load_all_versions_by_keys"
+    ; cat = [ "opam_repo" ]
+    ; args = [ "version_count", `Int (OpamPackage.Version.Map.cardinal ts) ]
+    }
+  in
   let from_git, from_dirs =
     OpamPackage.Version.Map.values ts
     |> List.partition_map ~f:(fun (repo, (pkg : Key.t)) ->
diff --git a/src/dune_pkg/opam_solver.ml b/src/dune_pkg/opam_solver.ml
@@ -290,8 +290,15 @@ module Context = struct
        | Found p -> Some p)
   ;;
 
-  let repo_candidate t name =
-    let versions = Opam_repo.all_packages_versions_map t.repos name in
+  let repo_candidate t package_name =
+    let open Dune_stats.Fiber.O in
+    let& () =
+      { Dune_stats.name = "repo_candidate"
+      ; cat = [ "solver" ]
+      ; args = [ "package", `String (OpamPackage.Name.to_string package_name) ]
+      }
+    in
+    let versions = Opam_repo.all_packages_versions_map t.repos package_name in
     let rejected, available =
       OpamPackage.Version.Map.fold
         (fun version (repo, key) (rejected, available) ->
@@ -305,7 +312,7 @@ module Context = struct
     let+ resolved = Opam_repo.load_all_versions_by_keys available in
     Table.add_exn
       t.expanded_packages
-      (Package_name.of_opam_package_name name)
+      (Package_name.of_opam_package_name package_name)
       (OpamPackage.Version.Map.cardinal resolved);
     let available =
       OpamPackage.Version.Map.values resolved
@@ -786,6 +793,8 @@ module Solver = struct
     (* Starting from [root_req], explore all the feeds and implementations we
        might need, adding all of them to [sat_problem]. *)
     let build_problem context root_req sat ~max_avoids ~dummy_impl =
+      let open Dune_stats.Fiber.O in
+      let& () = { Dune_stats.cat = [ "solver" ]; name = "build_problem"; args = [] } in
       (* For each (iface, source) we have a list of implementations. *)
       let impl_cache = Fiber_cache.create (module Input.Role) in
       let conflict_classes = Conflict_classes.create () in
@@ -955,6 +964,10 @@ module Solver = struct
     ;;
 
     let do_solve context ~closest_match root_req =
+      let open Dune_stats.Fiber.O in
+      let& () =
+        { Dune_stats.name = "do_solve_with_retries"; cat = [ "solver" ]; args = [] }
+      in
       do_solve context ~closest_match ~max_avoids:(Some 0) root_req
       >>= function
       | Some sels ->
@@ -1436,6 +1449,13 @@ module Solver = struct
 end
 
 let solve_package_list packages ~context =
+  let open Dune_stats.Fiber.O in
+  let& () =
+    { Dune_stats.name = "solve_package_list"
+    ; cat = [ "solver" ]
+    ; args = [ "package_count", `Int (List.length packages) ]
+    }
+  in
   Fiber.collect_errors (fun () ->
     (* [Solver.solve] returns [Error] when it's unable to find a solution to
        the dependencies, but can also raise exceptions, for example if opam
diff --git a/src/dune_pkg/rev_store.ml b/src/dune_pkg/rev_store.ml
@@ -717,6 +717,13 @@ module Entry = struct
 end
 
 let fetch_allow_failure repo ~url obj =
+  let open Dune_stats.Fiber.O in
+  let& () =
+    { Dune_stats.name = "fetch"
+    ; cat = [ "rev_store" ]
+    ; args = [ "url", `String url; "object", `String (Object.to_hex obj) ]
+    }
+  in
   with_mutex repo obj ~f:(fun () ->
     object_exists repo obj
     >>= function
@@ -922,6 +929,13 @@ module At_rev = struct
   ;;
 
   let rec of_rev repo ~revision =
+    let open Dune_stats.Fiber.O in
+    let& () =
+      { Dune_stats.name = "of_rev"
+      ; cat = [ "rev_store" ]
+      ; args = [ "revision", `String (Object.to_hex revision) ]
+      }
+    in
     let* files, submodules = files_and_submodules repo revision in
     let commit_paths = path_commit_map submodules in
     let+ files =
@@ -1021,6 +1035,16 @@ module At_rev = struct
         }
         ~target
     =
+    let open Dune_stats.Fiber.O in
+    let& () =
+      { Dune_stats.name = "check_out"
+      ; cat = [ "rev_store" ]
+      ; args =
+          [ "revision", `String (Object.to_hex revision)
+          ; "target", `String (Path.to_string target)
+          ]
+      }
+    in
     let git = Lazy.force Vcs.git in
     let temp_dir =
       Temp_dir.dir_for_target ~target ~prefix:"rev-store" ~suffix:(Object.to_hex revision)
diff --git a/src/dune_pkg/sys_poll.ml b/src/dune_pkg/sys_poll.ml
@@ -226,6 +226,8 @@ let sys_ocaml_version ~path =
 let make_lazy f = Fiber.Lazy.create f |> Fiber.Lazy.force
 
 let make ~path =
+  let open Dune_stats.Not_a_fiber.O in
+  let& () = { Dune_stats.name = "make"; cat = [ "sys_poll" ]; args = [] } in
   let arch = make_lazy (fun () -> arch ~path) in
   let os = make_lazy (fun () -> os ~path) in
   let os_release_fields = lazy (os_release_fields ()) in
diff --git a/src/dune_rules/lock_dir.ml b/src/dune_rules/lock_dir.ml
@@ -208,8 +208,17 @@ let get_with_path ctx =
         [ "context", Context_name.to_dyn ctx ]
   in
   let* () = Build_system.build_dir path in
-  Load.load path
-  >>= function
+  let* lock_dir =
+    let open Dune_stats.Memo.O in
+    let& () =
+      { Dune_stats.name = "load_lock_dir"
+      ; cat = [ "lock_dir" ]
+      ; args = [ "lock_dir", `String (Path.to_string path) ]
+      }
+    in
+    Load.load path
+  in
+  match lock_dir with
   | Error e -> Memo.return (Error e)
   | Ok lock_dir ->
     let+ workspace_lock_dir = get_workspace_lock_dir ctx in
diff --git a/src/dune_stats/dune b/src/dune_stats/dune
@@ -3,4 +3,4 @@
  (foreign_stubs
   (language c)
   (names dune_stats_stubs))
- (libraries stdune chrome_trace spawn unix))
+ (libraries stdune chrome_trace spawn unix fiber memo))
diff --git a/src/dune_stats/dune_stats.ml b/src/dune_stats/dune_stats.ml
@@ -178,8 +178,8 @@ let printf t format_string =
 let emit t event = printf t "%s" (Json.to_string (Event.to_json event))
 
 type event_data =
-  { args : Chrome_trace.Event.args option
-  ; cat : string list option
+  { args : Chrome_trace.Event.args
+  ; cat : string list
   ; name : string
   }
 
@@ -206,13 +206,70 @@ let finish event =
       let stop = Unix.gettimeofday () in
       Timestamp.of_float_seconds (stop -. start)
     in
+    let cat =
+      match cat with
+      | [] -> None
+      | cat -> Some cat
+    in
+    let args =
+      match args with
+      | [] -> None
+      | args -> Some args
+    in
     let common =
       Event.common_fields ?cat ~name ~ts:(Timestamp.of_float_seconds start) ()
     in
     let event = Event.complete ?args common ~dur in
     emit t event
 ;;
 
+let trace_fiber ~cat ~name ~args f =
+  let event = start (global ()) (fun () -> { args; cat; name }) in
+  Fiber.finalize
+    ~finally:(fun () ->
+      let open Fiber.O in
+      let+ () = Fiber.return (finish event) in
+      ())
+    f
+;;
+
+let trace_sync ~cat ~name ~args f =
+  let event = start (global ()) (fun () -> { args; cat; name }) in
+  Exn.protectx () ~f ~finally:(fun () -> finish event)
+;;
+
+let trace_memo ~cat ~name ~args f =
+  let open Memo.O in
+  let event = start (global ()) (fun () -> { args; cat; name }) in
+  let+ res = f () in
+  finish event;
+  res
+;;
+
+module Not_a_fiber = struct
+  module O = struct
+    let ( let& ) config f =
+      trace_sync ~cat:config.cat ~name:config.name ~args:config.args f
+    ;;
+  end
+end
+
+module Fiber = struct
+  module O = struct
+    let ( let& ) config f =
+      trace_fiber ~cat:config.cat ~name:config.name ~args:config.args f
+    ;;
+  end
+end
+
+module Memo = struct
+  module O = struct
+    let ( let& ) config f =
+      trace_memo ~cat:config.cat ~name:config.name ~args:config.args f
+    ;;
+  end
+end
+
 module Fd_count = struct
   type t =
     | Unknown
diff --git a/src/dune_stats/dune_stats.mli b/src/dune_stats/dune_stats.mli
@@ -23,15 +23,35 @@ val extended_build_job_info : t -> bool
 type event
 
 type event_data =
-  { args : Chrome_trace.Event.args option
-  ; cat : string list option
+  { args : Chrome_trace.Event.args
+  ; cat : string list
   ; name : string
   }
 
 val start : t option -> (unit -> event_data) -> event option
 val finish : event option -> unit
 val flush : t -> unit
 
+module Not_a_fiber : sig
+  (** Please make sure what you are wrapping is not a fiber. *)
+
+  module O : sig
+    val ( let& ) : event_data -> (unit -> 'a) -> 'a
+  end
+end
+
+module Fiber : sig
+  module O : sig
+    val ( let& ) : event_data -> (unit -> 'a Fiber.t) -> 'a Fiber.t
+  end
+end
+
+module Memo : sig
+  module O : sig
+    val ( let& ) : event_data -> (unit -> 'a Memo.t) -> 'a Memo.t
+  end
+end
+
 module Private : sig
   module Fd_count : sig
     type t =
diff --git a/test/blackbox-tests/test-cases/pkg/trace-file.t b/test/blackbox-tests/test-cases/pkg/trace-file.t
