Merge branch 'main' into add-native-pack-linker-variable

Author: TheLortex

bench/bench.ml

@@ -143,11 +143,15 @@ let () =
     stat.st_size
   in
   let results =
-    [ { Output.name = "clean_build"
-      ; metrics = [ ("time", `Float clean, "secs") ]
+    [ { Output.name = "Build times"
+      ; metrics =
+          [ ("Clean build time", `Float clean, "secs")
+          ; ("Null build time", `List zero, "secs")
+          ]
+      }
+    ; { Output.name = "Misc"
+      ; metrics = [ ("Size of dune.exe", `Int size, "bytes") ]
       }
-    ; { Output.name = "zero_build"; metrics = [ ("time", `List zero, "secs") ] }
-    ; { Output.name = "dune_size"; metrics = [ ("size", `Int size, "bytes") ] }
     ]
   in
   let version = 2 in

bench/micro/dune

@@ -25,3 +25,9 @@
  (allow_overlapping_dependencies)
  (modules fiber_bench_main)
  (libraries fiber_bench core_bench.inline_benchmarks))
+
+(executable
+ (name memo_bench_main)
+ (allow_overlapping_dependencies)
+ (modules memo_bench_main)
+ (libraries memo_bench core_bench.inline_benchmarks))

bench/micro/memo_bench/benchmarks.ml

