bench: add GC stats to bench (ocaml#8063)

Signed-off-by: Ali Caglayan <[email protected]>

Author: Alizter

bench/bench.ml

@@ -90,32 +90,83 @@ let prepare_workspace () =
       Format.eprintf "cloning %s/%s@." pkg.org pkg.name;
       Package.clone pkg)
 
-let dune_build () =
+let dune_build ~name =
   let stdin_from = Process.(Io.null In) in
   let stdout_to = Process.Io.make_stdout Swallow in
   let stderr_to = Process.Io.make_stderr Swallow in
+  let gc_dump = Temp.create File ~prefix:"gc_stat" ~suffix:name in
   let open Fiber.O in
+  (* Build with timings and gc stats *)
   let+ times =
     Process.run_with_times dune ~display:Quiet ~stdin_from ~stdout_to ~stderr_to
-      [ "build"; "@install"; "--release" ]
+      [ "build"
+      ; "@install"
+      ; "--release"
+      ; "--dump-gc-stats"
+      ; Path.to_string gc_dump
+      ]
   in
-  times.elapsed_time
+  (* Read the gc stats from the dump file *)
+  Dune_lang.Parser.parse_string ~mode:Single ~fname:(Path.to_string gc_dump)
+    (Io.read_file gc_dump)
+  |> Dune_lang.Decoder.parse Dune_util.Gc.decode Univ_map.empty
+  |> Metrics.make times
 
 let run_bench () =
   let open Fiber.O in
-  let* clean = dune_build () in
+  let* clean = dune_build ~name:"clean" in
   let+ zero =
-    let open Fiber.O in
     let rec zero acc n =
       if n = 0 then Fiber.return (List.rev acc)
       else
-        let* time = dune_build () in
+        let* time = dune_build ~name:("zero" ^ string_of_int n) in
         zero (time :: acc) (pred n)
     in
     zero [] 5
   in
   (clean, zero)
 
