unikernel/duniverse/ke/.gitignore

@@ -0,0 +1,15 @@
+_build
+setup.data
+setup.log
+doc/*.html
+*.native
+*.byte
+*.so
+lib/decompress_conf.ml
+*.tar.gz
+_tests
+lib_test/files
+zpipe
+c/dpipe
+*.merlin
+*.install

unikernel/duniverse/ke/.ocamlformat

@@ -0,0 +1,7 @@
+version=0.21.0
+module-item-spacing=compact
+break-struct=natural
+break-infix=fit-or-vertical
+parens-tuple=always
+wrap-comments=false
+break-collection-expressions=wrap

unikernel/duniverse/ke/.travis.yml

@@ -0,0 +1,13 @@
+language: c
+install:
+  - wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh
+  - wget https://raw.githubusercontent.com/dinosaure/ocaml-travisci-skeleton/master/.travis-docgen.sh
+script: bash -ex .travis-opam.sh
+sudo: true
+env:
+  matrix:
+  - PACKAGE="ke" OCAML_VERSION=4.03 TESTS=true
+  - PACKAGE="ke" OCAML_VERSION=4.04 TESTS=true
+  - PACKAGE="ke" OCAML_VERSION=4.05 TESTS=true
+  - PACKAGE="ke" OCAML_VERSION=4.06 TESTS=true
+  - PACKAGE="ke" OCAML_VERSION=4.07 TESTS=true

unikernel/duniverse/ke/CHANGES.md

@@ -0,0 +1,45 @@
+### v0.6 2022-04-07 Paris (France)
+
+* Require OCaml 4.08 and remove `bigarray-compat` dependency (@hannesm, #17)
+
+### v0.5 2022-03-18 Paris (France)
+
+* Remove `{build}` directive into the OPAM file (@CraigFe, #10)
+* Add `unsafe_bigarray` into `Rke.Weighted` (@anmonteiro, #11)
+* Lint OPAM file (@kit-ty-kate, #12)
+* Fix the distribution and the CI (@dinosaure, #13)
+* Update the distribution with `cmdliner.1.1.0` (@dinosaure, #15)
+
+### v0.4 2019-07-24 Мостар (Боснa и Херцеговина)
+
+* Call `dune subst` only when we _pin_ `ke`
+* Update documentation (@dinosaure, @Drup)
+  - Typography
+  - Documentation about `Fke.tail{,_exn}`
+  - Documentation about `Fke.rev_iter`
+* Add `Fke.tail{,_exn}` (@dinosaure, #8)
+* Add `Fke.rev_iter` (@dinosaure, #9)
+* Compatible with `mirage`, dependance with `bigarray-compat` (@dinosaure, @TheLortex, #8)
+* Update OPAM file (@dinosaure)
+
+### v0.3 2019-04-10 Paris (France)
+
+* Add `Rke.{,Weighted}.compress` function (fuzzed)
+* Update `bechamel` benchmark
+* Add `Rke{,.Weighted}.N.peek` function
+* Fix bug on `Rke.Weighted.N.keep` function
+* Add some tests
+
+### v0.2 2019-01-14 Paris (France)
+
+* Add pretty-printer
+* Randomize `pop` action on the fuzzer
+* Add tests on `Rke` and `Rke.Weighted` (with `alcotest`)
+* Fix bug retrieved by `ocaml-git` (see 453633b)
+* Add `rev_iter` function
+* Fix bug on `Rke.N.keep_exn` (see 3951501)
+* Add Travis CI support
+
+### v0.1 2018-12-20 Paris (France)
+
+* First release

unikernel/duniverse/ke/LICENSE.md

@@ -0,0 +1,20 @@
+The MIT License (MIT)
+
+Copyright (c) 2018 Romain Calascibetta
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
+the Software, and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

unikernel/duniverse/ke/README.md

@@ -0,0 +1,46 @@
+Ke - Fast implementation of Queue in OCaml
+==========================================
+
+![travis-ci](https://travis-ci.org/mirage/ke.svg?banch=master)
+
+Queue or FIFO is one of the most famous data-structure used in several
+algorithms. `Ke` provides some implementations of it in a functionnal or
+imperative way.
+
+It is a little library with benchmark
+([`bechamel`](https://github.com/dinosaure/bechamel.git) or `core_bench`),
+fuzzer and tests.
+
+From what we know, `Ke.Rke` is the faster implementation than `Queue` from the
+standard library or the `base` package. It is limited by some kind of data (see
+[`Bigarray.kind`]()) but enough for a large amount of algorithms. The fast
+operation is to put some elements faster than a sequence of `Queue.push`, and
+get some elements faster than a sequence of `Queue.pop`.
+
+Then we provide a functionnal interface `Fke` or an imperative interface `Rke`.
+
+We extended implementations to have a limit of elements to store (see
+`Rke.Weighted` and `Fke.Weigted`). The purpose of it is to limit memory
+consumption of queue when we use it in some contexts (like _encoder_).
+
+Again, as a part of the MirageOS project, `Ke` does not rely on C stubs,
+`Obj.magic` and so on.
+
+Author: Romain Calascibetta <romain.calascibetta@gmail.com>
+
+Documentation: https://mirage.github.io/ke/
+
+Notes about Implementations
+===========================
+
+The functionnal implementation `Fke` is come from the Okazaki's queue
+implementation with GADT to discard impossible case.
+
+`Rke`, `Rke.Weighted` and `Fke.Weighted` was limited by kind and follow Xen's
+implementation of the shared memory ring-buffer. Length of the internal buffer
+is, in any case, a power of two - that means, in some context, for a large
+amount of elements, this kind of queue does not fit on your request.
+
+Fuzzer was made to compare the standard Queue (as an oracle) with `Rke` and
+`Fke`. We construct a set of actions (`push` and `pop`) and ensure (by GADT) to
+never `pop` an empty queue.

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)))

unikernel/duniverse/ke/database.json

@@ -0,0 +1,4 @@
+[
+  {"name": "First node", "time": "0", "ancestors": []},
+  {"name": "Second node", "time": "1", "ancestors": [0]}
+]

unikernel/duniverse/ke/dune-project

@@ -0,0 +1,3 @@
+(lang dune 2.0)
+(name ke)
+(version v0.6)

unikernel/duniverse/ke/example/dune

@@ -0,0 +1,3 @@
+(executable
+ (name packer)
+ (libraries psq ke jsonm fmt rresult cmdliner ocplib-json-typed lwt lwt.unix))

unikernel/duniverse/ke/example/packer.ml

@@ -0,0 +1,323 @@
+let () = Printexc.record_backtrace true
+
+module type GRAPH = sig
+  type t
+  type id
+  type value
+  type error = private [> `Not_found ]
+
+  val pp_error : error Fmt.t
+  val preds : value -> id list
+  val get : t -> id -> (value, error) result Lwt.t
+  val compare : value -> value -> int
+end
+
+module Make (Q : Ke.Sigs.R) (G : GRAPH with type id = nativeint) = struct
+  open Lwt
+
+  exception Graph of G.error
+
+  module Node = struct
+    type t = { value : G.value; mutable color : [ `White | `Black ] }
+
+    let compare a b = G.compare a.value b.value
+  end
+
+  module Pq = Psq.Make (Nativeint) (Node)
+  module Map = Map.Make (Nativeint)
+
+  let pack graph exclude roots =
+    let store = Hashtbl.create 128 in
+    let memoize get id =
+      try
+        let ret = Hashtbl.find store id in
+        Lwt.return (Some ret)
+      with Not_found -> (
+        get id >>= function
+        | Ok value ->
+            let node = { Node.value; color = `White } in
+            Hashtbl.add store id node;
+            Lwt.return (Some node)
+        | Error `Not_found -> Lwt.return None
+        | Error err -> Lwt.fail (Graph err))
+    in
+    let preds v = G.preds v in
+    let get = memoize (G.get graph) in
+    let all_blacks pq =
+      Pq.fold
+        (fun _ -> function
+          | { Node.color = `Black; _ } -> ( && ) true
+          | _ -> ( && ) false)
+        true pq
+    in
+    let propagate { Node.value; color } =
+      let p = preds value in
+      let q = Q.create ~capacity:(List.length p) Bigarray.Nativeint in
+      let rec go () =
+        match Q.pop q with
+        | Some id -> (
+            try
+              let node = Hashtbl.find store id in
+              node.Node.color <- color;
+              go (List.iter (Q.push q) (preds node.Node.value))
+            with Not_found -> go ())
+        | None -> ()
+      in
+      List.iter (Q.push q) p;
+      go ()
+    in
+    let rec garbage pq =
+      if all_blacks pq then Lwt.return ()
+      else
+        match Pq.pop pq with
+        | Some ((_, { Node.value; color = `Black }), pq) ->
+            Lwt_list.fold_left_s
+              (fun pq id ->
+                get id >>= function
+                | Some ({ Node.color = `White; _ } as node) ->
+                    node.Node.color <- `Black;
+                    propagate node;
+                    Lwt.return (Pq.add id node pq)
+                | Some node -> Lwt.return (Pq.add id node pq)
+                | None -> Lwt.return pq)
+              pq (preds value)
+            >>= garbage
+        | Some ((_, { Node.value; _ }), pq) ->
+            Lwt_list.fold_left_s
+              (fun pq id ->
+                get id >>= function
+                | None -> Lwt.return pq
+                | Some node -> Lwt.return (Pq.add id node pq))
+              pq (preds value)
+            >>= garbage
+        | None -> Lwt.return ()
+    in
+    let collect () =
+      Hashtbl.fold
+        (fun id -> function
+          | { Node.color = `White; value } -> Map.add id value
+          | _ -> fun acc -> acc)
+        store Map.empty
+    in
+    Lwt_list.map_s
+      (fun id ->
+        get id >>= function
+        | Some node -> Lwt.return (Some (id, node))
+        | None -> Lwt.return None)
+      roots
+    >>= fun roots ->
+    Lwt_list.map_s
+      (fun id ->
+        get id >>= function
+        | Some node ->
+            node.Node.color <- `Black;
+            Lwt.return (Some (id, node))
+        | None -> Lwt.return None)
+      exclude
+    >|= List.append roots
+    >|= List.fold_left
+          (fun acc -> function None -> acc | Some x -> x :: acc)
+          []
+    >|= Pq.of_list
+    >>= fun pq -> garbage pq >|= collect
+end
+
+module Git = struct
+  type t = unit
+  type id = nativeint
+  type value = { name : string; time : int64; ancestors : nativeint list }
+  type error = [ `Not_found ]
+
+  let pp_error ppf = function `Not_found -> Fmt.string ppf "`Not_found"
+  let store : (id, value) Hashtbl.t = Hashtbl.create 16
+  let preds { ancestors; _ } = ancestors
+
+  let get () id =
+    try Lwt.return_ok (Hashtbl.find store id)
+    with Not_found -> Lwt.return_error `Not_found
+
+  let compare { time = a; _ } { time = b; _ } = Int64.compare a b
+end
+
+module Packer = Make (Ke.Rke) (Git)
+
+let json =
+  let open Json_encoding in
+  let name = req "name" string in
+  let time = req "time" (conv Int64.to_string Int64.of_string string) in
+  let ancestors =
+    req "ancestors" (list (conv Nativeint.to_int32 Nativeint.of_int32 int32))
+  in
+  conv
+    (fun { Git.name; time; ancestors } -> (name, time, ancestors))
+    (fun (name, time, ancestors) -> { Git.name; time; ancestors })
+    (obj3 name time ancestors)
+
+type await = [ `Await ]
+type error = [ `Error of Jsonm.error ]
+type eoi = [ `End ]
+type value = [ `Null | `Bool of bool | `String of string | `Float of float ]
+
+let pp_json ppf v =
+  let rec pp_value ppf = function
+    | `Bool v -> Fmt.bool ppf v
+    | `String v -> Fmt.quote Fmt.text ppf v
+    | `Float v -> Fmt.float ppf v
+    | `Null -> Fmt.string ppf "<null>"
+    | `A l -> pp_arr ppf l
+    | `O l -> pp_obj ppf l
+  and pp_arr ppf arr = Fmt.(using Array.of_list (Dump.array pp_value)) ppf arr
+  and pp_obj ppf obj =
+    Fmt.Dump.iter_bindings
+      (fun f -> List.iter (fun (k, v) -> f k v))
+      Fmt.(any "object")
+      Fmt.string pp_value ppf obj
+  in
+  pp_value ppf v
+
+let of_database ic : Git.value list =
+  let decoder = Jsonm.decoder (`Channel ic) in
+
+  let error (`Error err) = Fmt.invalid_arg "%a" Jsonm.pp_error err in
+  let end_of_input `End = Fmt.invalid_arg "Unexpected end of input" in
+
+  let rec arr acc k =
+    match Jsonm.decode decoder with
+    | #await -> assert false
+    | #error as v -> error v
+    | #eoi as v -> end_of_input v
+    | `Lexeme `Ae -> k (`A (List.rev acc))
+    | `Lexeme v -> base (fun v -> arr (v :: acc) k) v
+  and name n k =
+    match Jsonm.decode decoder with
+    | #await -> assert false
+    | #error as v -> error v
+    | #eoi as v -> end_of_input v
+    | `Lexeme v -> base (fun v -> k (n, v)) v
+  and obj acc k =
+    match Jsonm.decode decoder with
+    | #await -> assert false
+    | #error as v -> error v
+    | #eoi as v -> end_of_input v
+    | `Lexeme `Oe -> k (`O (List.rev acc))
+    | `Lexeme (`Name n) -> name n (fun v -> obj (v :: acc) k)
+    | `Lexeme v -> Fmt.invalid_arg "Unexpected lexeme: %a" Jsonm.pp_lexeme v
+  and base k = function
+    | #value as v -> k v
+    | `Os -> obj [] k
+    | `As -> arr [] k
+    | `Ae | `Oe -> Fmt.invalid_arg "Unexpected end of array/object"
+    | `Name n -> Fmt.invalid_arg "Unexpected key: %s" n
+  in
+
+  let go k =
+    match Jsonm.decode decoder with
+    | #await -> assert false
+    | #error as v -> error v
+    | #eoi as v -> end_of_input v
+    | `Lexeme (#Jsonm.lexeme as lexeme) -> base k lexeme
+  in
+
+  go Json_encoding.(destruct (list json))
+
+let flat_json json : Jsonm.lexeme list =
+  let rec arr acc k = function
+    | [] -> k (List.rev (`Ae :: acc))
+    | (#value as x) :: r -> arr (x :: acc) k r
+    | `A l :: r -> arr [ `As ] (fun l -> arr (List.rev_append l acc) k r) l
+    | `O l :: r -> obj [ `Os ] (fun l -> arr (List.rev_append l acc) k r) l
+  and obj acc k = function
+    | [] -> k (List.rev (`Oe :: acc))
+    | (n, x) :: r ->
+        base (fun v -> obj (List.rev_append v (`Name n :: acc)) k r) x
+  and base k = function
+    | `A l -> arr [ `As ] k l
+    | `O l -> obj [ `Os ] k l
+    | #value as x -> k [ x ]
+  in
+
+  base (fun l -> l) json
+
+external identity : 'a -> 'a = "%identity"
+
+let show ppf map =
+  let json =
+    Json_encoding.(
+      construct (list json) (List.map snd (Packer.Map.bindings map)))
+  in
+  let raw = Bytes.create 0x800 in
+  let encoder = Jsonm.encoder `Manual in
+  let rec write k = function
+    | `Ok -> k ()
+    | `Partial ->
+        Fmt.string ppf (Bytes.sub_string raw 0 (Jsonm.Manual.dst_rem encoder));
+        Jsonm.Manual.dst encoder raw 0 (Bytes.length raw);
+        write k (Jsonm.encode encoder `Await)
+  in
+  let rec go k = function
+    | [] -> write k (Jsonm.encode encoder `End)
+    | lexeme :: r ->
+        write (fun () -> go k r) (Jsonm.encode encoder (`Lexeme lexeme))
+  in
+  let lexemes = flat_json json in
+  go identity lexemes
+
+let run database exclude roots =
+  let graph = of_database (open_in database) in
+  let () =
+    List.iteri
+      (fun id value -> Hashtbl.add Git.store (Nativeint.of_int id) value)
+      graph
+  in
+  match
+    Lwt_main.run
+      Lwt.Infix.(
+        Packer.pack () exclude roots >|= Fmt.fmt "%a\n%!" Fmt.stdout show)
+  with
+  | () -> `Ok ()
+  | exception Packer.Graph err ->
+      `Error (false, Fmt.str "Retrieve an error: %a." Git.pp_error err)
+
+open Cmdliner
+
+let database =
+  let parser s =
+    if Sys.file_exists s then Ok s
+    else Rresult.R.error_msgf "File %s does not exists" s
+  in
+  let pp = Fmt.string in
+  Arg.conv (parser, pp)
+
+let id =
+  let parser s =
+    match Nativeint.of_string_opt s with
+    | Some n -> Ok n
+    | None -> Rresult.R.error_msgf "Invalid id: %s" s
+  in
+  let pp = Fmt.nativeint in
+  Arg.conv (parser, pp)
+
+let database =
+  let doc = "Database of graph." in
+  Arg.(
+    required
+    & opt (some database) None
+    & info [ "d"; "database" ] ~doc ~docv:"<FILE>")
+
+let roots =
+  let doc = "Roots of graph." in
+  Arg.(non_empty & opt (list id) [] & info [ "r"; "roots" ] ~doc ~docv:"<LST>")
+
+let exclude =
+  let doc = "Excluded nodes of graph." in
+  Arg.(
+    non_empty & opt (list id) [] & info [ "e"; "exclude" ] ~doc ~docv:"<LST>")
+
+let command =
+  let doc = "Example of ke." in
+  let exits = Cmd.Exit.defaults in
+  Cmd.v
+    (Cmd.info "packer" ~version:"dev" ~doc ~exits)
+    Term.(ret (const run $ database $ exclude $ roots))
+
+let () = Cmd.(exit @@ eval command)

unikernel/duniverse/ke/fuzz/dune

@@ -0,0 +1,3 @@
+(executable
+ (name fuzz)
+ (libraries crowbar bigstringaf ke))

unikernel/duniverse/ke/fuzz/fuzz.ml

@@ -0,0 +1,278 @@
+type 'a action = Push of 'a * 'a action | Pop of 'a action | Empty
+
+exception Invalid
+
+external identity : 'a -> 'a = "%identity"
+
+let valid a =
+  let rec go k = function
+    | Empty -> k 0
+    | Push (_, a) -> go (fun len -> k (succ len)) a
+    | Pop a -> go (function 0 -> raise Invalid | n -> k (pred n)) a
+  in
+  go identity a
+
+let push x a = Push (x, a)
+let empty = Empty
+let pop a = Pop a
+let () = assert (valid empty = 0)
+let () = assert (valid (push 0 empty) = 1)
+let () = assert (valid (push 1 (push 0 empty)) = 2)
+let () = assert (valid (pop (push 0 empty)) = 0)
+
+let () =
+  assert (match valid (pop empty) with _ -> false | exception Invalid -> true)
+
+module Peano = struct type zero = Zero type 'a succ = Succ end
+module Refl = struct type ('a, 'b) t = Refl : ('a, 'a) t end
+
+module Value = struct
+  type 'a value =
+    | Zero : Peano.zero value
+    | Succ : 'a value -> 'a Peano.succ value
+
+  type t = V : 'a value -> t
+
+  let of_int n =
+    let rec go k = function
+      | 0 -> k (V Zero)
+      | n -> go (fun (V n) -> k (V (Succ n))) (pred n)
+    in
+    if n < 0 then Fmt.invalid_arg "Value.of_int" else go identity n
+
+  let to_int v =
+    let rec go : type a. (int -> 'r) -> a value -> 'r =
+     fun k -> function Zero -> k 0 | Succ x -> go (fun v -> k (succ v)) x
+    in
+    go identity v
+
+  let () = assert (to_int Zero = 0)
+  let () = assert (to_int (Succ Zero) = 1)
+  let () = assert (to_int (Succ (Succ Zero)) = 2)
+  let pp : t Fmt.t = fun ppf (V v) -> Fmt.int ppf (to_int v)
+
+  let is_zero : type a. a value -> (a, Peano.zero) Refl.t option = function
+    | Zero -> Some Refl.Refl
+    | Succ _ -> None
+
+  type 'a is_not_zero =
+    | Is_not_zero : ('a, _ Peano.succ) Refl.t -> 'a is_not_zero
+
+  let is_not_zero : type a. a value -> a is_not_zero option = function
+    | Zero -> None
+    | Succ _ -> Some (Is_not_zero Refl.Refl)
+end
+
+module Stack = struct
+  type ('a, 'l) action =
+    | Push : 'a * ('a, 'l) action -> ('a, 'l Peano.succ) action
+    | Pop : ('a, 'l Peano.succ) action -> ('a, 'l) action
+    | Empty : ('a, Peano.zero) action
+
+  type 'a t = V : ('a, 'l) action -> 'a t
+
+  let rec pp : type l. 'a Fmt.t -> ('a, l) action Fmt.t =
+   fun pp_elt ppf -> function
+    | Push (v, a) ->
+        Fmt.pf ppf "@[<1>(Push %a)]" Fmt.(Dump.pair pp_elt (pp pp_elt)) (v, a)
+    | Pop a -> Fmt.pf ppf "@[<1>(Pop %a)]" (pp pp_elt) a
+    | Empty -> Fmt.pf ppf "Empty"
+
+  let rec length : type a l. (a, l) action -> l Value.value = function
+    | Empty -> Value.Zero
+    | Pop a -> ( match length a with Value.Succ x -> x)
+    | Push (_, a) -> Value.Succ (length a)
+
+  let is_empty : type l. ('a, l) action -> (l, Peano.zero) Refl.t option =
+    function
+    | Empty -> Some Refl.Refl
+    | Push _ -> None
+    | Pop a -> (
+        match length a with
+        | Value.Succ Value.Zero -> Some Refl.Refl
+        | Value.Succ _ -> None)
+
+  type 'a is_not_empty =
+    | Is_not_empty : ('a, _ Peano.succ) Refl.t -> 'a is_not_empty
+
+  let is_not_empty : type l. ('a, l) action -> l is_not_empty option = function
+    | Empty -> None
+    | Push _ -> Some (Is_not_empty Refl.Refl)
+    | Pop a -> (
+        match length a with
+        | Value.Succ Value.Zero -> None
+        | Value.Succ (Value.Succ _) -> Some (Is_not_empty Refl.Refl))
+end
+
+open Crowbar
+
+type tree = Tree of Value.t * tree list * bool
+
+let rec list_of_tree (Tree (v, x, pop)) : [ `Push of Value.t | `Pop ] list =
+  if pop then [ `Push v ] @ List.concat (List.map list_of_tree x) @ [ `Pop ]
+  else [ `Push v ] @ List.concat (List.map list_of_tree x)
+
+let generate : tree gen =
+  let value = map [ range 30 ] Value.of_int in
+  fix @@ fun m -> map [ value; list m; bool ] (fun v l pop -> Tree (v, l, pop))
+
+let action_of_tree tree : Value.t Stack.t =
+  let lst = list_of_tree tree in
+  List.fold_left
+    (fun (Stack.V acc) -> function
+      | `Push v -> Stack.(V (Push (v, acc)))
+      | `Pop -> (
+          match Stack.is_not_empty acc with
+          | Some (Stack.Is_not_empty Refl.Refl) -> Stack.V (Stack.Pop acc)
+          | None -> bad_test ()))
+    Stack.(V Empty)
+    lst
+
+(* XXX(dinosaure): [Stdlib.Queue] is oracle. *)
+
+module Compare = struct
+  exception Not_equal
+
+  let fke q fke =
+    let q' = Queue.copy q in
+    try
+      Ke.Fke.iter
+        (fun x ->
+          let x' = Queue.pop q' in
+          if x <> x' then raise Not_equal)
+        fke;
+      true
+    with Not_equal | Queue.Empty -> false
+
+  let rke q rke =
+    let q' = Queue.copy q in
+    try
+      Ke.Rke.iter
+        (fun x ->
+          let x' = Queue.pop q' in
+          if x <> x' then raise Not_equal)
+        rke;
+      true
+    with Not_equal | Queue.Empty -> false
+end
+
+let iter iter pp_name pp_elt ppf v =
+  let is_first = ref true in
+  let pp_elt v =
+    if !is_first then is_first := false else Fmt.pf ppf "@ ";
+    Fmt.pf ppf "@[%a@]" pp_elt v
+  in
+  Fmt.pf ppf "@[<1>(%a@ " pp_name v;
+  iter pp_elt v;
+  Fmt.pf ppf ")@]"
+
+let pp_fke pp_elt = iter Ke.Fke.iter (Fmt.any "fke") pp_elt
+let pp_rke pp_elt = iter Ke.Rke.iter (Fmt.any "rke") pp_elt
+
+let rke_of_action a =
+  let q =
+    Ke.Rke.create ~capacity:(Value.to_int (Stack.length a)) Bigarray.Int
+  in
+  let rec go : type l. (Value.t, l) Stack.action -> unit = function
+    | Stack.Empty -> ()
+    | Stack.Push (Value.V v, a) ->
+        go a;
+        Ke.Rke.push q (Value.to_int v)
+    | Stack.Pop a ->
+        go a;
+        ignore @@ Ke.Rke.pop_exn q
+  in
+  go a;
+  q
+
+let queue_of_action a =
+  let q = Queue.create () in
+  let rec go : type l. (Value.t, l) Stack.action -> unit = function
+    | Stack.Empty -> ()
+    | Stack.Push (Value.V v, a) ->
+        go a;
+        Queue.push (Value.to_int v) q
+    | Stack.Pop a ->
+        go a;
+        ignore @@ Queue.pop q
+  in
+  go a;
+  q
+
+let fke_of_action a =
+  let rec go : type l. (int Ke.Fke.t -> 'r) -> (Value.t, l) Stack.action -> 'r =
+   fun k -> function
+    | Stack.Empty -> k Ke.Fke.empty
+    | Stack.Push (Value.V v, a) ->
+        go
+          (fun q ->
+            let q = Ke.Fke.push q (Value.to_int v) in
+            k q)
+          a
+    | Stack.Pop a ->
+        go
+          (fun q ->
+            let _, q = Ke.Fke.pop_exn q in
+            k q)
+          a
+  in
+  go identity a
+
+let () =
+  add_test ~name:"queue" [ map [ generate ] action_of_tree ]
+  @@ fun (Stack.V a) ->
+  let fke = fke_of_action a in
+  let rke = rke_of_action a in
+  let queue = queue_of_action a in
+  if not (Compare.fke queue fke) then
+    failf "%a <> %a" Fmt.(Dump.queue int) queue (pp_fke Fmt.int) fke;
+  if not (Compare.rke queue rke) then
+    failf "%a <> %a" Fmt.(Dump.queue int) queue (pp_rke Fmt.int) rke;
+  ()
+
+let ( >>= ) = dynamic_bind
+let failf fmt = Fmt.kstr fail fmt
+
+let blit src src_off dst dst_off len =
+  let a = Bigarray.Array1.sub src src_off len in
+  let b = Bigarray.Array1.sub dst dst_off len in
+  Bigarray.Array1.blit a b
+
+let blit_from_string src src_off dst dst_off len =
+  Bigstringaf.blit_from_string src ~src_off dst ~dst_off ~len
+
+let () =
+  add_test ~name:"compress-and-push"
+    [ range 0x100 >>= bytes_fixed; range 0x100 >>= bytes_fixed ]
+  @@ fun fill0 fill1 ->
+  let capacity = String.length fill0 + String.length fill1 in
+  let q, capacity = Ke.Rke.Weighted.create ~capacity Bigarray.Char in
+  match
+    Ke.Rke.Weighted.N.push q ~blit:blit_from_string ~length:String.length fill0
+  with
+  | Some [ fill0' ] -> (
+      let fill0' = Bigstringaf.create (Bigstringaf.length fill0') in
+      Ke.Rke.Weighted.compress q;
+      Ke.Rke.Weighted.N.keep_exn q ~blit ~length:Bigstringaf.length fill0';
+      match
+        Ke.Rke.Weighted.N.push q ~blit:blit_from_string ~length:String.length
+          fill1
+      with
+      | Some [ fill1' ] ->
+          let a =
+            Bigstringaf.memcmp_string fill0' 0 fill0 0 (String.length fill0)
+          in
+          let b =
+            Bigstringaf.memcmp_string fill1' 0 fill1 0 (String.length fill1)
+          in
+          if a <> 0 || b <> 0 then failf "Queue differs from inputs"
+      | Some _ -> failf "push returns multiple payloads"
+      | None ->
+          if String.length fill0 + String.length fill1 <= capacity then
+            failf "push fails for unknow reason"
+          else bad_test ())
+  | Some _ -> failf "push returns multiple payloads."
+  | None ->
+      if String.length fill0 <= capacity then
+        failf "push fails for unknow reason"
+      else bad_test ()

unikernel/duniverse/ke/ke.opam

@@ -0,0 +1,34 @@
+version: "0.6"
+opam-version: "2.0"
+name:         "ke"
+maintainer:   "Romain Calascibetta <romain.calascibetta@gmail.com>"
+authors:      "Romain Calascibetta <romain.calascibetta@gmail.com>"
+homepage:     "https://github.com/mirage/ke"
+bug-reports:  "https://github.com/mirage/ke/issues"
+dev-repo:     "git+https://github.com/mirage/ke.git"
+doc:          "https://mirage.github.io/ke/"
+license:      "MIT"
+synopsis:     "Queue implementation"
+description:  """Queue implementation in OCaml (functional and imperative queue)"""
+
+build: [ "dune" "build" "-p" name "-j" jobs ]
+run-test: [ "dune" "runtest" "-p" name "-j" jobs ]
+
+depends: [
+  "ocaml"      {>= "4.08.0"}
+  "dune"       {>= "2.0"}
+  "fmt"        {>= "0.8.7"}
+  "alcotest"          {with-test}
+  "bigstringaf"       {with-test}
+  "bechamel"          {with-test}
+  "bechamel-notty"    {with-test}
+  "bechamel-perf"     {with-test}
+  "ocplib-json-typed" {with-test}
+  "core_bench"        {with-test & >= "v0.15"}
+  "lwt"               {with-test}
+  "crowbar"           {with-test}
+  "rresult"           {with-test}
+  "jsonm"             {with-test}
+  "psq"               {with-test}
+  "cmdliner"          {>= "1.1.0" & with-test}
+]

unikernel/duniverse/ke/lib/dune

@@ -0,0 +1,4 @@
+(library
+ (name ke)
+ (public_name ke)
+ (libraries fmt))

unikernel/duniverse/ke/lib/fke.ml

@@ -0,0 +1,352 @@
+[@@@warning "-37"]
+
+module Peano = struct
+  type zero = Zero
+  type 'a succ = Succ
+  type one = zero succ
+  type two = zero succ succ
+  type three = zero succ succ
+end
+
+type ('a, 'l) digit =
+  | Zero : ('a, Peano.zero) digit
+  | One : 'a -> ('a, Peano.one) digit
+  | Two : 'a * 'a -> ('a, Peano.two) digit
+  | Three : 'a * 'a * 'a -> ('a, Peano.three) digit
+
+type 'a t =
+  | Shallow : ('a, 'l) digit -> 'a t
+  | Deep : {
+      s : int;
+      f : ('a, 'f Peano.succ) digit;
+      m : ('a * 'a) t Lazy.t;
+      r : ('a, 'r Peano.succ) digit;
+    }
+      -> 'a t
+
+let empty = Shallow Zero
+
+exception Empty
+
+let _one x = Shallow (One x)
+let _two x y = Shallow (Two (x, y))
+let _three x y z = Shallow (Three (x, y, z))
+let _deep s f m r = Deep { s; f; m; r }
+
+let is_empty : type a. a t -> bool = function
+  | Shallow Zero -> true
+  | Shallow _ | Deep _ -> false
+
+let rec push : type a. a t -> a -> a t =
+ fun q x ->
+  match q with
+  | Shallow Zero -> _one x
+  | Shallow (One y) -> _two y x
+  | Shallow (Two (y, z)) -> _three y z x
+  | Shallow (Three (a, b, c)) ->
+      _deep 4 (Two (a, b)) (Lazy.from_val empty) (Two (c, x))
+  | Deep { s; f; m; r = One y } -> _deep (s + 1) f m (Two (y, x))
+  | Deep { s; f; m; r = Two (y, z) } -> _deep (s + 1) f m (Three (y, z, x))
+  | Deep { s; f; m = (lazy q'); r = Three (y, z, z') } ->
+      _deep (s + 1) f (lazy (push q' (y, z))) (Two (z', x))
+
+let rec pop_exn : type a. a t -> a * a t =
+ fun q ->
+  match q with
+  | Shallow Zero -> raise Empty
+  | Shallow (One x) -> (x, empty)
+  | Shallow (Two (x, y)) -> (x, _one y)
+  | Shallow (Three (x, y, z)) -> (x, _two y z)
+  | Deep { s; f = One x; m = (lazy q'); r } ->
+      if is_empty q' then (x, Shallow r)
+      else
+        let (y, z), q' = pop_exn q' in
+        (x, _deep (s - 1) (Two (y, z)) (Lazy.from_val q') r)
+  | Deep { s; f = Two (x, y); m; r } -> (x, _deep (s - 1) (One y) m r)
+  | Deep { s; f = Three (x, y, z); m; r } -> (x, _deep (s - 1) (Two (y, z)) m r)
+
+let rec tail_exn : type a. a t -> a t * a =
+ fun q ->
+  match q with
+  | Shallow Zero -> raise Empty
+  | Shallow (One x) -> (empty, x)
+  | Shallow (Two (x, y)) -> (_one x, y)
+  | Shallow (Three (x, y, z)) -> (_two x y, z)
+  | Deep { s; f; m = (lazy q'); r = One x } ->
+      if is_empty q' then (Shallow f, x)
+      else
+        let q'', (y, z) = tail_exn q' in
+        (_deep (s - 1) f (Lazy.from_val q'') (Two (y, z)), x)
+  | Deep { s; f; m; r = Two (x, y) } -> (_deep (s - 1) f m (One x), y)
+  | Deep { s; f; m; r = Three (x, y, z) } -> (_deep (s - 1) f m (Two (x, y)), z)
+
+let peek_exn : type a. a t -> a =
+ fun q ->
+  match q with
+  | Shallow Zero -> raise Empty
+  | Shallow (One x) -> x
+  | Shallow (Two (x, _)) -> x
+  | Shallow (Three (x, _, _)) -> x
+  | Deep { f = One x; _ } -> x
+  | Deep { f = Two (x, _); _ } -> x
+  | Deep { f = Three (x, _, _); _ } -> x
+
+let pop q = try Some (pop_exn q) with Empty -> None
+let tail q = try Some (tail_exn q) with Empty -> None
+let peek q = try Some (peek_exn q) with Empty -> None
+
+let rec cons : type a. a t -> a -> a t =
+ fun q x ->
+  match q with
+  | Shallow Zero -> _one x
+  | Shallow (One y) -> _two x y
+  | Shallow (Two (y, z)) -> _three x y z
+  | Shallow (Three (y, z, z')) ->
+      _deep 4 (Two (x, y)) (Lazy.from_val empty) (Two (z, z'))
+  | Deep { s; f = One y; m; r } -> _deep (s + 1) (Two (x, y)) m r
+  | Deep { s; f = Two (y, z); m; r } -> _deep (s + 1) (Three (x, y, z)) m r
+  | Deep { s; f = Three (y, z, z'); m = (lazy q'); r } ->
+      _deep (s + 1) (Three (x, y, z)) (lazy (cons q' (z, z'))) r
+
+let iter : type a. (a -> unit) -> a t -> unit =
+ fun f q ->
+  let rec go : type a. (a -> unit) -> a t -> unit =
+   fun f -> function
+    | Shallow Zero -> ()
+    | Shallow (One x) -> f x
+    | Shallow (Two (x, y)) ->
+        f x;
+        f y
+    | Shallow (Three (x, y, z)) ->
+        f x;
+        f y;
+        f z
+    | Deep { f = hd; m = (lazy q); r = tl; _ } ->
+        go f (Shallow hd);
+        go
+          (fun (x, y) ->
+            f x;
+            f y)
+          q;
+        go f (Shallow tl)
+  in
+  go f q
+
+let rev_iter : type a. (a -> unit) -> a t -> unit =
+ fun f q ->
+  let rec go : type a. (a -> unit) -> a t -> unit =
+   fun f -> function
+    | Shallow Zero -> ()
+    | Shallow (One x) -> f x
+    | Shallow (Two (y, x)) ->
+        f x;
+        f y
+    | Shallow (Three (z, y, x)) ->
+        f x;
+        f y;
+        f z
+    | Deep { f = hd; m = (lazy q); r = tl; _ } ->
+        go f (Shallow tl);
+        go
+          (fun (y, x) ->
+            f x;
+            f y)
+          q;
+        go f (Shallow hd)
+  in
+  go f q
+
+let fold : type acc x. (acc -> x -> acc) -> acc -> x t -> acc =
+ fun f a q ->
+  let rec go : type acc x. (acc -> x -> acc) -> acc -> x t -> acc =
+   fun f a -> function
+    | Shallow Zero -> a
+    | Shallow (One x) -> f a x
+    | Shallow (Two (x, y)) -> f (f a x) y
+    | Shallow (Three (x, y, z)) -> f (f (f a x) y) z
+    | Deep { f = hd; m = (lazy q); r = tl; _ } ->
+        let a = go f a (Shallow hd) in
+        let a = go (fun a (x, y) -> f (f a x) y) a q in
+        go f a (Shallow tl)
+  in
+  go f a q
+
+let length = function
+  | Deep { s; _ } -> s
+  | Shallow Zero -> 0
+  | Shallow (One _) -> 1
+  | Shallow (Two _) -> 2
+  | Shallow (Three _) -> 3
+
+let pp ?sep pp_elt = Fmt.iter ?sep iter pp_elt
+let dump pp_elt = Fmt.Dump.iter iter (Fmt.any "fke") pp_elt
+
+module Weighted = struct
+  type ('a, 'b) t = {
+    r : int;
+    w : int;
+    c : int;
+    k : ('a, 'b) Bigarray.kind;
+    v : ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t;
+  }
+
+  exception Empty
+  exception Full
+
+  let[@inline always] mask t v = v land (t.c - 1)
+  let[@inline always] empty t = t.r = t.w
+  let[@inline always] size t = t.w - t.r
+  let[@inline always] full t = size t = t.c
+  let[@inline always] available t = t.c - (t.w - t.r)
+  let is_empty t = (empty [@inlined]) t
+  let length q = size q
+
+  let[@inline always] to_power_of_two v =
+    let res = ref (pred v) in
+    res := !res lor (!res lsr 1);
+    res := !res lor (!res lsr 2);
+    res := !res lor (!res lsr 4);
+    res := !res lor (!res lsr 8);
+    res := !res lor (!res lsr 16);
+    succ !res
+
+  let[@inline always] is_power_of_two v = v <> 0 && v land (lnot v + 1) = v
+
+  let create ?capacity kind =
+    let capacity =
+      match capacity with
+      | None | Some 0 -> 1
+      | Some n ->
+          if n < 0 then Fmt.invalid_arg "Rke.Weighted.create"
+          else to_power_of_two n
+    in
+    ( {
+        r = 0;
+        w = 0;
+        c = capacity;
+        k = kind;
+        v = Bigarray.Array1.create kind Bigarray.c_layout capacity;
+      },
+      capacity )
+
+  let copy t =
+    let v = Bigarray.Array1.create t.k Bigarray.c_layout t.c in
+    Bigarray.Array1.blit t.v v;
+    { r = t.r; w = t.w; c = t.c; v; k = t.k }
+
+  let from v =
+    if not (is_power_of_two (Bigarray.Array1.dim v)) then
+      Fmt.invalid_arg "RBA.from";
+    let c = Bigarray.Array1.dim v in
+    let k = Bigarray.Array1.kind v in
+    { r = 0; w = 0; c; k; v }
+
+  let push_exn t v =
+    if (full [@inlined]) t then raise Full;
+    Bigarray.Array1.unsafe_set t.v ((mask [@inlined]) t t.w) v;
+    { t with w = t.w + 1 }
+
+  let push t v = try Some (push_exn t v) with Full -> None
+
+  let cons_exn t v =
+    if (full [@inlined]) t then raise Full;
+    let i = t.r - 1 in
+    Bigarray.Array1.unsafe_set t.v ((mask [@inlined]) t i) v;
+    { t with r = i }
+
+  let cons t v = try Some (cons_exn t v) with Full -> None
+
+  let pop_exn t =
+    if (empty [@inlined]) t then raise Empty;
+    let r = Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t t.r) in
+    (r, { t with r = t.r + 1 })
+
+  let pop t = try Some (pop_exn t) with Empty -> None
+
+  let peek_exn t =
+    if (empty [@inlined]) t then raise Empty;
+    Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t t.r)
+
+  let peek t = try Some (peek_exn t) with Empty -> None
+
+  module N = struct
+    type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t
+    type ('a, 'b) blit = 'a -> int -> 'b -> int -> int -> unit
+    type 'a length = 'a -> int
+
+    let push_exn t ~blit ~length ?(off = 0) ?len v =
+      let len = match len with None -> length v - off | Some len -> len in
+      if (available [@inlined]) t < len then raise Full;
+      let msk = (mask [@inlined]) t t.w in
+      let pre = t.c - msk in
+      let rst = len - pre in
+      let ret =
+        if rst > 0 then (
+          blit v off t.v msk pre;
+          blit v (off + pre) t.v 0 rst;
+          [
+            Bigarray.Array1.sub t.v ((mask [@inlined]) t t.w) pre;
+            Bigarray.Array1.sub t.v 0 rst;
+          ])
+        else (
+          blit v off t.v msk len;
+          [ Bigarray.Array1.sub t.v ((mask [@inlined]) t t.w) len ])
+      in
+      (ret, { t with w = t.w + len })
+
+    let push t ~blit ~length ?off ?len v =
+      try Some (push_exn t ~blit ~length ?off ?len v) with Full -> None
+
+    let keep_exn t ~blit ~length ?(off = 0) ?len v =
+      let len = match len with None -> length v | Some len -> len in
+      if (size [@inlined]) t < len then raise Empty;
+      let msk = (mask [@inlined]) t t.r in
+      let pre = t.c - msk in
+      let rst = len - pre in
+      if rst > 0 then (
+        blit t.v msk v off pre;
+        blit t.v 0 v (off + pre) rst)
+      else blit t.v msk v off len
+
+    let keep t ~blit ~length ?off ?len v =
+      try Some (keep_exn t ~blit ~length ?off ?len v) with Empty -> None
+
+    let unsafe_shift t len = { t with r = t.r + len }
+
+    let shift_exn t len =
+      if (size [@inlined]) t < len then raise Empty;
+      unsafe_shift t len
+
+    let shift t len = try Some (shift_exn t len) with Empty -> None
+  end
+
+  let iter f t =
+    let idx = ref t.r in
+    let max = t.w in
+    while !idx <> max do
+      f (Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t !idx));
+      incr idx
+    done
+
+  let rev_iter f t =
+    if t.r == t.w then ()
+    else
+      let idx = ref (pred t.w) in
+      let min = t.r in
+      while
+        f (Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t !idx));
+        !idx <> min
+      do
+        decr idx
+      done
+
+  let fold f a t =
+    let a = ref a in
+    iter (fun x -> a := f !a x) t;
+    !a
+
+  let clear t = { t with r = 0; w = 0 }
+  let unsafe_bigarray { v; _ } = v
+  let pp ?sep pp_elt = Fmt.iter ?sep iter pp_elt
+  let dump pp_elt = Fmt.Dump.iter iter (Fmt.any "fke:weighted") pp_elt
+end

unikernel/duniverse/ke/lib/fke.mli

@@ -0,0 +1,2 @@
+include Sigs.F
+module Weighted : Sigs.Weighted.F

unikernel/duniverse/ke/lib/ke.ml

@@ -0,0 +1,3 @@
+module Sigs = Sigs
+module Fke = Fke
+module Rke = Rke

unikernel/duniverse/ke/lib/ke.mli

@@ -0,0 +1,3 @@
+module Sigs = Sigs
+module Fke = Fke
+module Rke = Rke

unikernel/duniverse/ke/lib/rke.ml

@@ -0,0 +1,400 @@
+type ('a, 'b) t = {
+  mutable r : int;
+  mutable w : int;
+  mutable c : int;
+  k : ('a, 'b) Bigarray.kind;
+  mutable v : ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t;
+}
+
+exception Empty
+
+external ( = ) : 'a -> 'a -> bool = "%equal"
+
+let ( = ) (a : int) b = a = b
+let[@inline always] mask t v = v land (t.c - 1)
+let[@inline always] empty t = t.r = t.w
+let[@inline always] size t = t.w - t.r
+let[@inline always] available t = t.c - (t.w - t.r)
+let[@inline always] full t = size t = t.c
+let length q = size q
+
+let[@inline always] to_power_of_two v =
+  let res = ref (pred v) in
+  res := !res lor (!res lsr 1);
+  res := !res lor (!res lsr 2);
+  res := !res lor (!res lsr 4);
+  res := !res lor (!res lsr 8);
+  res := !res lor (!res lsr 16);
+  succ !res
+
+let[@inline always] is_power_of_two v = v <> 0 && v land (lnot v + 1) = v
+let is_empty t = (empty [@inlined]) t
+
+let create ?capacity kind =
+  let capacity =
+    match capacity with
+    | None | Some 0 -> 1
+    | Some n ->
+        if n < 0 then Fmt.invalid_arg "Rke.create" else to_power_of_two n
+  in
+  {
+    r = 0;
+    w = 0;
+    c = capacity;
+    k = kind;
+    v = Bigarray.Array1.create kind Bigarray.c_layout capacity;
+  }
+
+let capacity { c; _ } = c
+
+let copy t =
+  let v = Bigarray.Array1.create t.k Bigarray.c_layout t.c in
+  Bigarray.Array1.blit t.v v;
+  { r = t.r; w = t.w; c = t.c; v; k = t.k }
+
+let grow t want =
+  let max : int -> int -> int = max in
+  let c = to_power_of_two (max 1 (max want (size t))) in
+  if c <> Bigarray.Array1.dim t.v then (
+    let dst = Bigarray.Array1.create t.k Bigarray.c_layout c in
+    let sze = (size [@inlined]) t in
+    let msk = (mask [@inlined]) t t.r in
+    let pre = t.c - msk in
+    let rst = sze - pre in
+    (if rst > 0 then (
+     Bigarray.Array1.(blit (sub t.v msk pre) (sub dst 0 pre));
+     Bigarray.Array1.(blit (sub t.v 0 rst) (sub dst pre rst)))
+    else Bigarray.Array1.(blit (sub t.v msk sze) (sub dst 0 sze)));
+    t.v <- dst;
+    t.w <- sze;
+    t.c <- c;
+    t.r <- 0)
+
+let push t v =
+  if (full [@inlined]) t then grow t (2 * (size [@inlined]) t);
+  Bigarray.Array1.unsafe_set t.v ((mask [@inlined]) t t.w) v;
+  t.w <- t.w + 1
+
+let cons t v =
+  if (full [@inlined]) t then grow t (2 * (size [@inlined]) t);
+  let i = t.r - 1 in
+  Bigarray.Array1.unsafe_set t.v ((mask [@inlined]) t i) v;
+  t.r <- i
+
+let pop_exn t =
+  if (empty [@inlined]) t then raise Empty;
+  let r = Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t t.r) in
+  t.r <- t.r + 1;
+  r
+
+let pop t = try Some (pop_exn t) with Empty -> None
+
+let peek_exn t =
+  if (empty [@inlined]) t then raise Empty;
+  Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t t.r)
+
+let peek t = try Some (peek_exn t) with Empty -> None
+
+let blit src src_off dst dst_off len =
+  let a = Bigarray.Array1.sub src src_off len in
+  let b = Bigarray.Array1.sub dst dst_off len in
+  Bigarray.Array1.blit a b
+
+let compress t =
+  let len = length t in
+  let msk = (mask [@inlined]) t t.r in
+  let pre = t.c - msk in
+  let rst = len - pre in
+  if rst > 0 then (
+    if (available [@inlined]) t >= pre then (
+      (* XXX(dinosaure): in this case, [pre + rst <= msk], so [blit] will not
+         overlap bytes at the end of [t.v] (at offset [msk]). *)
+      blit t.v 0 t.v pre rst;
+      blit t.v msk t.v 0 pre)
+    else
+      let tmp = Bigarray.Array1.create t.k Bigarray.c_layout pre in
+      blit t.v msk tmp 0 pre;
+      blit t.v 0 t.v pre rst;
+      blit tmp 0 t.v 0 pre)
+  else blit t.v msk t.v 0 len;
+  t.r <- 0;
+  t.w <- len
+
+module N = struct
+  type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t
+  type ('a, 'b) blit = 'a -> int -> 'b -> int -> int -> unit
+  type 'a length = 'a -> int
+
+  let push t ~blit ~length ?(off = 0) ?len v =
+    let len = match len with None -> length v - off | Some len -> len in
+    if (available [@inlined]) t < len then grow t (len + (size [@inlined]) t);
+    let msk = (mask [@inlined]) t t.w in
+    let pre = t.c - msk in
+    let rst = len - pre in
+    if rst > 0 then (
+      blit v off t.v msk pre;
+      blit v (off + pre) t.v 0 rst)
+    else blit v off t.v msk len;
+    t.w <- t.w + len
+
+  let keep_exn t ~blit ~length ?(off = 0) ?len v =
+    let len = match len with None -> length v - off | Some len -> len in
+    if (size [@inlined]) t < len then raise Empty;
+    let msk = (mask [@inlined]) t t.r in
+    let pre = t.c - msk in
+    let rst = len - pre in
+    if rst > 0 then (
+      blit t.v msk v off pre;
+      blit t.v 0 v (off + pre) rst)
+    else blit t.v msk v off len
+
+  let keep t ~blit ~length ?off ?len v =
+    try Some (keep_exn t ~blit ~length ?off ?len v) with Empty -> None
+
+  let peek t =
+    let len = (size [@inlined]) t in
+    if len == 0 then []
+    else
+      let msk = (mask [@inlined]) t t.r in
+      let pre = t.c - msk in
+      let rst = len - pre in
+      if rst > 0 then
+        [ Bigarray.Array1.sub t.v msk pre; Bigarray.Array1.sub t.v 0 rst ]
+      else [ Bigarray.Array1.sub t.v msk len ]
+
+  let unsafe_shift t len = t.r <- t.r + len
+
+  let shift_exn t len =
+    if (size [@inlined]) t < len then raise Empty;
+    unsafe_shift t len
+
+  let shift t len = try Some (shift_exn t len) with Empty -> None
+end
+
+let iter f t =
+  let idx = ref t.r in
+  let max = t.w in
+  while !idx <> max do
+    f (Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t !idx));
+    incr idx
+  done
+
+let rev_iter f t =
+  if t.r == t.w then ()
+  else
+    let idx = ref (pred t.w) in
+    let min = t.r in
+    while
+      f (Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t !idx));
+      !idx <> min
+    do
+      decr idx
+    done
+
+let fold f a t =
+  let a = ref a in
+  iter (fun x -> a := f !a x) t;
+  !a
+
+let pp ?sep pp_elt = Fmt.iter ?sep iter pp_elt
+let dump pp_elt = Fmt.Dump.iter iter (Fmt.any "rke") pp_elt
+
+let clear q =
+  q.r <- 0;
+  q.w <- 0
+
+module Weighted = struct
+  type ('a, 'b) t = {
+    mutable r : int;
+    mutable w : int;
+    c : int;
+    k : ('a, 'b) Bigarray.kind;
+    v : ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t;
+  }
+
+  exception Empty
+  exception Full
+
+  let[@inline always] mask t v = v land (t.c - 1)
+  let[@inline always] empty t = t.r = t.w
+  let[@inline always] size t = t.w - t.r
+  let[@inline always] full t = size t = t.c
+  let[@inline always] available t = t.c - (t.w - t.r)
+  let is_empty t = (empty [@inlined]) t
+  let length q = size q
+
+  let create ?capacity kind =
+    let capacity =
+      match capacity with
+      | None | Some 0 -> 1
+      | Some n ->
+          if n < 0 then Fmt.invalid_arg "Rke.Weighted.create"
+          else to_power_of_two n
+    in
+    ( {
+        r = 0;
+        w = 0;
+        c = capacity;
+        k = kind;
+        v = Bigarray.Array1.create kind Bigarray.c_layout capacity;
+      },
+      capacity )
+
+  let copy t =
+    let v = Bigarray.Array1.create t.k Bigarray.c_layout t.c in
+    Bigarray.Array1.blit t.v v;
+    { r = t.r; w = t.w; c = t.c; v; k = t.k }
+
+  let from v =
+    if not (is_power_of_two (Bigarray.Array1.dim v)) then
+      Fmt.invalid_arg "RBA.from";
+    let c = Bigarray.Array1.dim v in
+    let k = Bigarray.Array1.kind v in
+    { r = 0; w = 0; c; k; v }
+
+  let push_exn t v =
+    if (full [@inlined]) t then raise Full;
+    Bigarray.Array1.unsafe_set t.v ((mask [@inlined]) t t.w) v;
+    t.w <- t.w + 1
+
+  let push t v = try Some (push_exn t v) with Full -> None
+
+  let cons_exn t v =
+    if (full [@inlined]) t then raise Full;
+    let i = t.r - 1 in
+    Bigarray.Array1.unsafe_set t.v ((mask [@inlined]) t i) v;
+    t.r <- i
+
+  let cons t v = try Some (cons_exn t v) with Full -> None
+
+  let pop_exn t =
+    if (empty [@inlined]) t then raise Empty;
+    let r = Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t t.r) in
+    t.r <- t.r + 1;
+    r
+
+  let pop t = try Some (pop_exn t) with Empty -> None
+
+  let peek_exn t =
+    if (empty [@inlined]) t then raise Empty;
+    Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t t.r)
+
+  let peek t = try Some (peek_exn t) with Empty -> None
+
+  let compress t =
+    let len = length t in
+    let msk = (mask [@inlined]) t t.r in
+    let pre = t.c - msk in
+    let rst = len - pre in
+    if rst > 0 then (
+      if (available [@inlined]) t >= pre then (
+        (* XXX(dinosaure): in this case, [pre + rst <= msk], so [blit] will not
+           overlap bytes at the end of [t.v] (at offset [msk]). *)
+        blit t.v 0 t.v pre rst;
+        blit t.v msk t.v 0 pre)
+      else
+        let tmp = Bigarray.Array1.create t.k Bigarray.c_layout pre in
+        blit t.v msk tmp 0 pre;
+        blit t.v 0 t.v pre rst;
+        blit tmp 0 t.v 0 pre)
+    else blit t.v msk t.v 0 len;
+    t.r <- 0;
+    t.w <- len
+
+  module N = struct
+    type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t
+    type ('a, 'b) blit = 'a -> int -> 'b -> int -> int -> unit
+    type 'a length = 'a -> int
+
+    let push_exn t ~blit ~length ?(off = 0) ?len v =
+      let len = match len with None -> length v - off | Some len -> len in
+      if (available [@inlined]) t < len then raise Full;
+      let msk = (mask [@inlined]) t t.w in
+      let pre = t.c - msk in
+      let rst = len - pre in
+      let ret =
+        if rst > 0 then (
+          blit v off t.v msk pre;
+          blit v (off + pre) t.v 0 rst;
+          [
+            Bigarray.Array1.sub t.v ((mask [@inlined]) t t.w) pre;
+            Bigarray.Array1.sub t.v 0 rst;
+          ])
+        else (
+          blit v off t.v msk len;
+          [ Bigarray.Array1.sub t.v ((mask [@inlined]) t t.w) len ])
+      in
+      t.w <- t.w + len;
+      ret
+
+    let push t ~blit ~length ?off ?len v =
+      try Some (push_exn t ~blit ~length ?off ?len v) with Full -> None
+
+    let keep_exn t ~blit ~length ?(off = 0) ?len v =
+      let len = match len with None -> length v - off | Some len -> len in
+      if (size [@inlined]) t < len then raise Empty;
+      let msk = (mask [@inlined]) t t.r in
+      let pre = t.c - msk in
+      let rst = len - pre in
+      if rst > 0 then (
+        blit t.v msk v off pre;
+        blit t.v 0 v (off + pre) rst)
+      else blit t.v msk v off len
+
+    let keep t ~blit ~length ?off ?len v =
+      try Some (keep_exn t ~blit ~length ?off ?len v) with Empty -> None
+
+    let peek t =
+      let len = (size [@inlined]) t in
+      if len == 0 then []
+      else
+        let msk = (mask [@inlined]) t t.r in
+        let pre = t.c - msk in
+        let rst = len - pre in
+        if rst > 0 then
+          [ Bigarray.Array1.sub t.v msk pre; Bigarray.Array1.sub t.v 0 rst ]
+        else [ Bigarray.Array1.sub t.v msk len ]
+
+    let unsafe_shift t len = t.r <- t.r + len
+
+    let shift_exn t len =
+      if (size [@inlined]) t < len then raise Empty;
+      unsafe_shift t len
+
+    let shift t len = try Some (shift_exn t len) with Empty -> None
+  end
+
+  let iter f t =
+    let idx = ref t.r in
+    let max = t.w in
+    while !idx <> max do
+      f (Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t !idx));
+      incr idx
+    done
+
+  let rev_iter f t =
+    if t.r == t.w then ()
+    else
+      let idx = ref (pred t.w) in
+      let min = t.r in
+      while
+        f (Bigarray.Array1.unsafe_get t.v ((mask [@inlined]) t !idx));
+        !idx <> min
+      do
+        decr idx
+      done
+
+  let fold f a t =
+    let a = ref a in
+    iter (fun x -> a := f !a x) t;
+    !a
+
+  let pp ?sep pp_elt = Fmt.iter ?sep iter pp_elt
+  let dump pp_elt = Fmt.Dump.iter iter (Fmt.any "rke:weighted") pp_elt
+
+  let clear q =
+    q.r <- 0;
+    q.w <- 0
+
+  let unsafe_bigarray { v; _ } = v
+end

unikernel/duniverse/ke/lib/rke.mli

@@ -0,0 +1,2 @@
+include Sigs.R
+module Weighted : Sigs.Weighted.R

unikernel/duniverse/ke/lib/sigs.ml

@@ -0,0 +1,532 @@
+module type F = sig
+  type 'a t
+  (** The type of queues containing elements of type ['a]. *)
+
+  exception Empty
+  (** Raised when {!peek_exn} or {!pop_exn} is applied to an empty queue. *)
+
+  val empty : 'a t
+  (** An empty queue. *)
+
+  val is_empty : 'a t -> bool
+  (** Return [true] if the given queue is empty, [false] otherwise. *)
+
+  val length : 'a t -> int
+  (** Number of elements in the queue. *)
+
+  val push : 'a t -> 'a -> 'a t
+  (** Push element at the end of the queue. *)
+
+  val cons : 'a t -> 'a -> 'a t
+  (** Push element at the front of the queue. *)
+
+  val peek : 'a t -> 'a option
+  (** [peek q] returns the first element in the queue [q], without removing it
+     from the queue. If [q] is empty, it returns [None]. *)
+
+  val peek_exn : 'a t -> 'a
+  (** Same as {!peek} but it raises an exception if [q] is empty. *)
+
+  val pop : 'a t -> ('a * 'a t) option
+  (** Get and remove the first element. If [q] is empty, it returns [None]. *)
+
+  val pop_exn : 'a t -> 'a * 'a t
+  (** Same as {!pop} but it raises an exception if [q] is empty. *)
+
+  val tail : 'a t -> ('a t * 'a) option
+  (** Get and remove the {b last} element. If [q] is empty, it returns [None]. *)
+
+  val tail_exn : 'a t -> 'a t * 'a
+  (** Same as {!tail} but it raises an exception if [q] is empty. *)
+
+  val iter : ('a -> unit) -> 'a t -> unit
+  (** [iter f q] applies [f] in turn to all elements of [q], from the least
+     recently entered to the most recently entered. The queue itself is
+     unchanged. *)
+
+  val rev_iter : ('a -> unit) -> 'a t -> unit
+  (** [rev_iter f q] applies [f] in turn to all elements of [q], from the most
+     recently entered to the least recently entered. The queue itself is
+     unchanged. *)
+
+  val fold : ('acc -> 'x -> 'acc) -> 'acc -> 'x t -> 'acc
+  (** [fold f a q] is equivalent to [List.fold_left f a l], where [l] is the
+     list of [q]'s elements. The queue remains unchanged. *)
+
+  val pp : ?sep:unit Fmt.t -> 'a Fmt.t -> 'a t Fmt.t
+  (** Pretty-printer of {!t}. *)
+
+  val dump : 'a Fmt.t -> 'a t Fmt.t
+  (** Human-readable pretty-printer of {!t}. *)
+end
+
+module type R = sig
+  type ('a, 'b) t
+  (** The type of queues containing elements of type ['a]. *)
+
+  exception Empty
+  (** Raised when {!peek_exn}, {!pop_exn}, {!N.keep_exn} or {!N.shift_exn} is
+     applied to an empty queue. *)
+
+  val is_empty : ('a, 'b) t -> bool
+  (** Return [true] if the given queue is empty, [false] otherwise. *)
+
+  val create : ?capacity:int -> ('a, 'b) Bigarray.kind -> ('a, 'b) t
+  (** Return a new queue, initially empty. *)
+
+  val capacity : ('a, 'b) t -> int
+  (** Returns how many objects [t] can store. *)
+
+  val length : ('a, 'b) t -> int
+  (** Number of elements in the queue. *)
+
+  val push : ('a, 'b) t -> 'a -> unit
+  (** [push q x] adds the elements [x] at the end of the queue [q]. *)
+
+  val pop : ('a, 'b) t -> 'a option
+  (** [pop q] removes and returns the first element in queue [q]. If [q] is
+     empty, it returns [None]. *)
+
+  val pop_exn : ('a, 'b) t -> 'a
+  (** [pop_exn] is the same as {!pop} but it raises {!Empty} when the given
+     queue [q] is empty. *)
+
+  val peek : ('a, 'b) t -> 'a option
+  (** [peek q] returns the first element in the queue [q], without removing it
+     from the queue. If [q] is empty, it returns [None]. *)
+
+  val peek_exn : ('a, 'b) t -> 'a
+  (** Same as {!peek} but it raises {!Empty} if [q] is empty. *)
+
+  val cons : ('a, 'b) t -> 'a -> unit
+  (** [cons q x] adds element [x] at the front of the given queue [q]. It
+     returns [None] if it fails. *)
+
+  val copy : ('a, 'b) t -> ('a, 'b) t
+  (** Return a copy of the given queue. *)
+
+  val clear : ('a, 'b) t -> unit
+  (** Discard all elements from a queue. *)
+
+  val compress : ('a, 'b) t -> unit
+  (** Compress queue, read cursor will be setted to [0] and data will be move
+     to. This operation allows to provide much more space for a
+     {!push}/{!N.push} operation - but it can not ensure enough free space. *)
+
+  module N : sig
+    type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t
+    (** The type of the internal bigarray of {!t}. *)
+
+    type ('a, 'b) blit = 'a -> int -> 'b -> int -> int -> unit
+    (** The type of the [blit] function. *)
+
+    type 'a length = 'a -> int
+    (** The type of the [length] function. *)
+
+    val push :
+      ('a, 'b) t ->
+      blit:('src, ('a, 'b) bigarray) blit ->
+      length:'src length ->
+      ?off:int ->
+      ?len:int ->
+      'src ->
+      unit
+    (** [push q ~blit ~length ?off ?len src] {i blits} elements in [src] to the
+       given queue [q] at the end (like a fast iterative {!R.push}). Default
+       value of [off] is [0]. Default value of [len] is [length src - off]. *)
+
+    val keep_exn :
+      ('a, 'b) t ->
+      blit:(('a, 'b) bigarray, 'dst) blit ->
+      length:'dst length ->
+      ?off:int ->
+      ?len:int ->
+      'dst ->
+      unit
+    (** [keep_exn q ~blit ~length ?off ?len dst] {i blits} elements of the given
+       queue [q] in [dst] from the front to the end of [dst] (like a fast
+       iterative {!R.pop_exn}). Default value of [off] is [0]. Default value of
+       [len] is [length dst - off]. If the given [q] does not have enough
+       elements to write on [dst], it raises {!Empty} and the given queue is
+       unchanged. *)
+
+    val keep :
+      ('a, 'b) t ->
+      blit:(('a, 'b) bigarray, 'dst) blit ->
+      length:'dst length ->
+      ?off:int ->
+      ?len:int ->
+      'dst ->
+      unit option
+    (** Same as {!keep_exn} but if it fails, it returns [None]. *)
+
+    val peek : ('a, 'b) t -> ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t list
+    (** Returns a sub-part of available to read payloads. *)
+
+    val unsafe_shift : ('a, 'b) t -> int -> unit
+    (** [unsafe_shift q l] discards [l] elements in the given queue [q] without
+       any verification. Mostly used after {!keep_exn}, if the last one does not
+       raise {!Empty}, it's safe to use it. *)
+
+    val shift_exn : ('a, 'b) t -> int -> unit
+    (** [shift_exn q l] discards [l] elements in the given queue [q]. If [q]
+       does not have enough elements, it raises {!Empty} and the given queue is
+       unchanged. *)
+
+    val shift : ('a, 'b) t -> int -> unit option
+    (** Same as {!shift_exn} but if it fails, it returns [None]. *)
+  end
+
+  val iter : ('a -> unit) -> ('a, 'b) t -> unit
+  (** [iter f q] applies [f] in turn to all elements of [q], from the least
+     recently entered to the most recently entered. The queue itself is
+     unchanged. *)
+
+  val rev_iter : ('a -> unit) -> ('a, 'b) t -> unit
+  (** [iter f q] applies [f] in turn to all elements of [q], from the most
+     recently entered to the least recently entered. The queue itself is
+     unchanged. *)
+
+  val fold : ('acc -> 'x -> 'acc) -> 'acc -> ('x, 'b) t -> 'acc
+  (** [fold f a q] is equivalent to [List.fold_left f a l], where [l] is the
+     list of [q]'s elements. The queue remains unchanged. *)
+
+  val pp : ?sep:unit Fmt.t -> 'a Fmt.t -> ('a, 'b) t Fmt.t
+  (** Pretty-printer of {!t}. *)
+
+  val dump : 'a Fmt.t -> ('a, 'b) t Fmt.t
+  (** Human-readable pretty-printer of {!t}. *)
+end
+
+module Weighted = struct
+  module type R = sig
+    type ('a, 'b) t
+    (** The type of queues containing elements of type ['a]. *)
+
+    exception Full
+    (** Raised when {!push_exn} or {!N.push_exn} is applied to an empty queue. *)
+
+    exception Empty
+    (** Raised when {!peek_exn}, {!pop_exn} is applied to an empty queue. *)
+
+    val is_empty : ('a, 'b) t -> bool
+    (** Return [true] if the given queue is empty, [false] otherwise. *)
+
+    val create : ?capacity:int -> ('a, 'b) Bigarray.kind -> ('a, 'b) t * int
+    (** Return a new queue, initially empty with the real capacity of it. *)
+
+    val length : ('a, 'b) t -> int
+    (** Number of elements in the queue. *)
+
+    val available : ('a, 'b) t -> int
+    (** Free cells availables on the queue. *)
+
+    val push_exn : ('a, 'b) t -> 'a -> unit
+    (** [push_exn q x] adds the elements [x] at the end of the queue [q]. It
+       raises {!Full} if the given queue [q] is full. *)
+
+    val push : ('a, 'b) t -> 'a -> unit option
+    (** [push q x] is the same as {!push_exn} but returns [None] if it fails. *)
+
+    val pop : ('a, 'b) t -> 'a option
+    (** [pop q] removes and returns the first element in the given queue [q]. If
+       [q] is empty, it returns [None]. *)
+
+    val pop_exn : ('a, 'b) t -> 'a
+    (** [pop_exn q] is the same as {!pop} but it raises an {!Empty} if the given
+       queue is empty. *)
+
+    val peek : ('a, 'b) t -> 'a option
+    (** [peek q] returns the first element in the given queue [q]. If [q] is
+       empty, it returns [None]. *)
+
+    val peek_exn : ('a, 'b) t -> 'a
+    (** [peek_exn q] returns the first element in the given queue [q]. If [q] is
+       empty, it raises {!Empty}. *)
+
+    val cons_exn : ('a, 'b) t -> 'a -> unit
+    (** [cons_exn q x] adds element [x] at the front of the given queue [q]. It
+       raises {!Full} if the queue is full. *)
+
+    val cons : ('a, 'b) t -> 'a -> unit option
+    (** [cons q x] adds element [x] at the front of the given queue [q]. It
+       returns [None] if it fails. *)
+
+    val copy : ('a, 'b) t -> ('a, 'b) t
+    (** Return a copy of the given queue. *)
+
+    val clear : ('a, 'b) t -> unit
+    (** Discard all elements from a queue. *)
+
+    val compress : ('a, 'b) t -> unit
+    (** Compress queue, read cursor will be setted to [0] and data will be move
+       to. This operation allows to provide much more space for a
+       {!push}/{!N.push} operation - but it can not ensure enough free space. *)
+
+    module N : sig
+      type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t
+      (** The type of the internal bigarray of {!t}. *)
+
+      type ('a, 'b) blit = 'a -> int -> 'b -> int -> int -> unit
+      (** The type of the [blit] function. *)
+
+      type 'a length = 'a -> int
+      (** The type of the [length] function. *)
+
+      val push_exn :
+        ('a, 'b) t ->
+        blit:('src, ('a, 'b) bigarray) blit ->
+        length:'src length ->
+        ?off:int ->
+        ?len:int ->
+        'src ->
+        ('a, 'b) bigarray list
+      (** [push_exn q ~blit ~length ?off ?len src] {i blits} elements in [src]
+         to the given queue [q] at the end (like a fast iterative {!R.push}).
+         Default value of [off] is [0]. Default value of [len] is [length src - off].
+         It returns a list of internal {!bigarray}s which contain [dst].
+         If the given [q] does not have enough free space to write [src], it
+         raises {!Full} and the given queue is unchanged. *)
+
+      val push :
+        ('a, 'b) t ->
+        blit:('src, ('a, 'b) bigarray) blit ->
+        length:'src length ->
+        ?off:int ->
+        ?len:int ->
+        'src ->
+        ('a, 'b) bigarray list option
+      (** Same as {!push_exn} but it returns [None] if it fails. *)
+
+      val keep_exn :
+        ('a, 'b) t ->
+        blit:(('a, 'b) bigarray, 'dst) blit ->
+        length:'dst length ->
+        ?off:int ->
+        ?len:int ->
+        'dst ->
+        unit
+      (** [keep_exn q ~blit ~length ?off ?len dst] {i blits} elements of the
+         given queue [q] in [dst] from the front to the end of [dst] (like a
+         fast iterative {!R.pop_exn}). Default value of [off] is [0]. Default
+         value of [len] is [length dst - off]. If the given [q] does not have
+         enough elements to write on [dst], it raises {!Empty}. In any case, the
+         given queue is unchanged. *)
+
+      val keep :
+        ('a, 'b) t ->
+        blit:(('a, 'b) bigarray, 'dst) blit ->
+        length:'dst length ->
+        ?off:int ->
+        ?len:int ->
+        'dst ->
+        unit option
+      (** Same as {!keep_exn} but if it fails, it returns [None]. *)
+
+      val peek :
+        ('a, 'b) t -> ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t list
+      (** Returns a sub-part of available to read payloads. *)
+
+      val unsafe_shift : ('a, 'b) t -> int -> unit
+      (** [unsafe_shift q l] discards [l] elements in the given queue [q]
+         without any verification. Mostly used after {!keep_exn}, if the last
+         one does not raise {!Empty}, it's safe to use it. *)
+
+      val shift_exn : ('a, 'b) t -> int -> unit
+      (** [shift_exn q l] discards [l] elements in the given queue [q]. If [q]
+         does not have enough elements, it raises {!Empty} and the given queue
+         is unchanged. *)
+
+      val shift : ('a, 'b) t -> int -> unit option
+      (** Same as {!shift_exn} but if it fails, it returns [None]. *)
+    end
+
+    val iter : ('a -> unit) -> ('a, 'b) t -> unit
+    (** [iter f q] applies [f] in turn to all elements of [q], from the least
+       recently entered to the most recently entered. The queue itself is
+       unchanged. *)
+
+    val rev_iter : ('a -> unit) -> ('a, 'b) t -> unit
+    (** [iter f q] applies [f] in turn to all elements of [q], from the most
+       recently entered to the least recently entered. The queue itself is
+       unchanged. *)
+
+    val fold : ('acc -> 'x -> 'acc) -> 'acc -> ('x, 'b) t -> 'acc
+    (** [fold f a q] is equivalent to [List.fold_left f a l], where [l] is the
+       list of [q]'s elements. The queue remains unchanged. *)
+
+    val pp : ?sep:unit Fmt.t -> 'a Fmt.t -> ('a, 'b) t Fmt.t
+    (** Pretty-printer of {!t}. *)
+
+    val dump : 'a Fmt.t -> ('a, 'b) t Fmt.t
+    (** Human-readable pretty-printer of {!t}. *)
+
+    val unsafe_bigarray :
+      ('a, 'b) t -> ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t
+    (** / **)
+
+    val from : ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t -> ('a, 'b) t
+  end
+
+  module type F = sig
+    type ('a, 'b) t
+    (** The type of queues containing elements of type ['a]. *)
+
+    exception Empty
+    (** Raised when {!push_exn} or {!N.push_exn} is applied to an empty queue. *)
+
+    exception Full
+    (** Raised when {!peek_exn}, {!pop_exn} is applied to an empty queue. *)
+
+    val is_empty : ('a, 'b) t -> bool
+    (** Return [true] if the given queue is empty, [false] otherwise. *)
+
+    val create : ?capacity:int -> ('a, 'b) Bigarray.kind -> ('a, 'b) t * int
+    (** Return a new queue, initially empty with the real capacity of it. *)
+
+    val length : ('a, 'b) t -> int
+    (** Number of elements in the queue. *)
+
+    val available : ('a, 'b) t -> int
+    (** Free cells availables on the queue. *)
+
+    val push_exn : ('a, 'b) t -> 'a -> ('a, 'b) t
+    (** [push_exn q x] adds the elements [x] at the end of the queue [q] and
+       returns the new queue [q']. It raises {!Full} if the given queue [q] is
+       full. *)
+
+    val push : ('a, 'b) t -> 'a -> ('a, 'b) t option
+    (** [push q x] is the same as {!push_exn} but returns [None] if it fails. *)
+
+    val pop : ('a, 'b) t -> ('a * ('a, 'b) t) option
+    (** [pop q] removes and returns the first element in the given queue [q] and
+       returns the new queue [q']. If [q] is empty, it returns [None]. *)
+
+    val pop_exn : ('a, 'b) t -> 'a * ('a, 'b) t
+    (** [pop_exn q] is the same as {!pop} but it raises an {!Empty} if the given
+       queue is empty. *)
+
+    val peek : ('a, 'b) t -> 'a option
+    (** [peek q] returns the first element in the given queue [q]. If [q] is
+       empty, it returns [None]. The given queue [q] is unchanged. *)
+
+    val peek_exn : ('a, 'b) t -> 'a
+    (** [peek_exn q] returns the first element in the given queue [q]. If [q] is
+       empty, it raises {!Empty}. *)
+
+    val cons : ('a, 'b) t -> 'a -> ('a, 'b) t option
+    (** [cons q x] adds element [x] at the front of the given queue [q]. It
+       returns [None] if it fails or the new queue [q']. *)
+
+    val cons_exn : ('a, 'b) t -> 'a -> ('a, 'b) t
+    (** [cons q x] adds element [x] at the front of the given queue [q]. It
+       raises {!Empty} if the given queue [q] is full or the new queue [q']. *)
+
+    val copy : ('a, 'b) t -> ('a, 'b) t
+    (** Return a copy of the given queue. *)
+
+    val clear : ('a, 'b) t -> ('a, 'b) t
+    (** Discard all elements from a queue. *)
+
+    module N : sig
+      type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t
+      (** The type of the internal bigarray of {!t}. *)
+
+      type ('a, 'b) blit = 'a -> int -> 'b -> int -> int -> unit
+      (** The type of the [blit] function. *)
+
+      type 'a length = 'a -> int
+      (** The type of the [length] function. *)
+
+      val push_exn :
+        ('a, 'b) t ->
+        blit:('src, ('a, 'b) bigarray) blit ->
+        length:'src length ->
+        ?off:int ->
+        ?len:int ->
+        'src ->
+        ('a, 'b) bigarray list * ('a, 'b) t
+      (** [push_exn q ~blit ~length ?off ?len src] {i blits} elements in [src]
+         to the given queue [q] at the end (like a fast iterative {!R.push}).
+         Default value of [off] is [0]. Default value of [len] is [length src - off].
+         It returns a list of internal {!bigarray}s which contain [dst].
+         If the given [q] does not have enough free space to write [src], it
+         raises {!Full} and the given queue is unchanged. *)
+
+      val push :
+        ('a, 'b) t ->
+        blit:('src, ('a, 'b) bigarray) blit ->
+        length:'src length ->
+        ?off:int ->
+        ?len:int ->
+        'src ->
+        (('a, 'b) bigarray list * ('a, 'b) t) option
+      (** Same as {!push_exn} but it returns [None] if it fails. *)
+
+      val keep_exn :
+        ('a, 'b) t ->
+        blit:(('a, 'b) bigarray, 'dst) blit ->
+        length:'dst length ->
+        ?off:int ->
+        ?len:int ->
+        'dst ->
+        unit
+      (** [keep_exn q ~blit ~length ?off ?len dst] {i blits} elements of the
+         given queue [q] in [dst] from the front to the end of [dst] (like a
+         fast iterative {!R.pop_exn}). Default value of [off] is [0]. Default
+         value of [len] is [length dst - off]. If the given [q] does not have
+         enough elements to write on [dst], it raises {!Empty}. In any case, the
+         given queue is unchanged. *)
+
+      val keep :
+        ('a, 'b) t ->
+        blit:(('a, 'b) bigarray, 'dst) blit ->
+        length:'dst length ->
+        ?off:int ->
+        ?len:int ->
+        'dst ->
+        unit option
+      (** Same as {!keep_exn} but if it fails, it returns [None]. *)
+
+      val unsafe_shift : ('a, 'b) t -> int -> ('a, 'b) t
+      (** [unsafe_shift q l] discards [l] elements in the given queue [q]
+         without any verification. Mostly used after {!keep_exn}, if the last
+         one does not raise {!Empty}, it's safe to use it. *)
+
+      val shift_exn : ('a, 'b) t -> int -> ('a, 'b) t
+      (** [shift_exn q l] discards [l] elements in the given queue [q]. If [q]
+         does not have enough elements, it raises {!Empty} and the given queue
+         is unchanged. *)
+
+      val shift : ('a, 'b) t -> int -> ('a, 'b) t option
+      (** Same as {!shift_exn} but if it fails, it returns [None]. *)
+    end
+
+    val iter : ('a -> unit) -> ('a, 'b) t -> unit
+    (** [iter f q] applies [f] in turn to all elements of [q], from the least
+       recently entered to the most recently entered. The queue itself is
+       unchanged. *)
+
+    val rev_iter : ('a -> unit) -> ('a, 'b) t -> unit
+    (** [iter f q] applies [f] in turn to all elements of [q], from the most
+       recently entered to the least recently entered. The queue itself is
+       unchanged. *)
+
+    val fold : ('acc -> 'x -> 'acc) -> 'acc -> ('x, 'b) t -> 'acc
+    (** [fold f a q] is equivalent to [List.fold_left f a l], where [l] is the
+       list of [q]'s elements. The queue remains unchanged. *)
+
+    val pp : ?sep:unit Fmt.t -> 'a Fmt.t -> ('a, 'b) t Fmt.t
+    (** Pretty-printer of {!t}. *)
+
+    val dump : 'a Fmt.t -> ('a, 'b) t Fmt.t
+    (** Human-readable pretty-printer of {!t}. *)
+
+    (** / **)
+
+    val unsafe_bigarray :
+      ('a, 'b) t -> ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t
+
+    val from : ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t -> ('a, 'b) t
+  end
+end

unikernel/duniverse/ke/test/dune

@@ -0,0 +1,10 @@
+(executable
+ (name test)
+ (libraries bigstringaf alcotest ke))
+
+(rule
+ (alias runtest)
+ (deps
+  (:exe test.exe))
+ (action
+  (run %{exe} --color=always)))

unikernel/duniverse/ke/test/test.ml

@@ -0,0 +1,331 @@
+let () = Printexc.record_backtrace true
+
+module Option = struct
+  let map f = function Some x -> Some (f x) | None -> None
+end
+
+module type Q = sig
+  type t
+
+  exception Empty
+
+  val available : t -> int
+  val fold : ('a -> int -> 'a) -> 'a -> t -> 'a
+  val create : unit -> t
+  val push : t -> int -> unit
+  val pop_exn : t -> int
+  val peek_exn : t -> int
+  val is_empty : t -> bool
+  val length : t -> int
+  val iter : (int -> unit) -> t -> unit
+  val copy : t -> t
+  val clear : t -> unit
+  val compress : t -> unit
+end
+
+(* XXX(dinosaure): from [ocaml]. *)
+module Make (Q : Q) = struct
+  let to_list q = Q.fold (fun a x -> x :: a) [] q |> List.rev
+
+  let test_0 =
+    Alcotest.test_case "test-0" `Quick @@ fun () ->
+    let q = Q.create () in
+    Alcotest.(check (list int)) "[            ]" (to_list q) [];
+    Q.push q 1;
+    Alcotest.(check (list int)) "[ 1          ]" (to_list q) [ 1 ];
+    Q.push q 2;
+    Alcotest.(check (list int)) "[ 1; 2       ]" (to_list q) [ 1; 2 ];
+    Q.push q 3;
+    Alcotest.(check (list int)) "[ 1; 2; 3    ]" (to_list q) [ 1; 2; 3 ];
+    Q.push q 4;
+    Alcotest.(check (list int)) "[ 1; 2; 3; 4 ]" (to_list q) [ 1; 2; 3; 4 ];
+    let n = Q.pop_exn q in
+    Alcotest.(check (list int)) "[    2; 3; 4 ]" (to_list q) [ 2; 3; 4 ];
+    Alcotest.(check int) "1" n 1;
+    let n = Q.pop_exn q in
+    Alcotest.(check (list int)) "[       3; 4 ]" (to_list q) [ 3; 4 ];
+    Alcotest.(check int) "2" n 2;
+    let n = Q.pop_exn q in
+    Alcotest.(check (list int)) "[          4 ]" (to_list q) [ 4 ];
+    Alcotest.(check int) "3" n 3;
+    let n = Q.pop_exn q in
+    Alcotest.(check (list int)) "[            ]" (to_list q) [];
+    Alcotest.(check int) "4" n 4;
+    Alcotest.check_raises "exception" Q.Empty (fun () -> ignore (Q.pop_exn q))
+
+  let test_1 =
+    Alcotest.test_case "test-1" `Quick @@ fun () ->
+    let q = Q.create () in
+    Alcotest.(check (list int)) "empty" (to_list q) [];
+    Q.push q 1;
+    let n = Q.pop_exn q in
+    Alcotest.(check int) "1" n 1;
+    Alcotest.check_raises "exception" Q.Empty (fun () -> ignore (Q.pop_exn q));
+    Q.push q 2;
+    let n = Q.pop_exn q in
+    Alcotest.(check int) "2" n 2;
+    Alcotest.check_raises "exception" Q.Empty (fun () -> ignore (Q.pop_exn q));
+    Alcotest.(check bool) "empty" (Q.is_empty q) true
+
+  let test_2 =
+    Alcotest.test_case "test-2" `Quick @@ fun () ->
+    let q = Q.create () in
+    Q.push q 1;
+    Alcotest.(check int) "[ 1 ]" (Q.peek_exn q) 1;
+    Q.push q 2;
+    Alcotest.(check int) "[ 1; 2 ]" (Q.peek_exn q) 1;
+    Q.push q 3;
+    Alcotest.(check int) "[ 1; 2; 3 ]" (Q.peek_exn q) 1;
+    Alcotest.(check int) "peek" (Q.peek_exn q) 1;
+    Alcotest.(check int) "pop" (Q.pop_exn q) 1;
+    Alcotest.(check int) "peek" (Q.peek_exn q) 2;
+    Alcotest.(check int) "pop" (Q.pop_exn q) 2;
+    Alcotest.(check int) "peek" (Q.peek_exn q) 3;
+    Alcotest.(check int) "pop" (Q.pop_exn q) 3;
+    Alcotest.check_raises "exception" Q.Empty (fun () -> ignore (Q.pop_exn q));
+    Alcotest.check_raises "exception" Q.Empty (fun () -> ignore (Q.pop_exn q));
+    Alcotest.(check bool) "empty" (Q.is_empty q) true
+
+  let test_3 =
+    Alcotest.test_case "test-3" `Quick @@ fun () ->
+    let q = Q.create () in
+    for i = 1 to 10 do
+      Q.push q i
+    done;
+    Q.clear q;
+    Alcotest.(check int) "length" (Q.length q) 0;
+    Alcotest.check_raises "exception" Q.Empty (fun () -> ignore (Q.pop_exn q));
+    Q.push q 42;
+    Alcotest.(check int) "[ 42 ]" (Q.pop_exn q) 42
+
+  let test_4 =
+    Alcotest.test_case "test-4" `Quick @@ fun () ->
+    let q1 = Q.create () in
+    for i = 1 to 10 do
+      Q.push q1 i
+    done;
+    let q2 = Q.copy q1 in
+    Alcotest.(check (list int))
+      "[ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ]" (to_list q1)
+      [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ];
+    Alcotest.(check (list int))
+      "[ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ]" (to_list q2)
+      [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ];
+    Alcotest.(check int) "length" (Q.length q1) 10;
+    Alcotest.(check int) "length" (Q.length q2) 10;
+    for i = 1 to 10 do
+      Alcotest.(check int) (string_of_int i) (Q.pop_exn q1) i
+    done;
+    for i = 1 to 10 do
+      Alcotest.(check int) (string_of_int i) (Q.pop_exn q2) i
+    done
+
+  let test_5 =
+    Alcotest.test_case "test-5" `Quick @@ fun () ->
+    let q = Q.create () in
+    Alcotest.(check bool) "is_empty" (Q.is_empty q) true;
+    for i = 1 to 10 do
+      Q.push q i;
+      Alcotest.(check int) "length" (Q.length q) i;
+      Alcotest.(check bool) "is_not_empty" (not (Q.is_empty q)) true
+    done;
+    for i = 10 downto 1 do
+      Alcotest.(check int) "length" (Q.length q) i;
+      Alcotest.(check bool) "is_not_empty" (not (Q.is_empty q)) true;
+      ignore (Q.pop_exn q)
+    done;
+    Alcotest.(check int) "length" (Q.length q) 0;
+    Alcotest.(check bool) "is_empty" (Q.is_empty q) true
+
+  let test_6 =
+    Alcotest.test_case "test-6" `Quick @@ fun () ->
+    let q = Q.create () in
+    for i = 1 to 10 do
+      Q.push q i
+    done;
+    let i = ref 1 in
+    Q.iter
+      (fun j ->
+        Alcotest.(check int) "iter" !i j;
+        incr i)
+      q
+
+  let test_7 =
+    Alcotest.test_case "test-7" `Quick @@ fun () ->
+    let q = Q.create () in
+    for i = 1 to 10 do
+      Q.push q i
+    done;
+    for _ = 1 to 10 do
+      ignore (Q.pop_exn q)
+    done;
+    for i = 1 to 10 do
+      Q.push q i
+    done;
+    let expect = [ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ] in
+    Alcotest.(check (list int))
+      "[ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ]" (to_list q) expect;
+    Q.compress q;
+    Alcotest.(check (list int))
+      "[ 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 ]" (to_list q) expect
+
+  let test_8 =
+    Alcotest.test_case "test-8" `Quick @@ fun () ->
+    let q = Q.create () in
+    let m = Q.available q in
+    for i = 1 to m / 2 do
+      Q.push q i
+    done;
+    for _ = 1 to m / 2 do
+      ignore (Q.pop_exn q)
+    done;
+    for i = 1 to m do
+      Q.push q i
+    done;
+    let expect = to_list q in
+    for _ = 1 to m do
+      ignore (Q.pop_exn q)
+    done;
+    for i = 1 to m do
+      Q.push q i
+    done;
+    Alcotest.(check (list int)) "filled" (to_list q) expect;
+    Q.compress q;
+    Alcotest.(check (list int)) "filled" (to_list q) expect
+end
+
+module Test_rke = Make (struct
+  type t = (int, Bigarray.int_elt) Ke.Rke.t
+
+  module W : sig
+    exception Empty
+  end = struct
+    include Ke.Rke
+  end
+
+  include W
+
+  let available = Ke.Rke.capacity
+  let fold = Ke.Rke.fold
+  let create () = Ke.Rke.create ~capacity:0x100 Bigarray.Int
+  let push = Ke.Rke.push
+  let pop_exn = Ke.Rke.pop_exn
+  let peek_exn = Ke.Rke.peek_exn
+  let is_empty = Ke.Rke.is_empty
+  let length = Ke.Rke.length
+  let iter = Ke.Rke.iter
+  let copy = Ke.Rke.copy
+  let clear = Ke.Rke.clear
+  let compress = Ke.Rke.compress
+end)
+
+module Test_weighted_rke = Make (struct
+  type t = (int, Bigarray.int_elt) Ke.Rke.Weighted.t
+
+  module W : sig
+    exception Empty
+  end = struct
+    include Ke.Rke.Weighted
+  end
+
+  include W
+
+  let available = Ke.Rke.Weighted.available
+  let fold = Ke.Rke.Weighted.fold
+
+  let create () =
+    let q, _ = Ke.Rke.Weighted.create ~capacity:0x100 Bigarray.Int in
+    q
+
+  let push = Ke.Rke.Weighted.push_exn
+  let pop_exn = Ke.Rke.Weighted.pop_exn
+  let peek_exn = Ke.Rke.Weighted.peek_exn
+  let is_empty = Ke.Rke.Weighted.is_empty
+  let length = Ke.Rke.Weighted.length
+  let iter = Ke.Rke.Weighted.iter
+  let copy = Ke.Rke.Weighted.copy
+  let clear = Ke.Rke.Weighted.clear
+  let compress = Ke.Rke.Weighted.compress
+end)
+
+module Test_blit = struct
+  module Q = Ke.Rke.Weighted
+
+  let blit_to_bytes src src_off dst dst_off len =
+    Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len
+
+  let blit_of_string src src_off dst dst_off len =
+    Bigstringaf.blit_from_string src ~src_off dst ~dst_off ~len
+
+  let blit_of_bytes src src_off dst dst_off len =
+    Bigstringaf.blit_from_bytes src ~src_off dst ~dst_off ~len
+
+  let test_0 =
+    Alcotest.test_case "peek/keep" `Quick @@ fun () ->
+    let q, _ = Q.create ~capacity:0x100 Bigarray.Char in
+    let _ =
+      Q.N.push_exn q ~blit:blit_of_string ~length:String.length "deadbeef"
+    in
+    let res = Q.N.peek q in
+    Alcotest.(check (list string))
+      "peek:deadbeef" [ "deadbeef" ]
+      (List.map Bigstringaf.to_string res);
+    let tmp = Bytes.create (String.length "deadbeef") in
+    let _ = Q.N.keep_exn q ~blit:blit_to_bytes ~length:Bytes.length tmp in
+    Alcotest.(check string)
+      "keep:deadbeef" "deadbeef"
+      (Bytes.unsafe_to_string tmp)
+
+  let test_1 =
+    Alcotest.test_case "shift" `Quick @@ fun () ->
+    let q, _ = Q.create ~capacity:0x100 Bigarray.Char in
+    let _ =
+      Q.N.push_exn q ~blit:blit_of_string ~length:String.length "deadbeef"
+    in
+    Q.N.shift_exn q (String.length "deadbeef");
+    let res = Q.N.peek q in
+    Alcotest.(check (list string))
+      "peek:empty" []
+      (List.map Bigstringaf.to_string res)
+
+  let test_2 =
+    Alcotest.test_case "push" `Quick @@ fun () ->
+    let q, capacity = Q.create ~capacity:0x10 Bigarray.Char in
+    match
+      Q.N.push q ~blit:blit_of_string ~length:String.length
+        (String.make capacity '\000')
+    with
+    | Some res ->
+        Alcotest.(check (list string))
+          "push:0x00"
+          [ String.make capacity '\000' ]
+          (List.map Bigstringaf.to_string res);
+        let res =
+          Q.N.push q ~blit:blit_of_string ~length:String.length "\x42"
+        in
+        Alcotest.(check (option (list string)))
+          "push:0x42" None
+          (Option.map (List.map Bigstringaf.to_string) res)
+    | None ->
+        Alcotest.failf "Impossible to push %S" (String.make capacity '\000')
+end
+
+let () =
+  Alcotest.run "ke"
+    [
+      ( "rke",
+        [
+          Test_rke.test_0; Test_rke.test_1; Test_rke.test_2; Test_rke.test_3;
+          Test_rke.test_4; Test_rke.test_5; Test_rke.test_6; Test_rke.test_7;
+          Test_rke.test_8;
+        ] );
+      ( "rke:weighted",
+        [
+          Test_weighted_rke.test_0; Test_weighted_rke.test_1;
+          Test_weighted_rke.test_2; Test_weighted_rke.test_3;
+          Test_weighted_rke.test_4; Test_weighted_rke.test_5;
+          Test_weighted_rke.test_6; Test_weighted_rke.test_7;
+          Test_weighted_rke.test_8; Test_blit.test_0; Test_blit.test_1;
+          Test_blit.test_2;
+        ] );
+    ]