Add wasm_of_ocaml benchmarks with current-bench output

.gitignore

@@ -41,6 +41,7 @@ _build
 benchmarks/*.svg
 benchmarks/*.pdf
 benchmarks/__run
+benchmarks/__run_wasm
 benchmarks/build
 benchmarks/results
 benchmarks/config

CHANGES.md

@@ -8,6 +8,7 @@
 * Runtime: remove polyfill for Map to simplify MlObjectTable implementation (#1846)
 * Runtime: refactor caml_xmlhttprequest_create implementation (#1846)
 * Runtime: update constant imports to use `node:fs` module (#1850)
+* Misc: add a benchmarking suite for wasm_of_ocaml targeting [current-bench](https://github.com/ocurrent/current-bench)
 
 ## Bug fixes
 * Runtime: fix path normalization (#1848)

Makefile

@@ -34,4 +34,7 @@ installdoc:
 	git worktree add _wikidoc origin/wikidoc
 	rsync -av doc-dev/ _wikidoc/doc/dev/
 
-.PHONY: all tests tests-wasm test runtest runtests doc clean installdoc
+bench:
+	$(MAKE) -C benchmarks bench
+
+.PHONY: all tests tests-wasm test runtest runtests doc clean installdoc bench

bench.Dockerfile

@@ -0,0 +1,21 @@
+FROM ocaml/opam:debian-ocaml-5.3
+WORKDIR /bench-dir
+RUN sudo apt-get update && \
+    sudo apt-get install -qq -yy --no-install-recommends pkg-config libgmp-dev \
+      wget
+RUN sudo ln -sf /usr/bin/opam-2.3 /usr/bin/opam
+RUN opam remote add origin https://github.com/ocaml/opam-repository.git && \
+    opam update
+RUN wget https://nodejs.org/dist/v22.14.0/node-v22.14.0-linux-x64.tar.xz && \
+    tar xJvf node-v22.14.0-linux-x64.tar.xz
+ENV PATH="/bench-dir/node-v22.14.0-linux-x64/bin:$PATH"
+RUN wget https://github.com/WebAssembly/binaryen/releases/download/version_122/binaryen-version_122-x86_64-linux.tar.gz && \
+    tar xzvf binaryen-version_122-x86_64-linux.tar.gz
+ENV PATH="/bench-dir/binaryen-version_122/bin:$PATH"
+RUN opam install --fake binaryen-bin
+COPY --chown=opam:opam ./*.opam ./
+RUN opam pin -yn --with-version=dev .
+RUN opam install -y --deps-only js_of_ocaml-compiler
+COPY --chown=opam:opam . ./
+RUN opam install -y wasm_of_ocaml-compiler
+WORKDIR ./benchmarks

benchmarks/Makefile

@@ -10,6 +10,14 @@ GRAPHSEFF = time-effects.pdf size-effects.pdf size-bzip2-effects.pdf
 # For full benchs:
 all: _perf graphsnopr graphspr graphseff _noperf
 
+# This target is the one run by `current-bench`,
+# see https://github.com/ocurrent/current-bench
+.PHONY: bench
+bench: __run_wasm
+	$(REPORT) -format current-bench -config report-wasm-cb.config \
+	  -ylabel "Wasm_of_ocaml"
+
+
 graphsnopr: _noprecomp $(GRAPHSNOPR)
 
 graphspr: __precomp $(GRAPHSPR)
@@ -51,6 +59,10 @@ __run_effects:
 	$(RUN) -fast -nobyteopt -effects
 	touch __run_effects
 
+__run_wasm:
+	$(RUN) -nobyteopt -wasm -nojs -verbose
+	touch __run_wasm
+
 fastrun:
 	make _noprecomp
 	echo "======================== WARNING: fast benchs!"

benchmarks/common.ml

@@ -114,11 +114,46 @@ let code = "build"
 
 let hostname = Unix.gethostname ()
 
-let times = Filename.concat "results/times" hostname
+module Measure = struct
+  type t =
+    { name : string
+    ; units : string
+    ; description : string option
+    ; trend : string option
+    ; path : string
+    ; color : string option
+    }
+end
 
-let sizes = "results/sizes"
+let times =
+  Measure.
+    { name = "execution-time"
+    ; units = "s"
+    ; description = Some "Execution time"
+    ; trend = Some "lower-is-better"
+    ; path = Filename.concat "results/times" hostname
+    ; color = None
+    }
 
-let compiletimes = Filename.concat "results/compiletimes" hostname
+let sizes =
+  Measure.
+    { name = "code-size"
+    ; units = "B"
+    ; description = Some "Code size"
+    ; trend = Some "lower-is-better"
+    ; path = "results/sizes"
+    ; color = None
+    }
+
+let compiletimes =
+  Measure.
+    { name = "compile-time"
+    ; units = "s"
+    ; description = Some "Compile time"
+    ; trend = Some "lower-is-better"
+    ; path = Filename.concat "results/compiletimes" hostname
+    ; color = None
+    }
 
 module Spec : sig
   type t
@@ -139,6 +174,8 @@ module Spec : sig
 
   val js : t
 
+  val wasm : t
+
   val byte : t
 
   val opt : t
@@ -164,6 +201,8 @@ module Spec : sig
   val js_of_ocaml_call : t
 
   val js_of_ocaml_effects : t
+
+  val wasm_of_ocaml : t
 end = struct
   type t =
     { dir : string
@@ -202,6 +241,8 @@ end = struct
 
   let js = create "js" ".js"
 
+  let wasm = create "wasm" ".js"
+
   let byte = create "byte" ""
 
   let opt = create "opt" ""
@@ -227,6 +268,8 @@ end = struct
   let js_of_ocaml_call = create "nooptcall" ".js"
 
   let js_of_ocaml_effects = create "effects" ".js"
+
+  let wasm_of_ocaml = create "wasm_of_ocaml" ".js"
 end
 
 let rec mkdir d =
@@ -246,11 +289,11 @@ let need_update src dst =
 
 let measures_need_update code meas spec nm =
   let p = Spec.file ~root:code spec nm in
-  let m = Spec.file ~root:meas (Spec.no_ext spec) nm in
+  let m = Spec.file ~root:meas.Measure.path (Spec.no_ext spec) nm in
   need_update p m
 
-let read_measures meas spec nm =
-  let m = Spec.file ~root:meas (Spec.no_ext spec) nm in
+let read_measures path spec nm =
+  let m = Spec.file ~root:path (Spec.no_ext spec) nm in
   let l = ref [] in
   if Sys.file_exists m
   then (
@@ -265,9 +308,9 @@ let read_measures meas spec nm =
   else []
 
 let write_measures meas spec nm l =
-  let m = Spec.file ~root:meas (Spec.no_ext spec) nm in
-  let tmp = Spec.file ~root:meas (Spec.no_ext spec) "_tmp_" in
-  mkdir (Spec.dir ~root:meas spec);
+  let m = Spec.file ~root:meas.Measure.path (Spec.no_ext spec) nm in
+  let tmp = Spec.file ~root:meas.Measure.path (Spec.no_ext spec) "_tmp_" in
+  mkdir (Spec.dir ~root:meas.Measure.path spec);
   let ch = open_out tmp in
   List.iter ~f:(fun t -> Printf.fprintf ch "%f\n" t) (List.rev l);
   close_out ch;

benchmarks/dune

@@ -1,6 +1,6 @@
 (executables
  (names report run stripdebug)
- (libraries unix compiler-libs.bytecomp))
+ (libraries unix compiler-libs.bytecomp yojson))
 
 (alias
  (name default)

benchmarks/report-wasm-cb.config

@@ -0,0 +1 @@
+histogram times node wasm_of_ocaml #ffffff node

benchmarks/report.ml

@@ -29,7 +29,7 @@ let maximum = ref (-1.)
 
 let minimum = ref 0.
 
-let table = ref false
+let format : [ `Gnuplot | `Text | `Current_bench ] ref = ref `Gnuplot
 
 let omitted = ref []
 
@@ -65,23 +65,19 @@ let rec merge f l1 l2 =
 
 let merge_blank = List.map ~f:(fun (n2, v2) -> n2, (0.0, 0.0) :: v2)
 
-let read_column ?title ?color meas spec refe =
+let read_column ~measure path spec refe :
+    (Measure.t option list * (string * (float * float) list) list) option =
   let l =
     List.map
-      (Spec.find_names ~root:meas (Spec.no_ext spec))
+      (Spec.find_names ~root:path (Spec.no_ext spec))
       ~f:(fun nm ->
-        let l = read_measures meas spec nm in
+        let l = read_measures path spec nm in
         let a = Array.of_list l in
         let m, i = mean_with_confidence a in
         nm, [ m, i ])
   in
-  let nm =
-    match title with
-    | Some nm -> nm
-    | None -> Spec.dir ~root:meas (Spec.no_ext spec)
-  in
   if refe then reference := Some l;
-  Some ([ Some (nm, color) ], l)
+  Some ([ Some measure ], l)
 
 let read_blank_column () = None
 
@@ -144,7 +140,7 @@ let normalize (h, t) =
 let stats (h, t) =
   for i = 0 to List.length h - 1 do
     match List.nth h i with
-    | Some (nm, _) ->
+    | Some Measure.{ name = nm; _ } ->
         let l = List.map t ~f:(fun (_, l) -> fst (List.nth l i)) in
         let a = Array.of_list l in
         Array.sort a ~cmp:compare;
@@ -169,7 +165,7 @@ let text_output _no_header (h, t) =
   List.iter h ~f:(fun v ->
       let nm =
         match v with
-        | Some (nm, _) -> nm
+        | Some Measure.{ name; _ } -> name
         | None -> ""
       in
       Format.printf " - \"%s\"" nm);
@@ -223,11 +219,11 @@ let gnuplot_output ch no_header (h, t) =
   Printf.fprintf ch "plot";
   for i = 0 to n - 1 do
     match List.nth h i with
-    | Some (_, col) -> (
+    | Some Measure.{ color; _ } -> (
         if i > 0
         then Printf.fprintf ch ", \"-\" using 2:3 title columnhead lw 0"
         else Printf.fprintf ch " \"-\" using 2:3:xtic(1) title columnhead lw 0";
-        match col with
+        match color with
         | Some c -> Printf.fprintf ch " lc rgb '%s'" c
         | None -> ())
     | None ->
@@ -240,7 +236,7 @@ let gnuplot_output ch no_header (h, t) =
   for i = 0 to n - 1 do
     let nm =
       match List.nth h i with
-      | Some (nm, _) -> nm
+      | Some Measure.{ name; _ } -> name
       | None -> ""
     in
     Printf.fprintf ch "- \"%s\"\n" (escape_name_for_gnuplot nm);
@@ -268,32 +264,59 @@ let filter (h, t) =
 
 let output_table =
   let old_table = ref None in
-  fun _r (l : ((string * 'a option) option list * _) option list) f ->
+  fun _r (l : (Measure.t option list * _) option list) f ->
     let t = merge_columns l !old_table in
     old_table := Some (snd t);
     let t = filter t in
     let t = normalize t in
     stats t;
     f t
 
-let output_tables r conf =
+let current_bench_output
+    (ch : out_channel)
+    (_no_header : bool)
+    ((header : Measure.t option list), (t : (string * (float * float) list) list)) =
+  let suite_name = !ylabel in
+  let measure_descs =
+    List.map header ~f:(function
+      | None -> failwith "Blank columns are not supported with current-bench output."
+      | Some desc -> desc)
+  in
+  let metrics =
+    List.concat_map t ~f:(function test_name, measures ->
+        assert (List.length measures = List.length measure_descs);
+        List.map2 measure_descs measures ~f:(fun desc (m, _confidence_itvl) ->
+            let description =
+              Option.value desc.Measure.description ~default:desc.Measure.name
+            in
+            `Assoc
+              [ "name", `String (String.concat ~sep:" - " [ test_name; description ])
+              ; "value", `Float m
+              ; "units", `String desc.Measure.units
+              ]))
+  in
+  let results = `Assoc [ "name", `String "Microbenchmarks"; "metrics", `List metrics ] in
+  let json = `Assoc [ "name", `String suite_name; "results", `List [ results ] ] in
+  Yojson.Basic.to_channel ch json
+
+let output ~format r conf =
   let output_function, close =
-    if !table
-    then text_output, fun () -> ()
-    else if !script
-    then gnuplot_output stdout, fun () -> ()
-    else
-      let ch = Unix.open_process_out "gnuplot -persist" in
-      gnuplot_output ch, fun () -> close_out ch
+    match format with
+    | `Text -> text_output, fun () -> ()
+    | `Gnuplot when !script -> gnuplot_output stdout, fun () -> ()
+    | `Gnuplot ->
+        let ch = Unix.open_process_out "gnuplot -persist" in
+        gnuplot_output ch, fun () -> close_out ch
+    | `Current_bench -> current_bench_output stdout, fun () -> ()
   in
   let no_header = ref false in
   List.iter conf ~f:(fun conf ->
       output_table
         r
         (List.map conf ~f:(function
           | None -> read_blank_column ()
-          | Some (dir1, dir2, color, title, refe) ->
-              read_column ~title ~color dir1 (Spec.create dir2 "") refe))
+          | Some (dir1, dir2, measure, refe) ->
+              read_column ~measure dir1 (Spec.create dir2 "") refe))
         (output_function !no_header);
       no_header := true);
   close ()
@@ -315,12 +338,20 @@ let read_config () =
       String.sub l ~pos:0 ~len:i, String.sub l ~pos:(i + 1) ~len:(String.length l - i - 1)
     with Not_found -> l, ""
   in
-  let get_info dir0 rem refe =
+  let get_info measure rem refe =
+    let dir0 = measure.Measure.path in
     let dir1, rem = split_at_space rem in
     let dir2, rem = split_at_space rem in
     let color, title = split_at_space rem in
     let dir1 = if dir1 = "\"\"" then dir0 else dir0 ^ "/" ^ dir1 in
-    info := Some (dir1, dir2, color, title, refe) :: !info
+    let name = String.concat ~sep:"-" [ measure.Measure.name; title ] in
+    let description =
+      match measure.Measure.description with
+      | None -> None
+      | Some d -> Some (String.concat ~sep:", " [ d; title ])
+    in
+    let measure = Measure.{ measure with name; description; color = Some color } in
+    info := Some (dir1, dir2, measure, refe) :: !info
   in
   (try
      while true do
@@ -363,7 +394,16 @@ let _ =
     [ "-ref", Arg.Set_int nreference, "<col> use column <col> as the baseline"
     ; "-max", Arg.Set_float maximum, "<m> truncate graph at level <max>"
     ; "-min", Arg.Set_float minimum, "<m> truncate graph below level <min>"
-    ; "-table", Arg.Set table, " output a text table"
+    ; ( "-format"
+      , Arg.Symbol
+          ( [ "gnuplot"; "table"; "current-bench" ]
+          , function
+            | "gnuplot" -> format := `Gnuplot
+            | "table" -> format := `Text
+            | "current-bench" -> format := `Current_bench
+            | _ -> assert false )
+      , " output format: a Gnuplot graph, a text table, or a JSON object for use by \
+         current-bench (default gnuplot)" )
     ; ( "-omit"
       , Arg.String (fun s -> omitted := split_on_char s ~sep:',' @ !omitted)
       , " omit the given benchmark" )
@@ -390,7 +430,7 @@ let _ =
     (fun s -> raise (Arg.Bad (Format.sprintf "unknown option `%s'" s)))
     (Format.sprintf "Usage: %s [options]" Sys.argv.(0));
   let r, conf = read_config () in
-  output_tables r conf
+  output ~format:!format r conf
 
 (*
 http://hacks.mozilla.org/2009/07/tracemonkey-overview/