+let display what units clean zero =
+  { Output.name = what
+  ; metrics =
+      [ ("[Clean] " ^ what, clean, units); ("[Null] " ^ what, zero, units) ]
+  }
+
+let results clean zero size =
+  (* tagging data for json conversion *)
+  let tag data = Metrics.map ~f:(fun t -> `Float t) ~g:(fun t -> `Int t) data in
+  let clean = tag clean in
+  let zero =
+    List.map zero ~f:tag |> Metrics.unzip
+    |> Metrics.map ~f:(fun x -> `List x) ~g:(fun x -> `List x)
+  in
+  (* bench results *)
+  [ display "Build Time" "Seconds" clean.elapsed_time zero.elapsed_time
+  ; { Output.name = "Misc"
+    ; metrics = [ ("Size of _boot/dune.exe", `Int size, "Bytes") ]
+    }
+  ; display "User CPU Time" "Seconds" clean.user_cpu_time zero.user_cpu_time
+  ; display "System CPU Time" "Seconds" clean.system_cpu_time
+      zero.system_cpu_time
+  ; display "Minor Words" "Approx. Words" clean.minor_words zero.minor_words
+  ; display "Major Words" "Approx. Words" clean.major_words zero.major_words
+  ; display "Minor Collections" "Collections" clean.minor_collections
+      zero.minor_collections
+  ; display "Major Collections" "Collections" clean.major_collections
+      zero.major_collections
+  ; display "Heap Words" "Words" clean.heap_words zero.heap_words
+  ; display "Heap Chunks" "Chunks" clean.heap_chunks zero.heap_chunks
+  ; display "Live Words" "Words" clean.live_words zero.live_words
+  ; display "Live Blocks" "Blocks" clean.live_blocks zero.live_blocks
+  ; display "Free Words" "Words" clean.free_words zero.free_words
+  ; display "Free Blocks" "Blocks" clean.free_blocks zero.free_blocks
+  ; display "Largest Free" "Words" clean.largest_free zero.largest_free
+  ; display "Fragments" "Fragments" clean.fragments zero.fragments
+  ; display "Compactions" "Compactions" clean.compactions zero.compactions
+  ; display "Top Heap Words" "Words" clean.top_heap_words zero.top_heap_words
+  ; display "Stack Size" "Words" clean.stack_size zero.stack_size
+  ]
+
 let () =
   Dune_util.Log.init ~file:No_log_file ();
   let dir = Temp.create Dir ~prefix:"dune" ~suffix:"bench" in
@@ -140,24 +191,12 @@ let () =
         let* () = prepare_workspace () in
         run_bench ())
   in
-  let zero = List.map zero ~f:(fun t -> `Float t) in
   let size =
     let stat : Unix.stats = Path.stat_exn dune in
     stat.st_size
   in
-  let results =
-    [ { Output.name = "Build times"
-      ; metrics =
-          [ ("Clean build time", `Float clean, "secs")
-          ; ("Null build time", `List zero, "secs")
-          ]
-      }
-    ; { Output.name = "Misc"
-      ; metrics = [ ("Size of _boot/dune.exe", `Int size, "bytes") ]
-      }
-    ]
-  in
-  let version = 2 in
+  let results = results clean zero size in
+  let version = 3 in
   let output = { Output.config = []; version; results } in
   print_string (Json.to_string (Output.to_json output));
   flush stdout

bench/bench.mli

@@ -1,7 +1,14 @@
 (executable
  (name bench)
- (modules bench)
- (libraries dune_stats chrome_trace stdune fiber dune_engine dune_util))
+ (modules bench metrics)
+ (libraries
+  dune_stats
+  chrome_trace
+  stdune
+  fiber
+  dune_lang
+  dune_engine
+  dune_util))
 
 (rule
  (alias bench)

bench/dune

@@ -0,0 +1,119 @@
+open Stdune
+
+type ('float, 'int) t =
+  { elapsed_time : 'float
+  ; user_cpu_time : 'float
+  ; system_cpu_time : 'float
+  ; minor_words : 'float
+  ; promoted_words : 'float
+  ; major_words : 'float
+  ; minor_collections : 'int
+  ; major_collections : 'int
+  ; heap_words : 'int
+  ; heap_chunks : 'int
+  ; live_words : 'int
+  ; live_blocks : 'int
+  ; free_words : 'int
+  ; free_blocks : 'int
+  ; largest_free : 'int
+  ; fragments : 'int
+  ; compactions : 'int
+  ; top_heap_words : 'int
+  ; stack_size : 'int
+  }
+
+let make (times : Proc.Times.t) (gc : Gc.stat) =
+  (* We default to 0 for the other processor times since they are rarely None in
+     pracice. *)
+  let { Proc.Resource_usage.user_cpu_time; system_cpu_time } =
+    Option.value times.resource_usage
+      ~default:{ user_cpu_time = 0.; system_cpu_time = 0. }
+  in
+  { elapsed_time = times.elapsed_time
+  ; user_cpu_time
+  ; system_cpu_time
+  ; minor_words = gc.minor_words
+  ; promoted_words = gc.promoted_words
+  ; major_words = gc.major_words
+  ; minor_collections = gc.minor_collections
+  ; major_collections = gc.major_collections
+  ; heap_words = gc.heap_words
+  ; heap_chunks = gc.heap_chunks
+  ; live_words = gc.live_words
+  ; live_blocks = gc.live_blocks
+  ; free_words = gc.free_words
+  ; free_blocks = gc.free_blocks
+  ; largest_free = gc.largest_free
+  ; fragments = gc.fragments
+  ; compactions = gc.compactions
+  ; top_heap_words = gc.top_heap_words
+  ; stack_size = gc.stack_size
+  }
+
+let map ~f ~g (metrics : ('float, 'int) t) : ('float_, 'int_) t =
+  { elapsed_time = f metrics.elapsed_time
+  ; user_cpu_time = f metrics.user_cpu_time
+  ; system_cpu_time = f metrics.system_cpu_time
+  ; minor_words = f metrics.minor_words
+  ; promoted_words = f metrics.promoted_words
+  ; major_words = f metrics.major_words
+  ; minor_collections = g metrics.minor_collections
+  ; major_collections = g metrics.major_collections
+  ; heap_words = g metrics.heap_words
+  ; heap_chunks = g metrics.heap_chunks
+  ; live_words = g metrics.live_words
+  ; live_blocks = g metrics.live_blocks
+  ; free_words = g metrics.free_words
+  ; free_blocks = g metrics.free_blocks
+  ; largest_free = g metrics.largest_free
+  ; fragments = g metrics.fragments
+  ; compactions = g metrics.compactions
+  ; top_heap_words = g metrics.top_heap_words
+  ; stack_size = g metrics.stack_size
+  }
+
+(** Turns a list of records into a record of lists. *)
+let unzip (metrics : ('float, 'int) t list) : ('float list, 'int list) t =
+  List.fold_left metrics
+    ~init:
+      { elapsed_time = []
+      ; user_cpu_time = []
+      ; system_cpu_time = []
+      ; minor_words = []
+      ; promoted_words = []
+      ; major_words = []
+      ; minor_collections = []
+      ; major_collections = []
+      ; heap_words = []
+      ; heap_chunks = []
+      ; live_words = []
+      ; live_blocks = []
+      ; free_words = []
+      ; free_blocks = []
+      ; largest_free = []
+      ; fragments = []
+      ; compactions = []
+      ; top_heap_words = []
+      ; stack_size = []
+      } ~f:(fun acc x ->
+      { elapsed_time = x.elapsed_time :: acc.elapsed_time
+      ; user_cpu_time = x.user_cpu_time :: acc.user_cpu_time
+      ; system_cpu_time = x.system_cpu_time :: acc.system_cpu_time
+      ; minor_words = x.minor_words :: acc.minor_words
+      ; promoted_words = x.promoted_words :: acc.promoted_words
+      ; major_words = x.major_words :: acc.major_words
+      ; minor_collections = x.minor_collections :: acc.minor_collections
+      ; major_collections = x.major_collections :: acc.major_collections
+      ; heap_words = x.heap_words :: acc.heap_words
+      ; heap_chunks = x.heap_chunks :: acc.heap_chunks
+      ; live_words = x.live_words :: acc.live_words
+      ; live_blocks = x.live_blocks :: acc.live_blocks
+      ; free_words = x.free_words :: acc.free_words
+      ; free_blocks = x.free_blocks :: acc.free_blocks
+      ; largest_free = x.largest_free :: acc.largest_free
+      ; fragments = x.fragments :: acc.fragments
+      ; compactions = x.compactions :: acc.compactions
+      ; top_heap_words = x.top_heap_words :: acc.top_heap_words
+      ; stack_size = x.stack_size :: acc.stack_size
+      })
+  |> map ~f:List.rev ~g:List.rev

bench/metrics.ml

@@ -0,0 +1,69 @@
+open Stdune
+
+(** [('float, 'int) t] is a record of metrics about the current process. It
+    includes timing information and information available from [Gc.stat]. It is
+    polymorphic in the type of field values to allow for the definition of
+    [unzip] functions which make serialisation easier. *)
+type ('float, 'int) t =
+  { elapsed_time : 'float
+        (** Real time elapsed since the process started and the process
+            finished. *)
+  ; user_cpu_time : 'float
+        (** The amount of CPU time spent in user mode during the process. Other
+            processes and blocked time are not included. *)
+  ; system_cpu_time : 'float
+        (** The amount of CPU time spent in kernel mode during the process.
+            Similar to user time, other processes and time spent blocked by
+            other processes are not counted. *)
+  ; minor_words : 'float
+        (** Number of words allocated in the minor heap since the program was
+            started. *)
+  ; promoted_words : 'float
+        (** Number of words that have been promoted from the minor to the major
+            heap since the program was started. *)
+  ; major_words : 'float
+        (** Number of words allocated in the major heap since the program was
+            started. *)
+  ; minor_collections : 'int
+        (** Number of minor collections since the program was started. *)
+  ; major_collections : 'int
+        (** Number of major collection cycles completed since the program was
+            started. *)
+  ; heap_words : 'int  (** Total size of the major heap, in words. *)
+  ; heap_chunks : 'int
+        (** Number of contiguous pieces of memory that make up the major heap. *)
+  ; live_words : 'int
+        (** Number of words of live data in the major heap, including the header
+            words. *)
+  ; live_blocks : 'int  (** Number of live blocks in the major heap. *)
+  ; free_words : 'int  (** Number of words in the free list. *)
+  ; free_blocks : 'int  (** Number of blocks in the free list. *)
+  ; largest_free : 'int
+        (** Size (in words) of the largest block in the free list. *)
+  ; fragments : 'int
+        (** Number of wasted words due to fragmentation. These are 1-words free
+            blocks placed between two live blocks. They are not available for
+            allocation. *)
+  ; compactions : 'int
+        (** Number of heap compactions since the program was started. *)
+  ; top_heap_words : 'int
+        (** Maximum size reached by the major heap, in words. *)
+  ; stack_size : 'int  (** Current size of the stack, in words. *)
+  }
+
+(** [make t gc] creates a new metrics record from the given [t] and [gc]
+    information. *)
+val make : Proc.Times.t -> Gc.stat -> (float, int) t
+
+(** [map ~f ~g m] applies [f] to the float fields and [g] to the int fields of
+    [m]. *)
+val map :
+     f:('float -> 'float_)
+  -> g:('int -> 'int_)
+  -> ('float, 'int) t
+  -> ('float_, 'int_) t
+
+(** [unzip m] takes a list of metrics [m] and returns a records with the lists
+    of values for each field. This is particularly convenient when serialising
+    to json. *)
+val unzip : ('float, 'int) t list -> ('float list, 'int list) t