diff --git a/bin/target.ml b/bin/target.ml index 00baa64614d..ada1036143b 100644 --- a/bin/target.ml +++ b/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: diff --git a/doc/changes/10884.md b/doc/changes/10884.md new file mode 100644 index 00000000000..95b8d94e77d --- /dev/null +++ b/doc/changes/10884.md @@ -0,0 +1 @@ +- Add names to source tree events in performance traces (#10884, @jchavarri) diff --git a/src/dune_rules/alias_rec.ml b/src/dune_rules/alias_rec.ml index bf719dad888..40a9dfecaf4 100644 --- a/src/dune_rules/alias_rec.ml +++ b/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) diff --git a/src/dune_rules/dune_load.ml b/src/dune_rules/dune_load.ml index 4c57684cdf7..94c51f0fb62 100644 --- a/src/dune_rules/dune_load.ml +++ b/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 = diff --git a/src/dune_rules/foreign_rules.ml b/src/dune_rules/foreign_rules.ml index d4472f819f6..86e9929558e 100644 --- a/src/dune_rules/foreign_rules.ml +++ b/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 = diff --git a/src/dune_rules/source_deps.ml b/src/dune_rules/source_deps.ml index cd1dbebc98e..1bc74a1c1b4 100644 --- a/src/dune_rules/source_deps.ml +++ b/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 ;; diff --git a/src/dune_rules/source_tree.ml b/src/dune_rules/source_tree.ml index ee18d160d47..8e9017227bf 100644 --- a/src/dune_rules/source_tree.ml +++ b/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,9 +440,9 @@ 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 @@ -450,7 +450,7 @@ module Dir = struct 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,7 +470,7 @@ 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 = @@ -477,7 +478,7 @@ module Make_map_reduce_with_progress (M : Memo.S) (Outcome : Monoid) = struct (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) diff --git a/src/dune_rules/source_tree.mli b/src/dune_rules/source_tree.mli index 222fa1f69ab..75dd822fd38 100644 --- a/src/dune_rules/source_tree.mli +++ b/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 diff --git a/src/dune_rules/utop.ml b/src/dune_rules/utop.ml index 01697cc8110..210489454b0 100644 --- a/src/dune_rules/utop.ml +++ b/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 diff --git a/src/upgrader/dune_upgrader.ml b/src/upgrader/dune_upgrader.ml index 33d8bda94e0..c2df2acaa9e 100644 --- a/src/upgrader/dune_upgrader.ml +++ b/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 diff --git a/test/blackbox-tests/test-cases/trace-file.t/run.t b/test/blackbox-tests/test-cases/trace-file.t/run.t index f13fd2fd7a4..1769346ef0c 100644 --- a/test/blackbox-tests/test-cases/trace-file.t/run.t +++ b/test/blackbox-tests/test-cases/trace-file.t/run.t @@ -3,7 +3,7 @@ This captures the commands that are being run: $