wip

ocaml/tests/bench/bechamel_simple_cli.ml

@@ -1,58 +1,201 @@
 (* based on bechamel example code *)
 open Bechamel
 open Toolkit
+open Cmdliner
 
-let instances = Instance.[monotonic_clock; minor_allocated; major_allocated]
+let span =
+  let parse s =
+    try Ok (s |> Float.of_string |> Bechamel.Time.second)
+    with e -> Error (Printexc.to_string e)
+  in
+  let print ppf t =
+    Format.fprintf ppf "%fs"
+      ((t |> Bechamel.Time.span_to_uint64_ns |> Int64.to_float) *. 1e-9)
+  in
+  Arg.conv' ~docv:"SECONDS" (parse, print)
+
+let measures =
+  let witness =
+    Instance.
+      [
+        minor_allocated
+      ; major_allocated
+      ; promoted
+      ; compaction
+      ; minor_collection
+      ; major_collection
+      ; monotonic_clock
+      ]
+    (* cannot add the perf measures because they instantly fail when not root even when we're not using them,
+       just referencing their name causes the module to be initialized
+    *)
+    |> List.map (fun w -> (Measure.label w, w))
+    |> Arg.enum
+  in
+  Arg.(
+    value
+    & opt (list witness)
+        Instance.[monotonic_clock; minor_allocated; major_allocated]
+    & info ["measures"] ~doc:"What measurements to record" ~docv:"MEASURE"
+  )
 
 let cfg =
-  (* stabilize:true would be the default but it can cause function runtimes to be 10x the amount measured without.
-     It is also confusing for flamegraphs because the GC will show up much more frequently than in reality
-     due to the thousands of repeated calls.
-  *)
-  Benchmark.cfg
-    ~quota:Time.(second 5.0)
-    ~start:10 ~stabilize:false ~compaction:false ()
-
-let benchmark tests = Benchmark.all cfg instances tests
-
-let analyze raw_results =
-  let ols =
-    Analyze.ols ~r_square:true ~bootstrap:0 ~predictors:[|Measure.run|]
+  let limit =
+    Arg.(
+      value
+      & opt (some int) None
+      & info ["limit"] ~doc:"maximum number of samples allowed" ~docv:"SAMPLES"
+    )
+  and quota =
+    Arg.(
+      value
+      & opt span (Time.second 5.0)
+      & info ["quota"] ~doc:"maximum time allowed" ~docv:"SECONDS"
+    )
+  and kde =
+    Arg.(
+      value
+      & opt (some int) None
+      & info ["kde"]
+          ~doc:
+            "additional measurements for KDE and histogram display. Actual \
+             time limit will be 2*quota"
+    )
+  and stabilize =
+    Arg.(
+      value
+      & opt bool false
+      & info ["stabilize"]
+          ~doc:
+            "stabilize the GC before each run. Beware that although \
+             measurements will be more stable they may sometimes slow down \
+             even 10x the measured value."
+    )
+  and start =
+    Arg.(
+      value
+      & opt (some int) None
+      & info ["start"] ~doc:"the first value of the run metric"
+    )
+  and compaction =
+    Arg.(
+      value
+      & opt bool false
+      & info ["compaction"]
+          ~doc:"whether to enable GC compaction during the benchmark"
+    )
+  in
+  let cfg limit quota kde stabilize start compaction =
+    Benchmark.cfg ?limit ~quota ~kde ~stabilize ?start ~compaction ()
   in
+  Term.(const cfg $ limit $ quota $ kde $ stabilize $ start $ compaction)
+
+let analysis =
+  let bootstrap =
+    Arg.(
+      value
+      & opt int 0
+      & info ["bootstrap"]
+          ~doc:
+            "how many times to resample the measurements (needed for \
+             confidence interval calculations)"
+    )
+  in
+  let analyze bootstrap =
+    Analyze.ols ~r_square:true ~bootstrap ~predictors:[|Measure.run|]
+  in
+  Term.(const analyze $ bootstrap)
+
+let analyze (_, measures, analysis, _) raw_results =
   let results =
-    List.map (fun instance -> Analyze.all ols instance raw_results) instances
+    List.map (fun measure -> Analyze.all analysis measure raw_results) measures
   in
-  (Analyze.merge ols instances results, raw_results)
+  (Analyze.merge analysis measures results, raw_results)
 
 let img (window, results) =
   Bechamel_notty.Multiple.image_of_ols_results ~rect:window
     ~predictor:Measure.run results
 
 open Notty_unix
 
-let show_results results =
+type output = Tty | Json | Text
+
+let dump_hashtbl name pp_elt =
+  Fmt.Dump.iter_bindings Hashtbl.iter Fmt.(any name) Fmt.string pp_elt
+
+let dump_measure ppf m =
+  Format.fprintf ppf "%s: %s" (Measure.label m) (Measure.unit m)
+
+let show_results ((_, measures, _, (output, json_file)) as t) results =
+  let results, raw_results = analyze t results in
   let () =
-    List.iter (fun i -> Bechamel_notty.Unit.add i (Measure.unit i)) instances
-  in
+    match output with
+    | Tty ->
+        let () =
+          List.iter
+            (fun i -> Bechamel_notty.Unit.add i (Measure.unit i))
+            measures
+        in
 
-  let results, _ = results |> analyze in
+        let window =
+          match winsize Unix.stdout with
+          | Some (w, h) ->
+              {Bechamel_notty.w; h}
+          | None ->
+              {Bechamel_notty.w= 80; h= 1}
+        in
+        img (window, results) |> eol |> output_image
+    | Json ->
+        ()
+    | Text ->
+        Format.printf "Measures: %a@." Fmt.Dump.(list dump_measure) measures ;
 
