unikernel/duniverse/dune_/bench/micro/memo_bench/benchmarks.ml

@@ -0,0 +1,174 @@
+open Stdune
+
+let invalidation_acc = ref Memo.Invalidation.empty
+
+module Memo = struct
+  include Memo
+
+  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.run build in
+    Fiber.run fiber ~iter:(fun _ -> failwith "deadlock?")
+  ;;
+
+  let memoize t =
+    let l = Memo.lazy_ ~cutoff:(fun _ _ -> false) (fun () -> t) in
+    Memo.of_thunk (fun () -> Memo.Lazy.force l)
+  ;;
+
+  let map2 x y ~f =
+    map ~f:(fun (x, y) -> f x y) (Memo.fork_and_join (fun () -> x) (fun () -> y))
+  ;;
+
+  let all l = Memo.all_concurrently l
+end
+
+let run tenacious = Memo.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.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.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 Memo.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:(Memo.return 0)
+        (List.init 1 ~f:(fun _i -> ()))
+        ~f:(fun acc () ->
+          Memo.bind acc ~f:(fun acc -> Memo.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:(Memo.return 0)
+        (List.init 20 ~f:(fun _i -> ()))
+        ~f:(fun acc () ->
+          Memo.bind acc ~f:(fun acc -> Memo.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 = Memo.memoize (Var.read v) in
+    ( v
+    , List.fold_left
+        ~init:read_v
+        (List.init 30 ~f:(fun _i -> ()))
+        ~f:(fun acc () ->
+          let node = Memo.memoize acc in
+          Memo.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
+        Memo.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 ->
+        Memo.memoize
+          (Memo.all
+             (List.mapi inputs ~f:(fun j x -> Memo.map x ~f:(fun x -> matrix i j * x)))
+           |> Memo.map ~f:(List.fold_left ~init:0 ~f:( + ))))
+    in
+    first_var, Memo.memoize (Memo.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 () ->
+          Memo.memoize (Memo.bind acc ~f:(fun x -> Memo.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 ()

unikernel/duniverse/dune_/bench/micro/memo_bench/dune

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

unikernel/duniverse/dune_/bench/micro/memo_bench/memo_intf.ml

@@ -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 Memo : 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 Memo.t
+
+    (** peek once without registering interest in future updates *)
+    val peek : 'a t -> 'a
+  end
+
+  val run : 'a Memo.t -> 'a
+  val make_counter : unit -> int Memo.t * (unit -> unit)
+end

unikernel/duniverse/dune_/bench/micro/memo_bench/memo_tests_env.ml

@@ -0,0 +1,121 @@
+module Io = struct
+  type 'a t = 'a Fiber.t
+
+  let of_thunk f = Fiber.of_thunk f
+  let map t ~f = Fiber.map t ~f
+  let bind t ~f = Fiber.bind t ~f:(fun x -> f x)
+  let return x = Fiber.return x
+
+  module Ivar = struct
+    include Fiber.Ivar
+
+    let read x = read x
+    let fill x v = fill x v
+  end
+
+  module Let_syntax = struct
+    let ( let+ ) x f = map x ~f
+    let ( let* ) x f = bind x ~f
+    let return = return
+  end
+end
+
+let invalidation_acc = ref Memo.Invalidation.empty
+
+module Memo = struct
+  include Memo
+
+  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.run build in
+    Fiber.run fiber ~iter:(fun _ -> failwith "deadlock?")
+  ;;
+
+  let of_io f = Memo.of_reproducible_fiber (Fiber.of_thunk f)
+
+  let memoize t =
+    let l = Memo.lazy_ ~cutoff:(fun _ _ -> false) (fun () -> t) in
+    Memo.of_thunk (fun () -> Memo.Lazy.force l)
+  ;;
+
+  let map2 x y ~f =
+    map ~f:(fun (x, y) -> f x y) (Memo.fork_and_join (fun () -> x) (fun () -> y))
+  ;;
+
+  let all l = Memo.all_concurrently l
+
+  module Glass = struct
+    type t = (unit, unit) Memo.Cell.t
+
+    let create () = Memo.lazy_cell ~cutoff:(fun _ _ -> false) (fun () -> Memo.return ())
+
+    let break (t : t) =
+      invalidation_acc
+      := Memo.Invalidation.combine
+           (Memo.Cell.invalidate ~reason:Memo.Invalidation.Reason.Test t)
+           !invalidation_acc
+    ;;
+  end
+
+  let of_glass (g : Glass.t) v =
+    Memo.of_thunk (fun () -> Memo.map (Memo.Cell.read g) ~f:(fun () -> v))
+  ;;
+
+  let of_thunk f = Memo.of_reproducible_fiber (Fiber.of_thunk (fun () -> Memo.run (f ())))
+
+  module Let_syntax = struct
+    let ( let+ ) x f = map x ~f
+    let ( let* ) x f = bind x ~f
+    let return = return
+  end
+end
+
+let run tenacious = Memo.exec tenacious
+
+module Glass = Memo.Glass
+
+let make_counter () =
+  let r = ref 0 in
+  let glass = Glass.create () in
+  let break () = Glass.break glass in
+  ( Memo.map
+      (Memo.of_thunk (fun () -> Memo.Cell.read glass))
+      ~f:(fun () ->
+        incr r;
+        !r)
+  , break )
+;;
+
+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.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.of_thunk (fun () -> Memo.Cell.read t.cell)
+  let peek t = !(t.value)
+end