unikernel/duniverse/ke/bench/bench_with_bechamel.ml

@@ -0,0 +1,179 @@
+open Bechamel
+open Toolkit
+
+let random ln =
+  let ic = open_in "/dev/urandom" in
+  let rs = Bytes.create ln in
+  really_input ic rs 0 ln;
+  close_in ic;
+  Bytes.unsafe_to_string rs
+
+let push_fke n =
+  let raw = random n in
+  let data = List.init n (String.get raw) in
+  Staged.stage (fun () -> List.fold_left Ke.Fke.push Ke.Fke.empty data)
+
+let push_rke n =
+  let queue = Ke.Rke.create ~capacity:n Bigarray.Char in
+  let raw = random n in
+  Staged.stage (fun () -> String.iter (Ke.Rke.push queue) raw)
+
+let push_rke_n n =
+  let queue = Ke.Rke.create ~capacity:n Bigarray.Char in
+  let raw = random n in
+  let blit src src_off dst dst_off len =
+    Bigstringaf.unsafe_blit_from_string src ~src_off dst ~dst_off ~len
+  in
+  Staged.stage (fun () -> Ke.Rke.N.push queue ~blit ~length:String.length raw)
+
+let push_queue n =
+  let queue = Queue.create () in
+  let raw = random n in
+  Staged.stage (fun () -> String.iter (fun chr -> Queue.add chr queue) raw)
+
+let push_and_pop_fke n =
+  let raw = random n in
+  let data = List.init n (String.get raw) in
+  Staged.stage (fun () ->
+      let q = List.fold_left Ke.Fke.push Ke.Fke.empty data in
+      let rec go q =
+        if not (Ke.Fke.is_empty q) then
+          let _, q = Ke.Fke.pop_exn q in
+          go q
+        else ()
+      in
+      go q)
+
+let push_and_pop_rke n =
+  let queue = Ke.Rke.create ~capacity:n Bigarray.Char in
+  let raw = random n in
+  Staged.stage (fun () ->
+      String.iter (Ke.Rke.push queue) raw;
+      while not (Ke.Rke.is_empty queue) do
+        ignore (Ke.Rke.pop queue)
+      done)
+
+let push_and_pop_queue n =
+  let queue = Queue.create () in
+  let raw = random n in
+  Staged.stage (fun () ->
+      String.iter (fun chr -> Queue.add chr queue) raw;
+      while not (Queue.is_empty queue) do
+        ignore (Queue.pop queue)
+      done)
+
+let test_push_fke =
+  Test.make_indexed ~name:"Fke.push"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_fke
+
+let test_push_rke =
+  Test.make_indexed ~name:"Rke.push"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_rke
+
+let test_push_rke_n =
+  Test.make_indexed ~name:"Rke.N.push"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_rke_n
+
+let test_push_queue =
+  Test.make_indexed ~name:"Queue.push"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_queue
+
+let tests_push =
+  [ test_push_fke; test_push_rke; test_push_rke_n; test_push_queue ]
+
+let big_push_fke n =
+  Staged.stage @@ fun () ->
+  let q = ref Ke.Fke.empty in
+  for i = 1 to n do
+    q := Ke.Fke.push !q i
+  done
+
+let big_push_rke n =
+  Staged.stage @@ fun () ->
+  let q = Ke.Rke.create ~capacity:n Bigarray.Char in
+  for i = 1 to n do
+    Ke.Rke.push q (Obj.magic i)
+  done
+
+let big_push_queue n =
+  Staged.stage @@ fun () ->
+  let q = Queue.create () in
+  for i = 1 to n do
+    Queue.push i q
+  done
+
+let test_big_push_fke =
+  Test.make_indexed ~name:"Fke.big_push" ~args:[ 10; 1_000_000 ] big_push_fke
+
+let test_big_push_rke =
+  Test.make_indexed ~name:"Rke.big_push" ~args:[ 10; 1_000_000 ] big_push_rke
+
+let test_big_push_queue =
+  Test.make_indexed ~name:"Queue.big_push" ~args:[ 10; 1_000_000 ]
+    big_push_queue
+
+let tests_big_push =
+  [ test_big_push_fke; test_big_push_rke; test_big_push_queue ]
+
+let test_push_and_pop_fke =
+  Test.make_indexed ~name:"Fke.push & Fke.pop"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_and_pop_fke
+
+let test_push_and_pop_rke =
+  Test.make_indexed ~name:"Rke.push & Rke.pop"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_and_pop_rke
+
+let test_push_and_pop_queue =
+  Test.make_indexed ~name:"Queue.push & Queue.pop"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_and_pop_queue
+
+let tests_push_and_pop =
+  [ test_push_and_pop_fke; test_push_and_pop_rke; test_push_and_pop_queue ]
+
+let () = Bechamel_notty.Unit.add Instance.monotonic_clock "ns"
+let () = Bechamel_notty.Unit.add Instance.minor_allocated "w"
+let () = Bechamel_notty.Unit.add Instance.major_allocated "mw"
+let () = Bechamel_notty.Unit.add Bechamel_perf.Instance.cpu_clock "ns"
+let ( <.> ) f g x = f (g x)
+
+let () =
+  let ols =
+    Analyze.ols ~r_square:true ~bootstrap:0 ~predictors:Measure.[| run |]
+  in
+  let instances =
+    Instance.
+      [ minor_allocated; major_allocated; Bechamel_perf.Instance.cpu_clock ]
+  in
+  let tests =
+    match Sys.argv with
+    | [| _ |] -> []
+    | [| _; "push" |] -> tests_push
+    | [| _; "push&pop" |] -> tests_push_and_pop
+    | [| _; "big-push" |] -> tests_big_push
+    | [| _; "all" |] -> tests_push @ tests_big_push @ tests_push_and_pop
+    | _ -> Fmt.invalid_arg "%s {push|all}" Sys.argv.(1)
+  in
+  let cfg = Benchmark.cfg ~limit:3000 () in
+  let raw_results = List.map (Benchmark.all cfg instances) tests in
+  let results =
+    List.map
+      (fun raw_results ->
+        List.map
+          (fun instance -> Analyze.all ols instance raw_results)
+          instances
+        |> Analyze.merge ols instances)
+      raw_results
+  in
+  let rect = { Bechamel_notty.w = 80; h = 1 } in
+  List.iter
+    (Notty_unix.(output_image <.> eol)
+    <.> Bechamel_notty.Multiple.image_of_ols_results ~rect
+          ~predictor:Measure.run)
+    results

