unikernel/duniverse/dune_/bench/bench.ml

@@ -0,0 +1,275 @@
+open Stdune
+module Process = Dune_engine.Process
+
+module Console = struct
+  include Dune_console
+
+  let printf fmt = printf ("[Bench] " ^^ fmt)
+end
+
+module Json = struct
+  include Chrome_trace.Json
+  include Dune_stats.Json
+end
+
+module Output = struct
+  type measurement =
+    [ `Int of int
+    | `Float of float
+    ]
+
+  type bench =
+    { name : string
+    ; metrics : (string * [ measurement | `List of measurement list ] * string) list
+    }
+
+  let json_of_bench { name; metrics } : Json.t =
+    let metrics =
+      List.map metrics ~f:(fun (name, value, units) ->
+        let value =
+          match value with
+          | `Int i -> `Int i
+          | `Float f -> `Float f
+          | `List xs -> `List (xs :> Json.t list)
+        in
+        `Assoc [ "name", `String name; "value", value; "units", `String units ])
+    in
+    `Assoc [ "name", `String name; "metrics", `List metrics ]
+  ;;
+
+  type t =
+    { config : (string * Json.t) list
+    ; version : int
+    ; results : bench list
+    }
+
+  let to_json { config; version; results } : Json.t =
+    let assoc = [ "results", `List (List.map results ~f:json_of_bench) ] in
+    let assoc = ("version", `Int version) :: assoc in
+    let assoc =
+      match config with
+      | [] -> assoc
+      | _ :: _ -> ("config", `Assoc config) :: assoc
+    in
+    `Assoc assoc
+  ;;
+end
+
+let git =
+  lazy
+    (let path = Env.get Env.initial "PATH" |> Option.value_exn |> Bin.parse_path in
+     Bin.which ~path "git" |> Option.value_exn)
+;;
+
+let dune = Path.of_string (Filename.concat Fpath.initial_cwd Sys.argv.(1))
+let output_limit = Dune_engine.Execution_parameters.Action_output_limit.default
+let make_stdout () = Process.Io.make_stdout ~output_on_success:Swallow ~output_limit
+let make_stderr () = Process.Io.make_stderr ~output_on_success:Swallow ~output_limit
+
+module Package = struct
+  type t =
+    { org : string
+    ; name : string
+    }
+
+  let uri { org; name } = sprintf "https://github.com/%s/%s" org name
+  let make org name = { org; name }
+
+  let clone t =
+    let stdout_to = make_stdout () in
+    let stderr_to = make_stderr () in
+    let stdin_from = Process.Io.(null In) in
+    Process.run
+      Strict
+      ~display:Quiet
+      ~stdout_to
+      ~stderr_to
+      ~stdin_from
+      (Lazy.force git)
+      [ "clone"; uri t ]
+  ;;
+end
+
+let duniverse =
+  let pkg = Package.make in
+  [ pkg "ocaml-dune" "dune-bench" ]
+;;
+
+let prepare_workspace () =
+  Fiber.parallel_iter duniverse ~f:(fun (pkg : Package.t) ->
+    Fpath.rm_rf pkg.name;
+    Console.printf "cloning %s/%s" pkg.org pkg.name;
+    Fiber.finalize
+      (fun () -> Package.clone pkg)
+      ~finally:(fun () ->
+        Fiber.return @@ Console.printf "finished cloning %s/%s" pkg.org pkg.name))
+;;
+
+let dune_build ~name ~sandbox =
+  let stdin_from = Process.(Io.null In) in
+  let stdout_to = make_stdout () in
+  let stderr_to = make_stderr () in
+  let gc_dump = Temp.create File ~prefix:"gc_stat" ~suffix:name in
+  let open Fiber.O in
+  (* Build with timings and gc stats *)
+  let+ times =
+    Process.run_with_times
+      Strict
+      dune
+      ~display:Quiet
+      ~stdin_from
+      ~stdout_to
+      ~stderr_to
+      ([ "build"
+       ; "@install"
+       ; "--release"
+       ; "--cache" (* explicitly disable cache *)
+       ; "disabled"
+       ; "--dump-gc-stats"
+       ; Path.to_string gc_dump
+       ]
+       @
+       match sandbox with
+       | `Yes -> [ "--sandbox"; "hardlink" ]
+       | `No -> [])
+  in
+  (* Read the gc stats from the dump file *)
+  Dune_lang.Parser.parse_string
+    ~mode:Single
+    ~fname:(Path.to_string gc_dump)
+    (Io.read_file gc_dump)
+  |> Dune_lang.Decoder.parse Dune_util.Gc.decode Univ_map.empty
+  |> Metrics.make times
+;;
+
+let run_bench ~sandbox =
+  let open Fiber.O in
+  let* clean = dune_build ~name:"clean" ~sandbox in
+  let+ zero =
+    let rec zero acc n =
+      if n = 0
+      then Fiber.return (List.rev acc)
+      else
+        let* time = dune_build ~name:("zero" ^ string_of_int n) ~sandbox in
+        zero (time :: acc) (pred n)
+    in
+    zero [] 5
+  in
+  clean, zero
+;;
+
+type ('float, 'int) bench_results =
+  { size : int
+  ; clean : ('float, 'int) Metrics.t
+  ; zero : ('float, 'int) Metrics.t list
+  }
+
+let tag_results { size; clean; zero } =
+  let tag data = Metrics.map ~f:(fun t -> `Float t) ~g:(fun t -> `Int t) data in
+  let list_tag data =
+    List.map data ~f:tag
+    |> Metrics.unzip
+    |> Metrics.map ~f:(fun x -> `List x) ~g:(fun x -> `List x)
+  in
+  `Int size, tag clean, list_tag zero
+;;
+
+(** Display all clean and null builds with a few exceptions:
+
+    - fragments - not consistent between builds
+    - stack_size - not very useful
+    - forced_collections - only available in OCaml >= 4.12 *)
+let display_clean_and_zero_with_sandboxing
+      ({ elapsed_time
+       ; user_cpu_time
+       ; system_cpu_time
+       ; minor_words
+       ; promoted_words
+       ; major_words
+       ; minor_collections
+       ; major_collections
+       ; heap_words
+       ; heap_chunks
+       ; live_words
+       ; live_blocks
+       ; free_words
+       ; free_blocks
+       ; largest_free
+       ; fragments = _
+       ; compactions
+       ; top_heap_words
+       ; stack_size = _
+       } :
+        _ Metrics.t)
+      (zero : _ Metrics.t)
+  =
+  let display what units clean zero =
+    { Output.name = what
+    ; metrics = [ "[Clean] " ^ what, clean, units; "[Null] " ^ what, zero, units ]
+    }
+  in
+  [ display "Build Time" "Seconds" elapsed_time zero.elapsed_time
+  ; display "Minor Words" "Approx. Words" minor_words zero.minor_words
+  ; display "Promoted Words" "Approx. Words" promoted_words zero.promoted_words
+  ; display "Major Words" "Approx. Words" major_words zero.major_words
+  ; display "Minor Collections" "Collections" minor_collections zero.minor_collections
+  ; display "Major Collections" "Collections" major_collections zero.major_collections
+  ; display "Heap Words" "Words" heap_words zero.heap_words
+  ; display "Heap Chunks" "Chunks" heap_chunks zero.heap_chunks
+  ; display "Live Words" "Words" live_words zero.live_words
+  ; display "Live Blocks" "Blocks" live_blocks zero.live_blocks
+  ; display "Free Words" "Words" free_words zero.free_words
+  ; display "Free Blocks" "Blocks" free_blocks zero.free_blocks
+  ; display "Largest Free" "Words" largest_free zero.largest_free
+  ; display "Compactions" "Compactions" compactions zero.compactions
+  ; display "Top Heap Words" "Words" top_heap_words zero.top_heap_words
+  ; display "User CPU Time" "Seconds" user_cpu_time zero.user_cpu_time
+  ; display "System CPU Time" "Seconds" system_cpu_time zero.system_cpu_time
+  ]
+;;
+
+let format_results bench_results =
+  (* tagging data for json conversion *)
+  let size, clean, zero = tag_results bench_results in
+  (* bench results *)
+  [ { Output.name = "Misc"; metrics = [ "Size of _boot/dune.exe", size, "Bytes" ] } ]
+  @ display_clean_and_zero_with_sandboxing clean zero
+;;
+
+let () =
+  Dune_util.Log.init ~file:No_log_file ();
+  let dir = Temp.create Dir ~prefix:"dune" ~suffix:"bench" in
+  Sys.chdir (Path.to_string dir);
+  Path.as_external dir |> Option.value_exn |> Path.set_root;
+  Path.Build.set_build_dir (Path.Outside_build_dir.of_string "_build");
+  let module Scheduler = Dune_engine.Scheduler in
+  let config =
+    Dune_engine.Clflags.display := Quiet;
+    { Scheduler.Config.concurrency = 10
+    ; stats = None
+    ; print_ctrl_c_warning = false
+    ; watch_exclusions = []
+    }
+  in
+  let size =
+    let stat : Unix.stats = Path.stat_exn dune in
+    stat.st_size
+  in
+  let results =
+    Scheduler.Run.go config ~on_event:(fun _ _ -> ())
+    @@ fun () ->
+    let open Fiber.O in
+    (* Prepare the workspace *)
+    let* () = prepare_workspace () in
+    (* Build the clean and null builds *)
+    Console.printf "Building clean and null builds";
+    let+ clean, zero = run_bench ~sandbox:`No in
+    Console.printf "Finished building clean and null builds";
+    (* Return the bench results *)
+    format_results { size; clean; zero }
+  in
+  let version = 4 in
+  let output = { Output.config = []; version; results } in
+  print_string (Json.to_string (Output.to_json output));
+  flush stdout
+;;

unikernel/duniverse/dune_/bench/dune

@@ -0,0 +1,27 @@
+(executable
+ (name bench)
+ (modules bench metrics)
+ (libraries
+  dune_stats
+  dune_console
+  chrome_trace
+  stdune
+  fiber
+  dune_lang
+  dune_engine
+  dune_util))
+
+(rule
+ (alias bench)
+ (action
+  (run ./bench.exe %{bin:dune})))
+
+(executable
+ (modules gen_synthetic)
+ (libraries unix)
+ (name gen_synthetic))
+
+(executable
+ (modules gen_synthetic_dune_watch)
+ (libraries unix)
+ (name gen_synthetic_dune_watch))

unikernel/duniverse/dune_/bench/gen-benchmark.sh

@@ -0,0 +1,40 @@
+#!/bin/bash
+
+set -eu
+
+usage()
+{
+    cat <<EOF
+Usage:
+    $(basename "${0}") <command> <clean_command> <name>
+EOF
+}
+
+if [ $# -ne 3 ]; then
+    usage
+    exit 1
+fi
+
+command="${1}"
+clean_command="${2}"
+name="${3}"
+
+hyperfine "${command}" \
+    --show-output \
+    --warmup 2 \
+    --runs 3 \
+    --prepare "${clean_command}" \
+    --export-json bench.json \
+    > /dev/null
+
+mean_time=$(cat bench.json | jq '.results[0].mean | tostring')
+
+cat<<EOF
+[
+    {
+        "name": "${name}",
+        "unit": "seconds",
+        "value": ${mean_time}
+    }
+]
+EOF

unikernel/duniverse/dune_/bench/gen_synthetic.ml

@@ -0,0 +1,37 @@
+open Printf
+
+let write_modules basedir num_modules =
+  for current_mod = 1 to num_modules do
+    let modname = sprintf "%s/m_%d" basedir current_mod in
+    let f = open_out (sprintf "%s.ml" modname) in
+    close_out f
+  done
+;;
+
+let dune =
+  {|
+(library
+ (name test))
+|}
+;;
+
+let write basedir =
+  let () = Unix.mkdir basedir 0o777 in
+  let f = open_out (Filename.concat basedir "dune") in
+  output_string f dune;
+  let () = close_out f in
+  write_modules basedir
+;;
+
+let () =
+  let basedir = ref "." in
+  let num_modules = ref 0 in
+  Arg.parse
+    [ ( "-n"
+      , Arg.Int (fun n -> num_modules := n)
+      , "<n>  number of modules to include in the synthetic library" )
+    ]
+    (fun d -> basedir := d)
+    (sprintf "usage: %s [basedir]" (Filename.basename Sys.argv.(0)));
+  write !basedir !num_modules
+;;

unikernel/duniverse/dune_/bench/gen_synthetic_dune_watch.ml

@@ -0,0 +1,96 @@
+open Printf
+
+type lib =
+  | Leaf
+  | Internal
+
+let subsets_per_library = 4
+let count n = Array.to_list (Array.init n (fun k -> k + 1))
+
+let write_subset base_dir library_index subset =
+  let mod_rows = 10 in
+  let mod_cols = 10 in
+  for row = 1 to mod_rows do
+    for col = 1 to mod_cols do
+      let deps =
+        if row = 1
+        then
+          if library_index = 1
+          then []
+          else
+            List.flatten
+              (List.map
+                 (fun k ->
+                    List.map
+                      (fun j ->
+                         sprintf "M_%d_%d_%d_%d.f()" (library_index - 1) j mod_rows k)
+                      (count subsets_per_library))
+                 (count mod_cols))
+        else
+          List.map
+            (fun k -> sprintf "M_%d_%d_%d_%d.f()" library_index subset (row - 1) k)
+            (count mod_cols)
+      in
+      let deps = List.rev ("()" :: List.rev deps) in
+      let str_deps = String.concat ";\n  " deps in
+      let mod_text = sprintf "let f() =\n  %s\n" str_deps in
+      let modname = sprintf "%s/m_%d_%d_%d_%d" base_dir library_index subset row col in
+      let f = open_out (sprintf "%s.ml" modname) in
+      output_string f mod_text;
+      close_out f;
+      let f = open_out (sprintf "%s.mli" modname) in
+      output_string f "val f : unit -> unit";
+      close_out f
+    done
+  done
+;;
+
+let write_lib ~base_dir ~lib ~dune =
+  let name =
+    match lib with
+    | Leaf -> "leaf"
+    | Internal -> "internal"
+  in
+  let lib_dir = Filename.concat base_dir name in
+  let () = Unix.mkdir lib_dir 0o777 in
+  let f = open_out (Filename.concat lib_dir "dune") in
+  output_string f dune;
+  let () = close_out f in
+  let library_index =
+    match lib with
+    | Leaf -> 2
+    | Internal -> 1
+  in
+  for subset = 1 to subsets_per_library do
+    write_subset lib_dir library_index subset
+  done
+;;
+
+let write base_dir =
+  let () = Unix.mkdir base_dir 0o777 in
+  let dune =
+    {|
+(library
+ (name leaf)
+ (libraries internal))
+|}
+  in
+  write_lib ~base_dir ~lib:Leaf ~dune;
+  let dune =
+    {|
+(library
+ (name internal)
+ (wrapped false))
+|}
+  in
+  write_lib ~base_dir ~lib:Internal ~dune
+;;
+
+let () =
+  let base_dir = ref "." in
+  Arg.parse
+    []
+    (fun d -> base_dir := d)
+    (sprintf "usage: %s [base_dir]" (Filename.basename Sys.argv.(0)));
+  write !base_dir
+;;

unikernel/duniverse/dune_/bench/metrics.ml

@@ -0,0 +1,125 @@
+open Stdune
+
+type ('float, 'int) t =
+  { elapsed_time : 'float
+  ; user_cpu_time : 'float
+  ; system_cpu_time : 'float
+  ; minor_words : 'float
+  ; promoted_words : 'float
+  ; major_words : 'float
+  ; minor_collections : 'int
+  ; major_collections : 'int
+  ; heap_words : 'int
+  ; heap_chunks : 'int
+  ; live_words : 'int
+  ; live_blocks : 'int
+  ; free_words : 'int
+  ; free_blocks : 'int
+  ; largest_free : 'int
+  ; fragments : 'int
+  ; compactions : 'int
+  ; top_heap_words : 'int
+  ; stack_size : 'int
+  }
+
+let make (times : Proc.Times.t) (gc : Gc.stat) =
+  (* We default to 0 for the other processor times since they are rarely None in
+     pracice. *)
+  let { Proc.Resource_usage.user_cpu_time; system_cpu_time } =
+    Option.value
+      times.resource_usage
+      ~default:{ user_cpu_time = 0.; system_cpu_time = 0. }
+  in
+  { elapsed_time = times.elapsed_time
+  ; user_cpu_time
+  ; system_cpu_time
+  ; minor_words = gc.minor_words
+  ; promoted_words = gc.promoted_words
+  ; major_words = gc.major_words
+  ; minor_collections = gc.minor_collections
+  ; major_collections = gc.major_collections
+  ; heap_words = gc.heap_words
+  ; heap_chunks = gc.heap_chunks
+  ; live_words = gc.live_words
+  ; live_blocks = gc.live_blocks
+  ; free_words = gc.free_words
+  ; free_blocks = gc.free_blocks
+  ; largest_free = gc.largest_free
+  ; fragments = gc.fragments
+  ; compactions = gc.compactions
+  ; top_heap_words = gc.top_heap_words
+  ; stack_size = gc.stack_size
+  }
+;;
+
+let map ~f ~g (metrics : ('float, 'int) t) : ('float_, 'int_) t =
+  { elapsed_time = f metrics.elapsed_time
+  ; user_cpu_time = f metrics.user_cpu_time
+  ; system_cpu_time = f metrics.system_cpu_time
+  ; minor_words = f metrics.minor_words
+  ; promoted_words = f metrics.promoted_words
+  ; major_words = f metrics.major_words
+  ; minor_collections = g metrics.minor_collections
+  ; major_collections = g metrics.major_collections
+  ; heap_words = g metrics.heap_words
+  ; heap_chunks = g metrics.heap_chunks
+  ; live_words = g metrics.live_words
+  ; live_blocks = g metrics.live_blocks
+  ; free_words = g metrics.free_words
+  ; free_blocks = g metrics.free_blocks
+  ; largest_free = g metrics.largest_free
+  ; fragments = g metrics.fragments
+  ; compactions = g metrics.compactions
+  ; top_heap_words = g metrics.top_heap_words
+  ; stack_size = g metrics.stack_size
+  }
+;;
+
+(** Turns a list of records into a record of lists. *)
+let unzip (metrics : ('float, 'int) t list) : ('float list, 'int list) t =
+  List.fold_left
+    metrics
+    ~init:
+      { elapsed_time = []
+      ; user_cpu_time = []
+      ; system_cpu_time = []
+      ; minor_words = []
+      ; promoted_words = []
+      ; major_words = []
+      ; minor_collections = []
+      ; major_collections = []
+      ; heap_words = []
+      ; heap_chunks = []
+      ; live_words = []
+      ; live_blocks = []
+      ; free_words = []
+      ; free_blocks = []
+      ; largest_free = []
+      ; fragments = []
+      ; compactions = []
+      ; top_heap_words = []
+      ; stack_size = []
+      }
+    ~f:(fun acc x ->
+      { elapsed_time = x.elapsed_time :: acc.elapsed_time
+      ; user_cpu_time = x.user_cpu_time :: acc.user_cpu_time
+      ; system_cpu_time = x.system_cpu_time :: acc.system_cpu_time
+      ; minor_words = x.minor_words :: acc.minor_words
+      ; promoted_words = x.promoted_words :: acc.promoted_words
+      ; major_words = x.major_words :: acc.major_words
+      ; minor_collections = x.minor_collections :: acc.minor_collections
+      ; major_collections = x.major_collections :: acc.major_collections
+      ; heap_words = x.heap_words :: acc.heap_words
+      ; heap_chunks = x.heap_chunks :: acc.heap_chunks
+      ; live_words = x.live_words :: acc.live_words
+      ; live_blocks = x.live_blocks :: acc.live_blocks
+      ; free_words = x.free_words :: acc.free_words
+      ; free_blocks = x.free_blocks :: acc.free_blocks
+      ; largest_free = x.largest_free :: acc.largest_free
+      ; fragments = x.fragments :: acc.fragments
+      ; compactions = x.compactions :: acc.compactions
+      ; top_heap_words = x.top_heap_words :: acc.top_heap_words
+      ; stack_size = x.stack_size :: acc.stack_size
+      })
+  |> map ~f:List.rev ~g:List.rev
+;;

unikernel/duniverse/dune_/bench/metrics.mli

@@ -0,0 +1,66 @@
+open Stdune
+
+(** [('float, 'int) t] is a record of metrics about the current process. It
+    includes timing information and information available from [Gc.stat]. It is
+    polymorphic in the type of field values to allow for the definition of
+    [unzip] functions which make serialisation easier. *)
+type ('float, 'int) t =
+  { elapsed_time : 'float
+    (** Real time elapsed since the process started and the process
+      finished. *)
+  ; user_cpu_time : 'float
+    (** The amount of CPU time spent in user mode during the process. Other
+      processes and blocked time are not included. *)
+  ; system_cpu_time : 'float
+    (** The amount of CPU time spent in kernel mode during the process.
+      Similar to user time, other processes and time spent blocked by
+      other processes are not counted. *)
+  ; minor_words : 'float
+    (** Number of words allocated in the minor heap since the program was
+      started. *)
+  ; promoted_words : 'float
+    (** Number of words that have been promoted from the minor to the major
+      heap since the program was started. *)
+  ; major_words : 'float
+    (** Number of words allocated in the major heap since the program was
+      started. *)
+  ; minor_collections : 'int
+    (** Number of minor collections since the program was started. *)
+  ; major_collections : 'int
+    (** Number of major collection cycles completed since the program was
+      started. *)
+  ; heap_words : 'int (** Total size of the major heap, in words. *)
+  ; heap_chunks : 'int
+    (** Number of contiguous pieces of memory that make up the major heap. *)
+  ; live_words : 'int
+    (** Number of words of live data in the major heap, including the header
+      words. *)
+  ; live_blocks : 'int (** Number of live blocks in the major heap. *)
+  ; free_words : 'int (** Number of words in the free list. *)
+  ; free_blocks : 'int (** Number of blocks in the free list. *)
+  ; largest_free : 'int (** Size (in words) of the largest block in the free list. *)
+  ; fragments : 'int
+    (** Number of wasted words due to fragmentation. These are 1-words free
+      blocks placed between two live blocks. They are not available for
+      allocation. *)
+  ; compactions : 'int (** Number of heap compactions since the program was started. *)
+  ; top_heap_words : 'int (** Maximum size reached by the major heap, in words. *)
+  ; stack_size : 'int (** Current size of the stack, in words. *)
+  }
+
+(** [make t gc] creates a new metrics record from the given [t] and [gc]
+    information. *)
+val make : Proc.Times.t -> Gc.stat -> (float, int) t
+
+(** [map ~f ~g m] applies [f] to the float fields and [g] to the int fields of
+    [m]. *)
+val map
+  :  f:('float -> 'float_)
+  -> g:('int -> 'int_)
+  -> ('float, 'int) t
+  -> ('float_, 'int_) t
+
+(** [unzip m] takes a list of metrics [m] and returns a records with the lists
+    of values for each field. This is particularly convenient when serialising
+    to json. *)
+val unzip : ('float, 'int) t list -> ('float list, 'int list) t

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"

unikernel/duniverse/dune_/bench/perf.sh

@@ -0,0 +1,90 @@
+#!/usr/bin/env bash
+
+# Run this script simply as ./bench/perf.sh from the root directory.
+
+set -e
+
+TEST_REPO=https://github.com/ocaml-dune/dune-bench
+TEST_COMMIT=b6bfaf2974ec8ee1eea92c4316ec37b9966322e3
+
+# Some alternative benchmarks:
+
+# TEST_REPO=https://github.com/ocaml/dune
+# TEST_COMMIT=002edc11f4e0a57f11d5226cb2497c8b406027b5
+
+# TEST_REPO=https://github.com/avsm/platform
+# TEST_COMMIT=b254e3c6b60f3c0c09dfdcde92eb1abdc267fa1c
+
+dune() {
+  TIMEFORMAT=$'real %Rs\nuser %Us\nsys  %Ss\n'; time ../_build/default/bin/main.exe "$@" > /dev/null 2>&1
+}
+
+setup_test() {
+  mkdir -p _perf
+
+  cd _perf
+  if [ ! -f README.md ]; then
+    echo "Cloning $TEST_REPO..."
+    wget $TEST_REPO/archive/$TEST_COMMIT.tar.gz
+    tar -xzf $TEST_COMMIT.tar.gz --strip-components=1
+  fi
+  cd ..
+}
+
+pad () {
+  while IFS='' read -r x; do printf "%-$1s\n" "$x"; done
+}
+
+run_test() {
+  echo "Building Dune..."
+  # [make release] is used for bootstrapping, but the real binary to benchmark is
+  # then produced by a separate dune invocation.
+  # This is done mainly because [make release] won't rebuild dune if it's stale.
+  make release > /dev/null
+  ./dune.exe build _build/default/bin/main.exe
+
+  cd _perf
+  rm -rf _build
+
+  echo "Running full build..."
+  dune build --release --cache=disabled 2>> $1
+
+  echo "Running zero build..."
+  dune build --release --cache=disabled 2>> $1
+
+  cd ..
+}
+
+setup_test
+CURRENT_BRANCH=$(git branch | sed -n -e 's/^\* \(.*\)/\1/p')
+
+rm -f _perf/rows _perf/current _perf/main
+
+echo "            " >> _perf/rows
+echo "            " >> _perf/rows
+echo "           |" >> _perf/rows
+echo "Full build |" >> _perf/rows
+echo "           |" >> _perf/rows
+echo "            " >> _perf/rows
+echo "           |" >> _perf/rows
+echo "Zero build |" >> _perf/rows
+echo "           |" >> _perf/rows
+
+echo "Current branch" >> _perf/current
+echo "==============" >> _perf/current
+echo "Testing the current branch ($CURRENT_BRANCH)"
+run_test current
+
+echo " Main branch " >> _perf/main
+echo "=============" >> _perf/main
+git checkout main
+echo "Testing main"
+run_test main
+
+git checkout $CURRENT_BRANCH
+
+echo ""
+echo "Summary for building $TEST_REPO:"
+echo ""
+
+paste -d ' ' <(pad 10 < _perf/rows) <(pad 14 < _perf/current) _perf/main

unikernel/duniverse/dune_/bench/run-synthetic-dune-watch.sh

@@ -0,0 +1,63 @@
+#!/bin/bash
+
+set -eu
+
+usage()
+{
+    cat <<EOF
+Usage:
+    $(basename "${0}") <path_to_dune>
+EOF
+}
+
+if [ $# -ne 1 ]; then
+    usage
+    exit 1
+fi
+
+path_to_dune="${1}"
+
+start_dune () {
+    ((${path_to_dune} build "$@" --watch @all > .#dune-output 2>&1) || (echo exit $? >> .#dune-output)) &
+    DUNE_PID=$!;
+}
+
+timeout="$(command -v timeout || echo gtimeout)"
+
+with_timeout () {
+    $timeout 2 "$@"
+    exit_code=$?
+    if [ "$exit_code" = 124 ]
+    then
+        echo Timed out
+        cat .#dune-output
+    else
+        return "$exit_code"
+    fi
+}
+
+stop_dune () {
+    with_timeout dune shutdown;
+    wait $DUNE_PID;
+    cat .#dune-output;
+}
+
+echo Breaking build
+echo "let f() = 2" > ./internal/m_1_1_1_1.ml
+echo "val f : unit -> int" > ./internal/m_1_1_1_1.mli
+
+echo Starting dune
+start_dune
+
+echo Checking for error
+until grep 'error' .#dune-output > /dev/null; do sleep 0.1; done
+
+echo Found, fixing build
+echo "let f() = ()" > ./internal/m_1_1_1_1.ml
+echo "val f : unit -> unit" > ./internal/m_1_1_1_1.mli
+
+echo Checking for success
+until grep 'Success' .#dune-output > /dev/null; do sleep 0.1; done
+
+echo Found, stopping dune
+stop_dune