-  let window =
-    match winsize Unix.stdout with
-    | Some (w, h) ->
-        {Bechamel_notty.w; h}
-    | None ->
-        {Bechamel_notty.w= 80; h= 1}
+        Format.printf "%a@."
+          (dump_hashtbl "results" (dump_hashtbl "result" Analyze.OLS.pp))
+          results
   in
-  img (window, results) |> eol |> output_image
-
-let cli tests =
-  Format.printf "@,Running benchmarks@." ;
-  let results = tests |> benchmark in
-  show_results results
+  let file = open_out json_file in
+  let finally () = close_out file in
+  Fun.protect ~finally @@ fun () ->
+  let open Bechamel_js in
+  match
+    emit ~dst:(Channel file)
+      (fun _ -> Ok ())
+      ~compare ~x_label:Measure.run
+      ~y_label:(Measure.label Instance.monotonic_clock)
+      (results, raw_results)
+  with
+  | Ok () ->
+      Format.printf "Saved JSON results to %s@." json_file
+  | Error (`Msg err) ->
+      invalid_arg err
 
 let results = Hashtbl.create 47
 
+let benchmark_cli =
+  let open Cmdliner in
+  let output =
+    Arg.(
+      value
+      & opt (enum [("tty", Tty); ("json", Json); ("text", Text)]) Tty
+      & info ["output"]
+    )
+  in
+  let json_file =
+    let self = Sys.executable_name |> Filename.basename in
+    Arg.(
+      value
+      & opt string (self ^ ".json")
+      & info ["output-json"] ~doc:"JSON file to write results to"
+    )
+  in
+  let tuple a b c output json_file =
+    let t = (a, b, c, (output, json_file)) in
+    let () = at_exit (fun () -> show_results t results) in
+    t
+  in
+  Term.(const tuple $ cfg $ measures $ analysis $ output $ json_file)
+
 open Alcotest.V1
 
 let to_alcotest tests =
@@ -63,13 +206,12 @@ let to_alcotest tests =
     |> Test.elements
     |> List.map @@ fun test ->
        let name = Test.Elt.name test in
-       test_case name `Slow @@ fun () ->
-       Hashtbl.add results name @@ Benchmark.run cfg instances test
+       test_case name `Slow @@ fun (cfg, measures, _, _) ->
+       Hashtbl.add results name @@ Benchmark.run cfg measures test
   in
   (name, tests)
 
 let alcotest_cli tests =
   let name = Bechamel.Test.name tests in
   (* Alcotest exits when filtering is used even with 'and_exit:false', so setup an at_exit handler to show results *)
-  let () = at_exit (fun () -> show_results results) in
-  run ~show_errors:true name [to_alcotest tests]
+  run_with_args ~show_errors:true name benchmark_cli [to_alcotest tests]

ocaml/tests/bench/bench_concurrent.ml

@@ -484,7 +484,8 @@ let benchmarks =
           Pam.authorize pam "pamtest-edvint" "pamtest-edvint"
         )
     ; Test.make ~name:"overhead" (Staged.stage ignore)
-    ; Test.make ~name:"parallel_c_work" (Staged.stage Bench_concurrent_util.parallel_c_work)
+    ; Test.make ~name:"parallel_c_work"
+        (Staged.stage Bench_concurrent_util.parallel_c_work)
     ; (let module T = TestBarrier (BarrierPreloaded) in
       T.test
       )

ocaml/tests/bench/bench_concurrent_util.ml

@@ -20,12 +20,12 @@ let parallel_c_work =
   fun ms ->
   let (_:int) = Sys.opaque_identity (bench_fixed_work (ms * n)) in ()*)
 
-(* 
-  So this will change with different compiler versions or CPU architectures,
-  but will be fixed on a given system.
+(*
+   So this will change with different compiler versions or CPU architectures,
+   but will be fixed on a given system.
 *)
 let parallel_c_work () =
-  let (_:int) = Sys.opaque_identity @@ bench_fixed_work @@ 4_000_000 in
+  let (_ : int) = Sys.opaque_identity @@ bench_fixed_work @@ 4_000_000 in
   ()
 
 let semaphore () = Semaphore.Binary.make false

ocaml/tests/bench/dune

@@ -1,7 +1,7 @@
 (library
  (name bechamel_simple_cli)
  (modules bechamel_simple_cli bench_concurrent_util)
- (libraries bechamel bechamel-notty bechamel.monotonic_clock notty.unix threads.posix alcotest)
+ (libraries bechamel bechamel-js bechamel-notty bechamel.monotonic_clock notty.unix threads.posix alcotest)
  (foreign_stubs
   (language c)
   (names bench_concurrent_stubs)
@@ -39,4 +39,4 @@
  (modes exe)
  (optional)
  (libraries pam mtime mtime.clock.os)
-)
+)

ocaml/tests/bench/scale_auth.ml

@@ -62,9 +62,11 @@ let () =
       let handle = Pam.authenticate_start () in
       (* warm up PAM, there is a sleep(1) inside otherwise on init race condition *)
       let () = Pam.authorize handle !user !password in
-      if !warmup_close then begin Pam.authenticate_stop handle; None end
-      else
-      Some handle
+      if !warmup_close then (
+        Pam.authenticate_stop handle ;
+        None
+      ) else
+        Some handle
     else
       None
   in