unikernel/duniverse/ke/bench/bench_with_core.ml

@@ -0,0 +1,194 @@
+open Core
+open Core_bench
+
+let random ln =
+  let open Stdlib in
+  let ic = open_in "/dev/urandom" in
+  let rs = Bytes.create ln in
+  really_input ic rs 0 ln;
+  close_in ic;
+  Bytes.unsafe_to_string rs
+
+let push_fke n =
+  let raw = random n in
+  let data = List.init n ~f:(String.get raw) in
+  Staged.stage (fun () -> List.fold_left ~f:Ke.Fke.push ~init:Ke.Fke.empty data)
+
+let push_rke n =
+  let queue = Ke.Rke.create ~capacity:n Bigarray.Char in
+  let raw = random n in
+  Staged.stage (fun () -> String.iter ~f:(Ke.Rke.push queue) raw)
+
+let push_rke_n n =
+  let queue = Ke.Rke.create ~capacity:n Bigarray.Char in
+  let raw = random n in
+  let blit src src_off dst dst_off len =
+    Bigstringaf.unsafe_blit_from_string src ~src_off dst ~dst_off ~len
+  in
+  Staged.stage (fun () -> Ke.Rke.N.push queue ~blit ~length:String.length raw)
+
+let push_queue n =
+  let queue = Queue.create () in
+  let raw = random n in
+  Staged.stage (fun () ->
+      String.iter ~f:(fun chr -> Queue.enqueue queue chr) raw)
+
+let push_stdlib_queue n =
+  let open Stdlib in
+  let queue = Queue.create () in
+  let raw = random n in
+  Staged.stage (fun () -> String.iter (fun chr -> Queue.push chr queue) raw)
+
+let push_and_pop_fke n =
+  let raw = random n in
+  let data = List.init n ~f:(String.get raw) in
+  Staged.stage (fun () ->
+      let q = List.fold_left ~f:Ke.Fke.push ~init:Ke.Fke.empty data in
+      let rec go q =
+        if not (Ke.Fke.is_empty q) then
+          let _, q = Ke.Fke.pop_exn q in
+          go q
+        else ()
+      in
+      go q)
+
+let push_and_pop_rke n =
+  let queue = Ke.Rke.create ~capacity:n Bigarray.Char in
+  let raw = random n in
+  Staged.stage (fun () ->
+      String.iter ~f:(Ke.Rke.push queue) raw;
+      while not (Ke.Rke.is_empty queue) do
+        ignore (Ke.Rke.pop queue)
+      done)
+
+let push_and_pop_queue n =
+  let queue = Queue.create () in
+  let raw = random n in
+  Staged.stage (fun () ->
+      String.iter ~f:(fun chr -> Queue.enqueue queue chr) raw;
+      while not (Queue.is_empty queue) do
+        ignore (Queue.dequeue_exn queue)
+      done)
+
+let push_and_pop_stdlib_queue n =
+  let open Stdlib in
+  let queue = Queue.create () in
+  let raw = random n in
+  Staged.stage (fun () ->
+      String.iter (fun chr -> Queue.push chr queue) raw;
+      while not (Queue.is_empty queue) do
+        ignore (Queue.pop queue)
+      done)
+
+let big_push_fke n =
+  Staged.stage @@ fun () ->
+  let q = ref Ke.Fke.empty in
+  for i = 1 to n do
+    q := Ke.Fke.push !q i
+  done
+
+let big_push_rke n =
+  Staged.stage @@ fun () ->
+  let q = Ke.Rke.create ~capacity:n Bigarray.Char in
+  for i = 1 to n do
+    Ke.Rke.push q (Obj.magic i)
+  done
+
+let big_push_queue n =
+  Staged.stage @@ fun () ->
+  let q = Queue.create () in
+  for i = 1 to n do
+    Queue.enqueue q i
+  done
+
+let big_push_stdlib_queue n =
+  let open Stdlib in
+  Staged.stage @@ fun () ->
+  let q = Queue.create () in
+  for i = 1 to n do
+    Queue.push i q
+  done
+
+open Bench
+
+let test_big_push_fke =
+  Test.create_indexed ~name:"Fke.big_push" ~args:[ 10; 1_000_000 ] big_push_fke
+
+let test_big_push_rke =
+  Test.create_indexed ~name:"Rke.big_push" ~args:[ 10; 1_000_000 ] big_push_rke
+
+let test_big_push_queue =
+  Test.create_indexed ~name:"Queue.big_push" ~args:[ 10; 1_000_000 ]
+    big_push_queue
+
+let test_big_push_stdlib_queue =
+  Test.create_indexed ~name:"Stdlib.Queue.big_push" ~args:[ 10; 1_000_000 ]
+    big_push_stdlib_queue
+
+let tests_big_push =
+  [
+    test_big_push_fke; test_big_push_rke; test_big_push_queue;
+    test_big_push_stdlib_queue;
+  ]
+
+let test_push_fke =
+  Test.create_indexed ~name:"Fke.push"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_fke
+
+let test_push_rke =
+  Test.create_indexed ~name:"Rke.push"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_rke
+
+let test_push_rke_n =
+  Test.create_indexed ~name:"Rke.N.push"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_rke_n
+
+let test_push_queue =
+  Test.create_indexed ~name:"Queue.push"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_queue
+
+let test_push_stdlib_queue =
+  Test.create_indexed ~name:"Stdlib.Queue.push"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_stdlib_queue
+
+let tests_push =
+  [
+    test_push_fke; test_push_rke; test_push_rke_n; test_push_queue;
+    test_push_stdlib_queue;
+  ]
+
+let test_push_and_pop_fke =
+  Test.create_indexed ~name:"Fke.push & Fke.pop"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_and_pop_fke
+
+let test_push_and_pop_rke =
+  Test.create_indexed ~name:"Rke.push & Rke.pop"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_and_pop_rke
+
+let test_push_and_pop_queue =
+  Test.create_indexed ~name:"Queue.push & Queue.pop"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_and_pop_queue
+
+let test_push_and_pop_stdlib_queue =
+  Test.create_indexed ~name:"Stdlib.Queue.push & Stdlib.Queue.pop"
+    ~args:[ 100; 500; 1000; 5000; 10000 ]
+    push_and_pop_stdlib_queue
+
+let tests_push_and_pop =
+  [
+    test_push_and_pop_fke; test_push_and_pop_rke; test_push_and_pop_queue;
+    test_push_and_pop_stdlib_queue;
+  ]
+
+let command =
+  Bench.make_command (tests_push @ tests_big_push @ tests_push_and_pop)
+
+let () = Command_unix.run command