@@ -0,0 +1,194 @@
+open Stdune
+
+let invalidation_acc = ref Memo.Invalidation.empty
+
+module Build = struct
+  include Memo.Build
+
+  let sample_count =
+    (* Count number of samples of all lifted computations, to allow simple
+       detection of looping tests executed by [run] *)
+    ref 0
+
+  let exec build =
+    (* not expected to be used in re-entrant way *)
+    sample_count := 0;
+    Memo.reset !invalidation_acc;
+    invalidation_acc := Memo.Invalidation.empty;
+    let fiber = Memo.Build.run build in
+    Fiber.run fiber ~iter:(fun _ -> failwith "deadlock?")
+
+  let memoize t =
+    let l = Memo.lazy_ ~cutoff:(fun _ _ -> false) (fun () -> t) in
+    Memo.Build.of_thunk (fun () -> Memo.Lazy.force l)
+
+  let map2 x y ~f =
+    map
+      ~f:(fun (x, y) -> f x y)
+      (Memo.Build.fork_and_join (fun () -> x) (fun () -> y))
+
+  let all l = Memo.Build.all_concurrently l
+end
+
+let run tenacious = Build.exec tenacious
+
+module Var = struct
+  type 'a t =
+    { value : 'a ref
+    ; cell : (unit, 'a) Memo.Cell.t
+    }
+
+  let create value =
+    let value = ref value in
+    { value
+    ; cell =
+        Memo.lazy_cell
+          ~cutoff:(fun _ _ -> false)
+          (fun () -> Memo.Build.return !value)
+    }
+
+  let set t v =
+    t.value := v;
+    invalidation_acc :=
+      Memo.Invalidation.combine !invalidation_acc
+        (Memo.Cell.invalidate ~reason:Memo.Invalidation.Reason.Test t.cell)
+
+  let read t = Memo.Build.of_thunk (fun () -> Memo.Cell.read t.cell)
+
+  let peek t = !(t.value)
+end
+
+let incr v = Var.set v (Var.peek v)
+
+module Case = struct
+  (* The first [unit] it to delay the creation of functions until benchmarking
+     is ready to run. *)
+  type 'a t =
+    { create_and_compute : unit -> unit -> 'a
+    ; incr_and_recompute : unit -> unit -> 'a
+    ; restore_from_cache : unit -> unit -> 'a
+    }
+
+  let create (f : unit -> _ Var.t * 'a Build.t) : 'a t =
+    let create_and_compute () () = run (f () |> snd) in
+    let incr_and_recompute () =
+      let var, build = f () in
+      let (_ : 'a) = run build in
+      fun () ->
+        incr var;
+        run build
+    in
+    let restore_from_cache () =
+      let build = f () |> snd in
+      let (_ : 'a) = run build in
+      fun () -> run build
+    in
+    { create_and_compute; incr_and_recompute; restore_from_cache }
+end
+
+let one_bind =
+  Case.create (fun () ->
+      let v = Var.create 0 in
+      ( v
+      , List.fold_left ~init:(Build.return 0)
+          (List.init 1 ~f:(fun _i -> ()))
+          ~f:(fun acc () ->
+            Build.bind acc ~f:(fun acc ->
+                Build.map (Var.read v) ~f:(fun v -> acc + v))) ))
+
+let%bench_fun "1-bind (create and compute)" = one_bind.create_and_compute ()
+
+let%bench_fun "1-bind (incr and recompute)" = one_bind.incr_and_recompute ()
+
+let%bench_fun "1-bind (restore from cache)" = one_bind.restore_from_cache ()
+
+let twenty_reads =
+  Case.create (fun () ->
+      let v = Var.create 0 in
+      ( v
+      , List.fold_left ~init:(Build.return 0)
+          (List.init 20 ~f:(fun _i -> ()))
+          ~f:(fun acc () ->
+            Build.bind acc ~f:(fun acc ->
+                Build.map (Var.read v) ~f:(fun v -> acc + v))) ))
+
+let%bench_fun "20-reads (create and compute)" =
+  twenty_reads.create_and_compute ()
+
+let%bench_fun "20-reads (incr and recompute)" =
+  twenty_reads.incr_and_recompute ()
+
+let%bench_fun "20-reads (restore from cache)" =
+  twenty_reads.restore_from_cache ()
+
+let clique =
+  Case.create (fun () ->
+      let v = Var.create 0 in
+      let read_v = Build.memoize (Var.read v) in
+      ( v
+      , List.fold_left ~init:read_v
+          (List.init 30 ~f:(fun _i -> ()))
+          ~f:(fun acc () ->
+            let node = Build.memoize acc in
+            Build.map2 node acc ~f:( + )) ))
+
+let%bench_fun "clique (create and compute)" = clique.create_and_compute ()
+
+let%bench_fun "clique (incr and recompute)" = clique.incr_and_recompute ()
+
+let%bench_fun "clique (restore from cache)" = clique.restore_from_cache ()
+
+let bipartite =
+  Case.create (fun () ->
+      let first_var = Var.create 0 in
+      let inputs =
+        List.init 30 ~f:(fun i ->
+            let v =
+              if i = 0 then
+                first_var
+              else
+                Var.create 0
+            in
+            Build.memoize (Var.read v))
+      in
+      let matrix i j =
+        if i = j then
+          1
+        else
+          0
+      in
+      let outputs =
+        List.init 30 ~f:(fun i ->
+            Build.memoize
+              (Build.all
+                 (List.mapi inputs ~f:(fun j x ->
+                      Build.map x ~f:(fun x -> matrix i j * x)))
+              |> Build.map ~f:(List.fold_left ~init:0 ~f:( + ))))
+      in
+      (first_var, Build.memoize (Build.all outputs)))
+
+let%bench_fun "bipartite (create and compute)" = bipartite.create_and_compute ()
+
+let%bench_fun "bipartite (incr and recompute)" = bipartite.incr_and_recompute ()
+
+let%bench_fun "bipartite (restore from cache)" = bipartite.restore_from_cache ()
+
+let memo_diamonds =
+  Case.create (fun () ->
+      let v = Var.create 0 in
+      ( v
+      , List.fold_left ~init:(Var.read v)
+          (List.init 20 ~f:(fun _i -> ()))
+          ~f:(fun acc () ->
+            Build.memoize
+              (Build.bind acc ~f:(fun x -> Build.map acc ~f:(fun y -> x + y))))
+      ))
+
+let%bench_fun "memo diamonds (create and compute)" =
+  memo_diamonds.create_and_compute ()
+
+let%bench_fun "memo diamonds (incr and recompute)" =
+  memo_diamonds.incr_and_recompute ()
+
+let%bench_fun "memo diamonds (restore from cache)" =
+  memo_diamonds.restore_from_cache ()

bench/micro/memo_bench/benchmarks.mli

@@ -0,0 +1,6 @@
+(library
+ (name memo_bench)
+ (library_flags -linkall)
+ (preprocess
+  (pps ppx_bench))
+ (libraries fiber stdune memo core_bench.inline_benchmarks))

bench/micro/memo_bench/dune

@@ -0,0 +1,62 @@
+module type Monad_intf = sig
+  type 'a t
+
+  val return : 'a -> 'a t
+  val bind : 'a t -> f:('a -> 'b t) -> 'b t
+  val map : 'a t -> f:('a -> 'b) -> 'b t
+
+  module Let_syntax : sig
+    val return : 'a -> 'a t
+    val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
+    val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
+  end
+end
+
+module type Test_env = sig
+  module Glass : sig
+    type t
+
+    val create : unit -> t
+    val break : t -> unit
+  end
+
+  module Io : sig
+    include Monad_intf
+
+    module Ivar : sig
+      type 'a io := 'a t
+      type 'a t
+
+      val create : unit -> 'a t
+      val read : 'a t -> 'a io
+      val fill : 'a t -> 'a -> unit io
+    end
+
+    val of_thunk : (unit -> 'a t) -> 'a t
+  end
+
+  module Build : sig
+    include Monad_intf
+
+    val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t
+    val all : 'a t list -> 'a list t
+    val of_glass : Glass.t -> 'a -> 'a t
+    val of_thunk : (unit -> 'a t) -> 'a t
+    val of_io : (unit -> 'a Io.t) -> 'a t
+    val memoize : 'a t -> 'a t
+  end
+
+  module Var : sig
+    type 'a t
+
+    val create : 'a -> 'a t
+    val set : 'a t -> 'a -> unit
+    val read : 'a t -> 'a Build.t
+
+    (** peek once without registering interest in future updates *)
+    val peek : 'a t -> 'a
+  end
+
+  val run : 'a Build.t -> 'a
+  val make_counter : unit -> int Build.t * (unit -> unit)
+end