unikernel/duniverse/dune_/bench/micro/copyfile.ml

@@ -0,0 +1,28 @@
+open Stdune
+
+let dir =
+  (if Array.length Sys.argv > 1
+   then (
+     let dir = Path.of_filename_relative_to_initial_cwd Sys.argv.(1) in
+     Temp.temp_in_dir Dir ~dir)
+   else Temp.create Dir)
+    ~prefix:"copyfile"
+    ~suffix:"bench"
+;;
+
+let contents =
+  let len =
+    if Array.length Sys.argv > 2 then Int.of_string_exn Sys.argv.(2) else 50_000
+  in
+  String.make len '0'
+;;
+
+let () =
+  let src = Path.relative dir "initial" in
+  Io.write_file (Path.relative dir "initial") contents;
+  let chmod _ = 444 in
+  for i = 1 to 10_000 do
+    let dst = Path.relative dir (sprintf "dst-%d" i) in
+    Io.copy_file ~chmod ~src ~dst ()
+  done
+;;

unikernel/duniverse/dune_/bench/micro/digest_bench.ml

@@ -0,0 +1,24 @@
+open Stdune
+module Digest = Dune_digest
+module Caml = Stdlib
+
+let create_file size =
+  let name = Printf.sprintf "digest-bench-%d" size in
+  let out = open_out name in
+  for _ = 1 to size do
+    output_char out 'X'
+  done;
+  close_out out;
+  at_exit (fun () -> Unix.unlink name);
+  name
+;;
+
+let%bench_fun ("string" [@indexed len = [ 10; 100; 1_000; 10_000; 1_000_000 ]]) =
+  let s = String.make len 'x' in
+  fun () -> ignore (Digest.string s)
+;;
+
+let%bench_fun ("file" [@indexed len = [ 10; 100; 1_000; 10_000; 100_000; 1_000_000 ]]) =
+  let f = Path.of_filename_relative_to_initial_cwd (create_file len) in
+  fun () -> ignore (Digest.file f)
+;;

unikernel/duniverse/dune_/bench/micro/digest_bench_main.ml

@@ -0,0 +1 @@
+Inline_benchmarks_public.Runner.main ~libname:"digest_bench"

unikernel/duniverse/dune_/bench/micro/dune

@@ -0,0 +1,57 @@
+(executable
+ (name copyfile)
+ (modules copyfile)
+ (libraries stdune))
+
+(executable
+ (name main)
+ (modules main)
+ (libraries dune_bench core_bench.inline_benchmarks))
+
+(executable
+ (name memo_bench_main)
+ (allow_overlapping_dependencies)
+ (modules memo_bench_main)
+ (libraries memo_bench core_bench.inline_benchmarks))
+
+(library
+ (name thread_pool_bench)
+ (modules thread_pool_bench)
+ (library_flags -linkall)
+ (preprocess
+  (pps ppx_bench))
+ (libraries dune_thread_pool unix threads.posix core_bench.inline_benchmarks))
+
+(executable
+ (name thread_pool_bench_main)
+ (allow_overlapping_dependencies)
+ (modules thread_pool_bench_main)
+ (libraries thread_pool_bench core_bench.inline_benchmarks))
+
+(library
+ (name digest_bench)
+ (modules digest_bench)
+ (library_flags -linkall)
+ (preprocess
+  (pps ppx_bench))
+ (libraries dune_digest stdune unix core_bench.inline_benchmarks))
+
+(executable
+ (name digest_bench_main)
+ (allow_overlapping_dependencies)
+ (modules digest_bench_main)
+ (libraries digest_bench core_bench.inline_benchmarks))
+
+(library
+ (name path_bench)
+ (modules path_bench)
+ (library_flags -linkall)
+ (preprocess
+  (pps ppx_bench))
+ (libraries base stdune core_bench.inline_benchmarks))
+
+(executable
+ (name path_bench_main)
+ (allow_overlapping_dependencies)
+ (modules path_bench_main)
+ (libraries path_bench core_bench.inline_benchmarks))

unikernel/duniverse/dune_/bench/micro/dune_bench/dune

@@ -0,0 +1,6 @@
+(library
+ (name dune_bench)
+ (libraries stdune fiber dune_engine dune_rules)
+ (library_flags -linkall)
+ (preprocess
+  (pps ppx_bench)))

unikernel/duniverse/dune_/bench/micro/dune_bench/scheduler_bench.ml

@@ -0,0 +1,39 @@
+(* Benchmark the scheduler *)
+
+open Stdune
+open Dune_engine
+module Caml = Stdlib
+
+let config =
+  Dune_engine.Clflags.display := Short;
+  { Scheduler.Config.concurrency = 1
+  ; stats = None
+  ; print_ctrl_c_warning = false
+  ; watch_exclusions = []
+  }
+;;
+
+let setup =
+  lazy
+    (Path.set_root (Path.External.cwd ());
+     Path.Build.set_build_dir (Path.Outside_build_dir.of_string "_build"))
+;;
+
+let prog = Option.value_exn (Bin.which ~path:(Env_path.path Env.initial) "true")
+let run () = Process.run ~display:Quiet ~env:Env.initial Strict prog []
+
+let go ~jobs fiber =
+  Scheduler.Run.go ~on_event:(fun _ _ -> ()) { config with concurrency = jobs } fiber
+;;
+
+let%bench_fun "single" =
+  Lazy.force setup;
+  fun () -> go run ~jobs:1
+;;
+
+let l = List.init 100 ~f:ignore
+
+let%bench_fun ("many" [@indexed jobs = [ 1; 2; 4; 8 ]]) =
+  Lazy.force setup;
+  fun () -> go ~jobs (fun () -> Fiber.parallel_iter l ~f:run)
+;;