unikernel/duniverse/ke/bench/bfs.ml

@@ -0,0 +1,103 @@
+module type F_PROBLEM = sig
+  type state
+  type move
+
+  val success : state -> bool
+  val moves : state -> (move * state) list
+
+  type table
+
+  val create : unit -> table
+  val add : table -> state -> unit
+  val mem : table -> state -> bool
+  val clear : table -> unit
+end
+
+module type M_PROBLEM = sig
+  type move
+
+  val success : unit -> bool
+  val moves : unit -> move list
+  val do_move : move -> unit
+  val undo_move : move -> unit
+  val add : unit -> unit
+  val mem : unit -> bool
+  val clear : unit -> unit
+end
+
+module F (Q : Ke.Sigs.M) (P : F_PROBLEM) = struct
+  let search s0 =
+    let visited = P.create () in
+    let already s =
+      P.mem visited s
+      ||
+      (P.add visited s;
+       false)
+    in
+    let _ = already s0 in
+    let q = Q.create () in
+    Q.push q ([], s0);
+    let rec bfs () =
+      if Q.is_empty q then raise Not_found;
+      let path, s = Q.pop_exn q in
+      if P.success s then (s, List.rev path)
+      else (
+        List.iter
+          (fun (m, s') -> if not (already s') then Q.push q (m :: path, s'))
+          (P.moves s);
+        bfs ())
+    in
+    bfs ()
+end
+
+module M (Q : Ke.Sigs.M) (P : M_PROBLEM) = struct
+  let rec cut_head n l = if n == 0 then l else cut_head (pred n) (List.tl l)
+
+  let common_psuffix (n1, l1) (n2, l2) =
+    let rec suffix l1 l2 =
+      if l1 == l2 then l1 else suffix (List.tl l1) (List.tl l2)
+    in
+    if n1 < n2 then suffix l1 (cut_head (n2 - n1) l2)
+    else if n2 < n1 then suffix (cut_head (n1 - n2) l1) l2
+    else suffix l1 l2
+
+  let search () =
+    let already () =
+      P.mem ()
+      ||
+      (P.add ();
+       false)
+    in
+    let q = Q.create () in
+    Q.push q (0, []);
+    let cpath = ref (0, []) in
+    let rec restore_state path =
+      let suf = common_psuffix path !cpath in
+      let rec backward = function
+        | m :: r as p when p != suf ->
+            P.undo_move m;
+            backward r
+        | _ -> ()
+      in
+      let rec forward = function
+        | m :: r as p when p != suf ->
+            forward r;
+            P.do_move m
+        | _ -> ()
+      in
+      backward (snd !cpath);
+      forward (snd path);
+      cpath := path
+    in
+    let rec bfs () =
+      if Q.is_empty q then raise Not_found;
+      let ((n, path) as s) = Q.pop_exn q in
+      restore_state s;
+      if P.success () then List.rev path
+      else if not (already ()) then (
+        List.iter (fun m -> Q.push q (succ n, m :: path)) (P.moves ());
+        bfs ())
+      else bfs ()
+    in
+    bfs ()
+end

unikernel/duniverse/ke/bench/dune

@@ -0,0 +1,19 @@
+(executable
+ (name bench_with_bechamel)
+ (modules bench_with_bechamel)
+ (libraries notty.unix bigstringaf ke bechamel bechamel-perf bechamel-notty))
+
+(executable
+ (name bench_with_core)
+ (modules bench_with_core)
+ (libraries bigstringaf core_bench ke core core_unix.command_unix))
+
+(rule
+ (alias runbench)
+ (action
+  (run ./bench_with_bechamel.exe)))
+
+(rule
+ (alias runbench)
+ (action
+  (run ./bench_with_core.exe)))