Add some more metrics

Signed-off-by: Andrey Mokhov <amokhov@janestreet.com>

bin/build_cmd.ml

@@ -15,9 +15,13 @@ let run_build_system ~common ~(targets : unit -> Target.t list Memo.Build.t) =
         Console.print_user_message
           (User_message.make
              [ Pp.textf "%s" (Memo.Perf_counters.report_for_current_run ())
-             ; Pp.textf "(%.2f sec, %d heap words)"
+             ; Pp.textf
+                 "(%.2fs total, %.2fs cycle detection, %.2fs digests, %.1fM \
+                  heap words)"
                  (Unix.gettimeofday () -. build_started)
-                 gc_stat.heap_words
+                 (Metrics.Timer.read_seconds Memo.cycle_detection_timer)
+                 (Metrics.Timer.read_seconds Digest.generic_timer)
+                 (float_of_int gc_stat.heap_words /. 1_000_000.)
              ]));
       Fiber.return ())
 

bin/common.ml

@@ -940,7 +940,10 @@ let term =
         stats)
   in
   if store_digest_preimage then Dune_engine.Reversible_digest.enable ();
-  if print_metrics then Memo.Perf_counters.enable ();
+  if print_metrics then (
+    Memo.Perf_counters.enable ();
+    Metrics.enable ()
+  );
   { debug_dep_path
   ; debug_findlib
   ; debug_backtraces

otherlibs/stdune-unstable/digest.ml

@@ -55,13 +55,17 @@ let string = Impl.string
 
 let to_string_raw s = s
 
+let generic_timer = Metrics.Timer.create ()
+
 (* We use [No_sharing] to avoid generating different digests for inputs that
    differ only in how they share internal values. Without [No_sharing], if a
    command line contains duplicate flags, such as multiple occurrences of the
    flag [-I], then [Marshal.to_string] will produce different digests depending
    on whether the corresponding strings ["-I"] point to the same memory location
    or to different memory locations. *)
-let generic a = string (Marshal.to_string a [ No_sharing ])
+let generic a =
+  Metrics.Timer.record generic_timer ~f:(fun () ->
+      string (Marshal.to_string a [ No_sharing ]))
 
 let file_with_executable_bit ~executable path =
   (* We follow the digest scheme used by Jenga. *)

otherlibs/stdune-unstable/digest.mli

@@ -26,6 +26,9 @@ val to_string_raw : t -> string
 
 val generic : 'a -> t
 
+(** The total time spent in the function [generic] during the current build. *)
+val generic_timer : Metrics.Timer.t
+
 (** Digest a file and its stats. Does something sensible for directories. *)
 val file_with_stats : Path.t -> Unix.stats -> t
 

otherlibs/stdune-unstable/monoid.ml

@@ -139,12 +139,24 @@ end)
   let combine f g x = M.combine (f x) (g x)
 end)
 
-module Endofunction (A : sig
-  type t
-end) : Monoid_intf.S with type t = A.t -> A.t = Make (struct
-  type t = A.t -> A.t
+module Endofunction = struct
+  module Left (A : sig
+    type t
+  end) : Monoid_intf.S with type t = A.t -> A.t = Make (struct
+    type t = A.t -> A.t
 
-  let empty x = x
+    let empty x = x
 
-  let combine f g x = f (g x)
-end)
+    let combine f g x = g (f x)
+  end)
+
+  module Right (A : sig
+    type t
+  end) : Monoid_intf.S with type t = A.t -> A.t = Make (struct
+    type t = A.t -> A.t
+
+    let empty x = x
+
+    let combine f g x = f (g x)
+  end)
+end

otherlibs/stdune-unstable/monoid.mli

@@ -74,10 +74,23 @@ module Function (A : sig
 end)
 (M : Monoid_intf.Basic) : Monoid_intf.S with type t = A.t -> M.t
 
-(** Endofunctions, i.e., functions of type [t -> t] form the following monoid:
-
-    - empty = fun x -> x
-    - combine f g = fun x -> f (g x) *)
-module Endofunction (A : sig
-  type t
-end) : Monoid_intf.S with type t = A.t -> A.t
+(** Endofunctions, i.e., functions of type [t -> t] form two monoids. *)
+module Endofunction : sig
+  (** The left-to-right function composition monoid, where the argument is first
+      passed to the leftmost function:
+
+      - empty = fun x -> x
+      - combine f g = fun x -> g (f x) *)
+  module Left (A : sig
+    type t
+  end) : Monoid_intf.S with type t = A.t -> A.t
+
+  (** The right-to-left function composition monoid, where the argument is first
+      passed to the rightmost function:
+
+      - empty = fun x -> x
+      - combine f g = fun x -> f (g x) *)
+  module Right (A : sig
+    type t
+  end) : Monoid_intf.S with type t = A.t -> A.t
+end