unikernel/duniverse/dune_/bench/micro/main.ml

@@ -0,0 +1 @@
+Inline_benchmarks_public.Runner.main ~libname:"dune_bench"

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

unikernel/duniverse/dune_/bench/micro/memo_bench_main.ml

@@ -0,0 +1 @@
+Inline_benchmarks_public.Runner.main ~libname:"memo_bench"

unikernel/duniverse/dune_/bench/micro/path_bench.ml

@@ -0,0 +1,67 @@
+module Path = Stdune.Path
+module Fpath = Stdune.Fpath
+open Base
+module Filename = Stdlib.Filename
+
+let () = Path.Build.set_build_dir (In_source_dir Path.Source.(relative root "_build"))
+let root = "."
+let short_path = "a/b/c"
+let long_path = List.init 20 ~f:(fun _ -> "foo-bar-baz") |> String.concat ~sep:"/"
+
+let%bench_fun
+    ("is_root"
+     [@params path = [ "root", "."; "short path", short_path; "long path", long_path ]])
+  =
+  fun () -> ignore (Fpath.is_root path)
+;;
+
+let%bench_fun
+    ("reach"
+     [@params
+       t
+       = [ "from root long path", (long_path, root)
+         ; "from root short path", (short_path, root)
+         ; "reach root from short path", (root, short_path)
+         ; "reach root from long path", (root, long_path)
+         ; ( "reach long path from similar long path"
+           , (Filename.concat long_path "a", Filename.concat long_path "b") )
+         ; ( "reach short path from similar short path"
+           , (Filename.concat short_path "a", Filename.concat short_path "b") )
+         ]])
+  =
+  let t, from = t in
+  let t = Path.of_string t in
+  let from = Path.of_string from in
+  fun () -> ignore (Path.reach t ~from)
+;;
+
+let%bench_fun
+    ("Path.Local.relative"
+     [@params
+       t
+       = [ "left root", (".", long_path)
+         ; "right root", (long_path, ".")
+         ; "short paths", (short_path, short_path)
+         ; "long paths", (long_path, long_path)
+         ]])
+  =
+  let x, y = t in
+  let x = Path.Local.of_string x in
+  fun () -> ignore (Path.Local.relative x y)
+;;
+
+let%bench_fun
+    ("Path.Local.append"
+     [@params
+       t
+       = [ "left root", (".", long_path)
+         ; "right root", (long_path, ".")
+         ; "short paths", (short_path, short_path)
+         ; "long paths", (long_path, long_path)
+         ]])
+  =
+  let x, y = t in
+  let x = Path.Local.of_string x in
+  let y = Path.Local.of_string y in
+  fun () -> ignore (Path.Local.append x y)
+;;

unikernel/duniverse/dune_/bench/micro/path_bench_main.ml

@@ -0,0 +1 @@
+Inline_benchmarks_public.Runner.main ~libname:"path_bench"

unikernel/duniverse/dune_/bench/micro/runner.sh

@@ -0,0 +1,12 @@
+#!/usr/bin/env sh
+export BENCHMARKS_RUNNER=TRUE
+case "$1" in
+  "dune" ) test="dune_bench"; main="main";;
+  "memo" ) test="memo_bench"; main="memo_bench_main";;
+  "thread_pool" ) test="thread_pool_bench"; main="thread_pool_bench_main";;
+  "digest" ) test="digest_bench"; main="digest_bench_main";;
+  "path" ) test="path_bench"; main="path_bench_main";;
+esac
+shift;
+export BENCH_LIB="$test"
+exec ./dune.exe exec --release -- "./bench/micro/$main.exe" -fork -run-without-cross-library-inlining "$@"

unikernel/duniverse/dune_/bench/micro/thread_pool_bench.ml

@@ -0,0 +1,47 @@
+open Dune_thread_pool
+
+let spawn_thread f = ignore (Thread.create f ())
+
+let%bench "almost no-op" =
+  let tp = Thread_pool.create ~min_workers:10 ~max_workers:50 ~spawn_thread in
+  let tasks = 50_000 in
+  let counter = Atomic.make tasks in
+  let f () = Atomic.decr counter in
+  for _ = 0 to tasks - 1 do
+    Thread_pool.task tp ~f
+  done;
+  while Atomic.get counter > 0 do
+    Thread.yield ()
+  done
+;;
+
+let%bench "syscall" =
+  let tp = Thread_pool.create ~min_workers:10 ~max_workers:50 ~spawn_thread in
+  let tasks = 50_000 in
+  let counter = Atomic.make tasks in
+  let f () =
+    Unix.sleepf 0.0;
+    Atomic.decr counter
+  in
+  for _ = 0 to tasks - 1 do
+    Thread_pool.task tp ~f
+  done;
+  while Atomic.get counter > 0 do
+    Thread.yield ()
+  done
+;;
+
+let%bench "syscall - no background" =
+  let tasks = 50_000 in
+  let counter = Atomic.make tasks in
+  let f () =
+    Unix.sleepf 0.0;
+    Atomic.decr counter
+  in
+  for _ = 0 to tasks - 1 do
+    f ()
+  done;
+  while Atomic.get counter > 0 do
+    Thread.yield ()
+  done
+;;

unikernel/duniverse/dune_/bench/micro/thread_pool_bench_main.ml

@@ -0,0 +1 @@
+Inline_benchmarks_public.Runner.main ~libname:"thread_pool_bench"