perf: add names to source tree events (ocaml#10884)

* perf: better names for trace events

Signed-off-by: Javier Chávarri <[email protected]>

Author: jchavarri

bin/target.ml

@@ -53,6 +53,7 @@ let all_direct_targets dir =
     Source_tree_map_reduce.map_reduce
       root
       ~traverse:Source_dir_status.Set.all
+      ~trace_event_name:"All direct targets"
       ~f:(fun dir ->
         Dune_engine.Load_rules.load_dir
           ~dir:

doc/changes/10884.md

@@ -0,0 +1 @@
+- Add names to source tree events in performance traces (#10884, @jchavarri)

src/dune_rules/alias_rec.ml

@@ -70,6 +70,10 @@ include Alias_builder.Alias_rec (struct
       >>= function
       | None -> Action_builder.return Alias_builder.Alias_status.Not_defined
       | Some src_dir ->
-        Map_reduce.map_reduce src_dir ~traverse:Source_dir_status.Set.normal_only ~f
+        Map_reduce.map_reduce
+          src_dir
+          ~traverse:Source_dir_status.Set.normal_only
+          ~trace_event_name:"Alias builder"
+          ~f
     ;;
   end)

src/dune_rules/dune_load.ml

@@ -64,7 +64,10 @@ let load () =
       in
       Memo.return (projects, dune_files)
     in
-    Source_tree_map_reduce.map_reduce ~traverse:Source_dir_status.Set.all ~f
+    Source_tree_map_reduce.map_reduce
+      ~traverse:Source_dir_status.Set.all
+      ~trace_event_name:"Dune load"
+      ~f
   in
   let projects = Appendable_list.to_list_rev projects in
   let packages, vendored_packages =

src/dune_rules/foreign_rules.ml

@@ -164,6 +164,7 @@ let include_dir_flags ~expander ~dir ~include_dirs =
                      Source_tree_map_reduce.map_reduce
                        dir
                        ~traverse:Source_dir_status.Set.all
+                       ~trace_event_name:"Foreign rules"
                        ~f:(fun t ->
                          let deps =
                            let dir =

src/dune_rules/source_deps.ml

@@ -13,17 +13,21 @@ let files dir =
   | None -> Memo.return (Dep.Set.empty, Path.Set.empty)
   | Some dir ->
     let+ files, empty_directories =
-      Map_reduce.map_reduce dir ~traverse:Source_dir_status.Set.all ~f:(fun dir ->
-        let path = Path.append_source prefix_with @@ Source_tree.Dir.path dir in
-        let files =
-          Source_tree.Dir.filenames dir
-          |> String.Set.to_list
-          |> Path.Set.of_list_map ~f:(fun fn -> Path.relative path fn)
-        in
-        let empty_directories =
-          if Path.Set.is_empty files then Path.Set.singleton path else Path.Set.empty
-        in
-        Memo.return (files, empty_directories))
+      Map_reduce.map_reduce
+        dir
+        ~traverse:Source_dir_status.Set.all
+        ~trace_event_name:"Source deps"
+        ~f:(fun dir ->
+          let path = Path.append_source prefix_with @@ Source_tree.Dir.path dir in
+          let files =
+            Source_tree.Dir.filenames dir
+            |> String.Set.to_list
+            |> Path.Set.of_list_map ~f:(fun fn -> Path.relative path fn)
+          in
+          let empty_directories =
+            if Path.Set.is_empty files then Path.Set.singleton path else Path.Set.empty
+          in
+          Memo.return (files, empty_directories))
     in
     Dep.Set.of_source_files ~files ~empty_directories, files
 ;;

src/dune_rules/source_tree.ml

@@ -422,7 +422,7 @@ module Dir = struct
     open M.O
 
     let map_reduce =
-      let rec map_reduce t ~traverse ~f =
+      let rec map_reduce t ~traverse ~trace_event_name ~f =
         let must_traverse = Source_dir_status.Map.find traverse t.status in
         match must_traverse with
         | false -> M.return Outcome.empty
@@ -431,7 +431,7 @@ module Dir = struct
           and+ in_sub_dirs =
             M.List.map (Filename.Map.values t.sub_dirs) ~f:(fun s ->
               let* t = M.of_memo (sub_dir_as_t s) in
-              map_reduce t ~traverse ~f)
+              map_reduce t ~traverse ~trace_event_name ~f)
           in
           List.fold_left in_sub_dirs ~init:here ~f:Outcome.combine
       in
@@ -440,17 +440,17 @@ module Dir = struct
           (match Dune_stats.global () with
            | None -> map_reduce
            | Some stats ->
-             fun t ~traverse ~f ->
+             fun t ~traverse ~trace_event_name ~f ->
                let start = Unix.gettimeofday () in
-               let+ res = map_reduce t ~traverse ~f in
+               let+ res = map_reduce t ~traverse ~trace_event_name ~f in
                let event =
                  let stop = Unix.gettimeofday () in
                  let module Event = Chrome_trace.Event in
                  let module Timestamp = Event.Timestamp in
                  let dur = Timestamp.of_float_seconds (stop -. start) in
                  let common =
                    Event.common_fields
-                     ~name:"Source tree scan"
+                     ~name:(trace_event_name ^ ": " ^ Path.Source.to_string t.path)
                      ~ts:(Timestamp.of_float_seconds start)
                      ()
                  in
@@ -460,7 +460,8 @@ module Dir = struct
                Dune_stats.emit stats event;
                res)
       in
-      fun t ~traverse ~f -> (Lazy.force impl) t ~traverse ~f
+      fun t ~traverse ~trace_event_name ~f ->
+        (Lazy.force impl) t ~traverse ~trace_event_name ~f
     ;;
   end
 end
@@ -469,15 +470,15 @@ module Make_map_reduce_with_progress (M : Memo.S) (Outcome : Monoid) = struct
   open M.O
   include Dir.Make_map_reduce (M) (Outcome)
 
-  let map_reduce ~traverse ~f =
+  let map_reduce ~traverse ~trace_event_name ~f =
     let* root = M.of_memo (root ()) in
     let nb_path_visited = ref 0 in
     let overlay =
       Console.Status_line.add_overlay
         (Live (fun () -> Pp.textf "Scanned %i directories" !nb_path_visited))
     in
     let+ res =
-      map_reduce root ~traverse ~f:(fun dir ->
+      map_reduce root ~traverse ~trace_event_name ~f:(fun dir ->
         incr nb_path_visited;
         if !nb_path_visited mod 100 = 0 then Console.Status_line.refresh ();
         f dir)

src/dune_rules/source_tree.mli

@@ -19,6 +19,7 @@ module Dir : sig
     val map_reduce
       :  t
       -> traverse:Source_dir_status.Set.t
+      -> trace_event_name:string
       -> f:(t -> Outcome.t M.t)
       -> Outcome.t M.t
   end
@@ -41,6 +42,7 @@ module Make_map_reduce_with_progress (M : Memo.S) (Outcome : Monoid) : sig
   (** Traverse starting from the root and report progress in the status line *)
   val map_reduce
     :  traverse:Source_dir_status.Set.t
+    -> trace_event_name:string
     -> f:(Dir.t -> Outcome.t M.t)
     -> Outcome.t M.t
 end

src/dune_rules/utop.ml

@@ -118,6 +118,7 @@ let libs_and_ppx_under_dir sctx ~db ~dir =
       Source_tree_map_reduce.map_reduce
         dir
         ~traverse:Source_dir_status.Set.all
+        ~trace_event_name:"Utop rules loading"
         ~f:(fun dir ->
           let dir =
             Path.Build.append_source

src/upgrader/dune_upgrader.ml

@@ -369,10 +369,13 @@ let upgrade () =
                   type t = Source_tree.Dir.t * project_version
                 end))
          in
-        M.map_reduce ~traverse:Source_dir_status.Set.normal_only ~f:(fun dir ->
-          let project = Source_tree.Dir.project dir in
-          let detected_version = detect_project_version project dir in
-          Memo.return (Appendable_list.singleton (dir, detected_version))))
+        M.map_reduce
+          ~traverse:Source_dir_status.Set.normal_only
+          ~trace_event_name:"Upgrader"
+          ~f:(fun dir ->
+            let project = Source_tree.Dir.project dir in
+            let detected_version = detect_project_version project dir in
+            Memo.return (Appendable_list.singleton (dir, detected_version))))
       >>| Appendable_list.to_list
     in
     let v1_updates = ref false in