otherlibs/stdune-unstable/stdune.ml

@@ -68,6 +68,7 @@ module Seq = Seq
 module Temp = Temp
 module Queue = Queue
 module Caller_id = Caller_id
+module Metrics = Metrics
 
 module type Applicative = Applicative_intf.S
 

src/memo/memo.ml

@@ -849,41 +849,47 @@ module Cached_value = struct
       not (Exn_set.equal prev_exns cur_exns)
 end
 
+let cycle_detection_timer = Metrics.Timer.create ()
+
 (* Add a dependency on the [dep_node] from the caller, if there is one. Returns
    an [Error] if the new dependency would introduce a dependency cycle. *)
 let add_dep_from_caller (type i o) (dep_node : (i, o) Dep_node.t)
     (sample_attempt : _ Sample_attempt.t) =
   let* caller = Call_stack.get_call_stack_tip () in
-  match caller with
-  | None -> Fiber.return (Ok ())
-  | Some (Stack_frame_with_state.T caller) -> (
-    let deps_so_far_of_caller = caller.running_state.deps_so_far in
-    match
-      Id.Map.mem deps_so_far_of_caller.added_to_dag dep_node.without_state.id
-    with
-    | true ->
-      Deps_so_far.add_dep deps_so_far_of_caller dep_node.without_state.id
-        (Dep_node.T dep_node);
-      Fiber.return (Ok ())
-    | false -> (
-      let cycle_error =
-        match sample_attempt with
-        | Finished _ -> None
-        | Running { dag_node; _ } -> (
-          match
-            Dag.add_assuming_missing global_dep_dag
-              caller.running_state.dag_node dag_node
-          with
-          | () -> None
-          | exception Dag.Cycle cycle ->
-            Some (List.map cycle ~f:(fun dag_node -> dag_node.Dag.data)))
-      in
-      match cycle_error with
-      | None ->
-        Deps_so_far.add_dep deps_so_far_of_caller dep_node.without_state.id
-          (Dep_node.T dep_node);
-        Fiber.return (Ok ())
-      | Some cycle -> Fiber.return (Error cycle)))
+  (* Not counting the above computation of the [caller] towards cycle detection,
+     to avoid inserting an extra Fiber map or bind. *)
+  Metrics.Timer.record cycle_detection_timer ~f:(fun () ->
+      match caller with
+      | None -> Fiber.return (Ok ())
+      | Some (Stack_frame_with_state.T caller) -> (
+        let deps_so_far_of_caller = caller.running_state.deps_so_far in
+        match
+          Id.Map.mem deps_so_far_of_caller.added_to_dag
+            dep_node.without_state.id
+        with
+        | true ->
+          Deps_so_far.add_dep deps_so_far_of_caller dep_node.without_state.id
+            (Dep_node.T dep_node);
+          Fiber.return (Ok ())
+        | false -> (
+          let cycle_error =
+            match sample_attempt with
+            | Finished _ -> None
+            | Running { dag_node; _ } -> (
+              match
+                Dag.add_assuming_missing global_dep_dag
+                  caller.running_state.dag_node dag_node
+              with
+              | () -> None
+              | exception Dag.Cycle cycle ->
+                Some (List.map cycle ~f:(fun dag_node -> dag_node.Dag.data)))
+          in
+          match cycle_error with
+          | None ->
+            Deps_so_far.add_dep deps_so_far_of_caller dep_node.without_state.id
+              (Dep_node.T dep_node);
+            Fiber.return (Ok ())
+          | Some cycle -> Fiber.return (Error cycle))))
 
 type ('input, 'output) t =
   { spec : ('input, 'output) Spec.t

src/memo/memo.mli

@@ -421,6 +421,9 @@ module Perf_counters : sig
   val reset : unit -> unit
 end
 
+(** Total time taken by the cycle detection functionality. *)
+val cycle_detection_timer : Metrics.Timer.t
+
 module Expert : sig
   (** Like [cell] but returns [Nothing] if the given memoized function has never
       been evaluated on the specified input. We use [previously_evaluated_cell]