pkg: add chrome tracing events

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 <alizter@gmail.com>

Author: Alizter

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 ();

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

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 =

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.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.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 =

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)) ->

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,11 @@ 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 event =
+        Dune_stats.(
+          start (global ()) (fun () ->
+            { 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
@@ -875,6 +887,7 @@ module Solver = struct
           process_dep `No_expand impl_var dep)
         (* All impl_candidates have now been added, so snapshot the cache. *)
       in
+      Dune_stats.finish event;
       Conflict_classes.seal conflict_classes;
       (match max_avoids, !avoids with
        | None, _ | _, [] -> ()
@@ -955,6 +968,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,13 +1453,20 @@ 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
-       is unable to parse an opam file in the package repository. To prevent
-       an unexpected opam exception from crashing dune, we catch all
-       exceptions raised by the solver and report them as [User_error]s
-       instead. *)
+           the dependencies, but can also raise exceptions, for example if opam
+           is unable to parse an opam file in the package repository. To prevent
+           an unexpected opam exception from crashing dune, we catch all
+           exceptions raised by the solver and report them as [User_error]s
+           instead. *)
     Solver.solve context packages)
   >>| (function
    | Ok (Ok res) -> Ok res

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,12 +929,19 @@ 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 =
       let* submodules = Submodule.parse repo revision in
       (* It's not safe to do a parallel map because adding a remote
-         requires getting the lock (which we're now holding) *)
+              requires getting the lock (which we're now holding) *)
       Fiber.sequential_map submodules ~f:(fun { Submodule.path; source } ->
         match Path.Local.Map.find commit_paths path with
         | None ->
@@ -956,10 +970,10 @@ module At_rev = struct
         Path.Local.Table.create (File.Set.cardinal files)
       in
       (* Build a table mapping each directory path to the set of files under it
-         in the directory hierarchy. *)
+              in the directory hierarchy. *)
       File.Set.iter files ~f:(fun file ->
         (* Add [file] to the set of files under each directory which is an
-           ancestor of [file]. *)
+                ancestor of [file]. *)
         let rec loop = function
           | None -> ()
           | Some parent ->
@@ -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)
@@ -1045,11 +1069,11 @@ module At_rev = struct
         path, archive)
     in
     (* We untar things into a temp dir to make sure we don't create garbage
-       in the build dir until we know can produce the files *)
+           in the build dir until we know can produce the files *)
     let target_in_temp_dir = Path.relative temp_dir "dir" in
     let+ () =
       (* We don't necessarily need to unpack things sequentially, but it's the
-         easiest thing to do *)
+             easiest thing to do *)
       Fiber.sequential_iter archives ~f:(fun (path, archive) ->
         let target_in_temp_dir = Path.append_local target_in_temp_dir path in
         Archive_driver.extract Archive_driver.tar ~archive ~target:target_in_temp_dir

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.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

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

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))