unikernel/duniverse/lru/.gitignore

@@ -0,0 +1,9 @@
+_build
+
+tmp
+*~
+\.\#*
+\#*#
+
+gmon.out
+rondom

unikernel/duniverse/lru/.ocamlinit

@@ -0,0 +1,31 @@
+#require "psq"
+#directory "_build/src"
+#load "lru.cma"
+#require "fmt"
+
+module I = struct
+  type t = int
+  let compare (a: int) b = compare a b
+  let hash = Hashtbl.hash
+  let equal = (=)
+  let weight a = a
+end
+
+module F = Lru.F.Make (I) (I)
+module M = Lru.M.Make (I) (I)
+
+let r _ = Random.int 100
+
+let init f n =
+  let rec go i =
+    if i = n then [] else let x = f i in x :: go (i + 1) in
+  go 0
+
+let ppf = F.pp_dump Fmt.int Fmt.int
+let ppm = M.pp_dump Fmt.int Fmt.int
+
+;;
+
+#install_printer ppf;;
+#install_printer ppm;;
+

unikernel/duniverse/lru/CHANGES.md

@@ -0,0 +1,55 @@
+## v0.3.1 2022-10-25
+
+- Ocaml 5.0 compatible. Thanks to @samoht for the report.
+- tweak ordering implementation in `F.of_list`
+
+## v0.3.0 2019-04-09
+
+Semantics cleanup.
+
+Breaking:
+
+- `find` drops `?promote` and never changes the ordering.
+- `add` drops `?trim` and never drops bindings.
+- `size` -> `weight`
+- `items` -> `size`
+- `unadd` -> `pop`
+- `F.S.fold` and `F.S.iter` iterate in LRU order.
+- `F.M.fold` and `F.M.iter` drop `?dir` and always iterate in LRU order.
+
+Other:
+
+- add `F.S.fold_k` and `F.S.iter_k`
+
+To fix client code:
+
+- replace `find ~promote:false` with `find`;
+- replace `find` and `find ~promote:true` with `find` and `promote`;
+- replace `add ~trim:false` with `add`;
+- replace `add` and `add ~trim:true` with `add` and `trim`;
+- `s/size/weight/g`, `s/items/size/g`, `s/unadd/pop/g`;
+- audit uses of `fold` and `iter` for order-sensitivity.
+
+## v0.2.0 2017-03-31
+
+Breaking changes:
+
+- `resize` no longer drops bindings if the new size pushes the queue over capacity.
+- `of_list` has simpler semantics; dropped the `cap` parameter.
+
+Other changes:
+
+- Replace `Lru.M.cache` with more general `Lru.memo`.
+- Queues with 0 initial capacity are legal.
+- Add `trim` to shrink a queue to its capacity, as queues are no longer guaranteed to
+  have size smaller than capacity.
+- `find` gets the `promote` parameter, allowing queries that do not change the order.
+- `add` gets the `trim` parameter, allowing insertions that do not drop old entries.
+
+## v0.1.1 2016-11-28
+
+* Fix missing dep on `psq` in META.
+
+## v0.1.0 2016-11-22
+
+First release.

unikernel/duniverse/lru/LICENSE.md

@@ -0,0 +1,13 @@
+Copyright (c) 2016 David Kaloper Meršinjak
+
+Permission to use, copy, modify, and/or distribute this software for any
+purpose with or without fee is hereby granted, provided that the above
+copyright notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

unikernel/duniverse/lru/README.md

@@ -0,0 +1,18 @@
+# lru — Scalable LRU caches
+
+v0.3.0-4-gcf049b9
+
+Lru provides weight-bounded finite maps that can remove the least-recently-used
+(LRU) bindings in order to maintain a weight constraint.
+
+Two implementations are provided: one is functional, the other imperative.
+
+lru is distributed under the ISC license.
+
+Homepage: https://github.com/pqwy/lru
+
+## Documentation
+
+Interface, [online][doc].
+
+[doc]: https://pqwy.github.io/lru/doc/lru/

unikernel/duniverse/lru/dune-project

@@ -0,0 +1,3 @@
+(lang dune 1.7)
+(name lru)
+(version v0.3.0-4-gcf049b9)

unikernel/duniverse/lru/lru.opam

@@ -0,0 +1,25 @@
+version: "0.3.1"
+opam-version: "2.0"
+maintainer: "David Kaloper Meršinjak <dk505@cam.ac.uk>"
+authors: ["David Kaloper Meršinjak <dk505@cam.ac.uk>"]
+homepage: "https://github.com/pqwy/lru"
+doc: "https://pqwy.github.io/lru/doc"
+license: "ISC"
+dev-repo: "git+https://github.com/pqwy/lru.git"
+bug-reports: "https://github.com/pqwy/lru/issues"
+synopsis: "Scalable LRU caches"
+build: [ [ "dune" "subst" ] {pinned}
+         [ "dune" "build" "-p" name "-j" jobs ]
+         [ "dune" "runtest" "-p" name ] {with-test & ocaml:version >= "4.07.0"} ]
+depends: [
+  "ocaml" {>="4.03.0"}
+  "dune"  {build & >= "1.7"}
+  "psq"   {>="0.2.0"}
+  "qcheck-core"     {with-test}
+  "qcheck-alcotest" {with-test}
+  "alcotest"        {with-test}
+]
+description: """
+Lru provides weight-bounded finite maps that can remove the least-recently-used
+(LRU) bindings in order to maintain a weight constraint.
+"""

unikernel/duniverse/lru/src/dune

@@ -0,0 +1,6 @@
+(library
+  (public_name lru)
+  (synopsis "Scalable LRU caches")
+  (libraries psq)
+  (wrapped false))
+

unikernel/duniverse/lru/src/lru.ml

@@ -0,0 +1,334 @@
+(* Copyright (c) 2015-2016 David Kaloper Meršinjak. All rights reserved.
+   See LICENSE.md *)
+
+module type Weighted = sig type t val weight : t -> int end
+
+let invalid_arg fmt = Format.ksprintf invalid_arg fmt
+
+type 'a fmt = Format.formatter -> 'a -> unit
+
+let pf = Format.fprintf
+
+let pp_iter ?(sep = Format.pp_print_space) pp ppf i =
+  let first = ref true in
+  i @@ fun x ->
+    (match !first with true -> first := false | _ -> sep ppf ());
+    pp ppf x
+
+let cap_makes_sense ~m ~f cap =
+  if cap < 0 then invalid_arg "Lru.%s.%s: ~cap:%d" m f cap
+
+module F = struct
+
+  module type S = sig
+    type t
+    type k
+    type v
+    val empty : int -> t
+    val is_empty : t -> bool
+    val size : t -> int
+    val weight : t -> int
+    val capacity : t -> int
+    val resize : int -> t -> t
+    val trim : t -> t
+    val mem : k -> t -> bool
+    val find : k -> t -> v option
+    val promote : k -> t -> t
+    val add : k -> v -> t -> t
+    val remove : k -> t -> t
+    val pop : k -> t -> (v * t) option
+    val lru : t -> (k * v) option
+    val drop_lru : t -> t
+    val pop_lru : t -> ((k * v) * t) option
+    val fold : (k -> v -> 'a -> 'a) -> 'a -> t -> 'a
+    val fold_k : (k -> v -> 'a -> 'a) -> 'a -> t -> 'a
+    val iter : (k -> v -> unit) -> t -> unit
+    val iter_k : (k -> v -> unit) -> t -> unit
+    val of_list : (k * v) list -> t
+    val to_list : t -> (k * v) list
+    val pp : ?pp_size:(int * int) fmt -> ?sep:unit fmt -> (k * v) fmt -> t fmt
+    val pp_dump : k fmt -> v fmt -> t fmt
+  end
+
+  module Make (K: Map.OrderedType) (V: Weighted) = struct
+
+    module Q = Psq.Make (K) (struct
+      type t = int * V.t
+      let compare (g1, _) (g2, _) = compare (g1: int) g2
+    end)
+
+    type k = K.t
+    type v = V.t
+
+    type t = { cap: int; w: int; gen: int; q: Q.t }
+
+    let g0 = min_int
+
+    let is_empty t = Q.is_empty t.q
+    let size t = Q.size t.q
+    let weight t = t.w
+    let capacity t = t.cap
+
+    let cap_makes_sense = cap_makes_sense ~m:"F"
+
+    let empty cap =
+      cap_makes_sense ~f:"empty" cap; { cap; w = 0; gen = g0; q = Q.empty }
+
+    let resize cap t = cap_makes_sense ~f:"resize" cap; { t with cap }
+
+    let mem k t = Q.mem k t.q
+
+    let find k t = match Q.find k t.q with Some (_, v) -> Some v | _ -> None
+
+    let trim t =
+      let rec go t w q =
+        if w > t.cap then match Q.pop q with
+          Some ((_, (_, v)), q) -> go t (w - V.weight v) q
+        | None -> assert false
+        else { t with w; q } in
+      if t.w > t.cap then go t t.w t.q else t
+
+    let promote k ({ gen; _ } as t) =
+      if gen = max_int then empty t.cap else
+        { t with gen = gen + 1; q = Q.adjust k (fun (_, v) -> gen, v) t.q }
+
+    let rec add k v ({ gen; _ } as t) =
+      if gen = max_int then add k v (empty t.cap) else
+        let p = Some (gen, v) and p0 = ref None in
+        let q = Q.update k (fun x -> p0 := x; p) t.q in
+        let w = t.w + V.weight v -
+          (match !p0 with Some (_, v0) -> V.weight v0 | _ -> 0) in
+        { t with gen = gen + 1; w; q }
+
+    let remove k t = match Q.find k t.q with
+      None -> t
+    | Some (_, v) -> { t with w = t.w - V.weight v; q = Q.remove k t.q }
+
+    let pop k t = match Q.find k t.q with
+      None -> None
+    | Some (_, v) ->
+        Some (v, { t with w = t.w - V.weight v; q = Q.remove k t.q })
+
+    let lru t = match Q.min t.q with Some (k, (_, v)) -> Some (k, v) | _ -> None
+
+    let pop_lru t = match Q.pop t.q with
+      None -> None
+    | Some ((k, (_, v)), q) ->
+        Some ((k, v), { t with w = t.w - V.weight v; q })
+
+    let drop_lru t = match Q.pop t.q with
+      None -> t
+    | Some ((_, (_, v)), q) -> { t with w = t.w - V.weight v; q }
+
+    let sort_uniq_r xs =
+      let rec sieve k0 kv0 = function
+      | [] -> [kv0]
+      | (k, _ as kv)::kvs when K.compare k0 k = 0 -> sieve k kv kvs
+      | (k, _ as kv)::kvs -> kv0 :: sieve k kv kvs in
+      let cmp (k1, (g1, _)) (k2, (g2, _)) =
+        match K.compare k1 k2 with 0 -> compare (g1: int) g2 | r -> r
+      in
+      match List.sort cmp xs with [] -> [] | (k, _ as kv)::kvs -> sieve k kv kvs
+
+    let of_list xs =
+      let rec annotate g acc = function
+      | (k, v)::kvs -> annotate (succ g) ((k, (g, v))::acc) kvs
+      | [] -> g, sort_uniq_r acc in
+      let gen, kgvs = annotate g0 [] xs in
+      let q = Q.of_sorted_list kgvs in
+      let w = Q.fold (fun _ (_, v) w -> w + V.weight v) 0 q in
+      { cap = w; w; gen; q }
+
+    let fold f z t =
+      List.fold_right (fun (k, (_, v)) acc -> f k v acc)
+        (Q.to_priority_list t.q) z
+    let iter f t =
+      Q.to_priority_list t.q |> List.iter (fun (k, (_, v)) -> f k v)
+    let to_list t = fold (fun k v kvs -> (k, v) :: kvs) [] t
+
+    let fold_k f z t = Q.fold (fun k (_, v) -> f k v) z t.q
+    let iter_k f t = Q.iter (fun k (_, v) -> f k v) t.q
+
+    let pp ?(pp_size = fun _ -> ignore) ?sep pp ppf t =
+      let ppx ppf (k, (_, v)) = pp ppf (k, v) in
+      pf ppf "@[%a@[%a@]@]" pp_size (t.w, t.cap)
+        (pp_iter ?sep ppx) (fun f -> List.iter f (Q.to_priority_list t.q))
+
+    let pp_dump ppk ppv ppf =
+      let sep ppf () = pf ppf ";@ "
+      and ppkv ppf (k, v) = pf ppf "(@[%a,@ %a@])" ppk k ppv v in
+      pf ppf "of_list [%a]" (pp ~sep ppkv)
+  end
+
+end
+
+module M = struct
+
+  module Q = struct
+
+    type 'a node = {
+      value : 'a;
+      mutable next : 'a node option;
+      mutable prev : 'a node option
+    }
+
+    type 'a t = {
+      mutable first : 'a node option;
+      mutable last  : 'a node option
+    }
+
+    let detach t n =
+      let np = n.prev and nn = n.next in
+      ( match np with
+        | None   -> t.first <- nn
+        | Some x -> x.next <- nn; n.prev <- None );
+      ( match nn with
+        | None   -> t.last <- np
+        | Some x -> x.prev <- np; n.next <- None )
+
+    let append t n =
+      let on = Some n in
+      match t.last with
+      | Some x as l -> x.next <- on; t.last <- on; n.prev <- l
+      | None        -> t.first <- on; t.last <- on
+
+    let node x = { value = x; prev = None; next = None }
+
+    let create () = { first = None; last = None }
+
+    let iter f t =
+      let rec go f = function Some n -> f n.value; go f n.next | _ -> () in
+      go f t.first
+
+    let fold f t z =
+      let rec go f z = function Some n -> go f (f n.value z) n.prev | _ -> z in
+      go f z t.last
+  end
+
+  module type S = sig
+    type t
+    type k
+    type v
+    val create : ?random:bool -> int -> t
+    val is_empty : t -> bool
+    val size : t -> int
+    val weight : t -> int
+    val capacity : t -> int
+    val resize : int -> t -> unit
+    val trim : t -> unit
+    val mem : k -> t -> bool
+    val find : k -> t -> v option
+    val promote : k -> t -> unit
+    val add : k -> v -> t -> unit
+    val remove : k -> t -> unit
+    val lru : t -> (k * v) option
+    val drop_lru : t -> unit
+    val fold : (k -> v -> 'a -> 'a) -> 'a -> t -> 'a
+    val iter : (k -> v -> unit) -> t -> unit
+    val of_list : (k * v) list -> t
+    val to_list : t -> (k * v) list
+    val pp : ?pp_size:(int * int) fmt -> ?sep:unit fmt -> (k * v) fmt -> t fmt
+    val pp_dump : k fmt -> v fmt -> t fmt
+  end
+
+  module Bake (HT: Hashtbl.SeededS) (V: Weighted) = struct
+
+    type k = HT.key
+    type v = V.t
+
+    type t = {
+      ht : (k * v) Q.node HT.t;
+      q  : (k * v) Q.t;
+      mutable cap : int;
+      mutable w   : int;
+    }
+
+    let size t = HT.length t.ht
+    let weight t = t.w
+    let capacity t = t.cap
+    let is_empty t = HT.length t.ht = 0
+
+    let cap_makes_sense = cap_makes_sense ~m:"M"
+
+    let create ?random cap =
+      cap_makes_sense ~f:"create" cap;
+      { cap; w = 0; ht = HT.create ?random cap; q = Q.create () }
+
+    let lru t = match t.q.Q.first with Some n -> Some n.Q.value | _ -> None
+
+    let drop_lru t = match t.q.Q.first with
+      None -> ()
+    | Some ({ Q.value = (k, v); _ } as n) ->
+        t.w <- t.w - V.weight v;
+        HT.remove t.ht k;
+        Q.detach t.q n
+
+    let rec trim t = if weight t > t.cap then (drop_lru t; trim t)
+
+    let resize cap t = cap_makes_sense ~f:"resize" cap; t.cap <- cap
+
+    let remove k t =
+      try
+        let n = HT.find t.ht k in
+        t.w <- t.w - (snd n.Q.value |> V.weight);
+        HT.remove t.ht k; Q.detach t.q n
+      with Not_found -> ()
+
+    let add k v t =
+      remove k t;
+      let n = Q.node (k, v) in
+      t.w <- t.w + V.weight v;
+      HT.add t.ht k n; Q.append t.q n
+
+    let promote k t =
+      try
+        let n = HT.find t.ht k in Q.( detach t.q n; append t.q n )
+      with Not_found -> ()
+
+    let find k t =
+      try Some (snd (HT.find t.ht k).Q.value) with Not_found -> None
+
+    let mem k t = HT.mem t.ht k
+
+    let iter f t = Q.iter (fun (k, v) -> f k v) t.q
+    let fold f z t = Q.fold (fun (k, v) a -> f k v a) t.q z
+    let to_list t = Q.fold (fun x xs -> x::xs) t.q []
+
+    let of_list xs =
+      let t = create 0 in
+      List.iter (fun (k, v) -> add k v t) xs;
+      resize (Q.fold (fun (_, v) w -> w + V.weight v) t.q 0) t;
+      t
+
+    let pp ?(pp_size = fun _ -> ignore) ?sep pp ppf t =
+      pf ppf "@[%a@[%a@]@]" pp_size (t.w, t.cap)
+        (pp_iter ?sep pp) (fun f -> Q.iter f t.q)
+
+    let pp_dump ppk ppv ppf =
+      let sep ppf () = pf ppf ";@ "
+      and ppkv ppf (k, v) = pf ppf "(@[%a,@ %a@])" ppk k ppv v in
+      pf ppf "of_list [%a]" (pp ~sep ppkv)
+  end
+
+  module Make (K: Hashtbl.HashedType) (V: Weighted) =
+    Bake (Hashtbl.MakeSeeded (struct
+      include K
+      let hash _ = hash
+      let seeded_hash = hash [@@ocaml.warning "-32"]
+    end)) (V)
+
+  module MakeSeeded (K : Hashtbl.SeededHashedType) (V: Weighted) =
+    Bake (Hashtbl.MakeSeeded (K)) (V)
+
+end
+
+let memo (type k) (type v)
+    ?(hashed=(Hashtbl.hash, (=))) ?(weight = fun _ -> 1) ~cap f =
+  let module C =
+    M.Make (struct type t = k let hash = fst hashed let equal = snd hashed end)
+           (struct type t = v let weight = weight end) in
+    let c = C.create cap in
+    let rec g k = match C.find k c with
+      None   -> let v = f g k in C.add k v c; v
+    | Some v -> C.promote k c; v in
+    g

unikernel/duniverse/lru/src/lru.mli

@@ -0,0 +1,358 @@
+(* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved.
+   See LICENSE.md *)
+
+(** Scalable LRU caches
+
+    [Lru] provides weight-bounded finite maps that can remove the
+    least-recently-used (LRU) bindings in order to maintain a weight constraint.
+    Two implementations are provided: one is {{!F}functional}, the other
+    {{!M}imperative}.
+
+    The {{!F}functional} map is backed by a
+    {{:https://github.com/pqwy/psq}priority search queue}. Operations on
+    individual elements are [O(log n)].
+
+    The {{!M}mutable} map is backed by the standard {!Hashtbl} paired with a
+    doubly-linked list. Operations on individual elements incur an [O(1)]
+    overhead on top of hash table access.
+
+    Both versions support {{!Weighted}differentially weighted} bindings, and
+    have a capacity parameter that limits the combined weight of the bindings.
+    To limit the maps by the number of bindings, use [let weight _ = 1].
+
+    {e v0.3.0-4-gcf049b9 — {{:https://github.com/pqwy/lru }homepage}} *)
+
+(** {1:sem Semantics}
+
+    A pretty accurate model of a {{!F.S}functional} [k -> v] map is an
+    association list ([(k * v) list]) with unique keys.
+
+    {{!F.S.add}Adding} a bindings [k -> v] to [kvs] means
+    [List.remove_assoc k kvs @ [(k, v)]], {{!F.S.find}finding} a [k] means
+    [List.assoc_opt k kvs], and removing it means [List.remove_assoc k kvs].
+
+    The {{!F.S.lru}LRU binding} is then the first element of the list.
+
+    {{!F.S.promote}Promoting} a binding [k -> v] means removing, and then
+    re-adding it.
+
+    {{!F.S.trim}Trimming} [kvs] means retaining the longest suffix with the sum
+    of [weight v] not larger than {{!F.S.capacity}capacity}.
+
+    The {{!M.S}imperative} LRU map is like the above, but kept in a reference
+    cell. *)
+
+(** {1 Lru} *)
+
+(** Signature of types with measurable weight. *)
+module type Weighted = sig
+  type t
+  val weight : t -> int
+  (** [weight t] is a measure of [t]s contribution towards the total map
+      capacity. Weight must be strictly positive. *)
+end
+
+(** Functional LRU map. *)
+module F : sig
+
+  (** Signature of functional LRU maps. *)
+  module type S = sig
+
+    (** {1 Functional LRU map} *)
+
+    type t
+    (** A map. *)
+
+    type k
+    (** Keys in {{!t}[t]}. *)
+
+    type v
+    (** Values in {{!t}[t]}. *)
+
+    val empty : int -> t
+    (** [empty cap] is an empty map with capacity [cap].
+
+        @raise Invalid_argument when [cap < 0]. *)
+
+    val is_empty : t -> bool
+    (** [is_empty t] is [true] iff there are no bindings in [t]. *)
+
+    val size : t -> int
+    (** [size t] is the number of bindings in [t]. *)
+
+    (** {1 Limiting the weight of bindings} *)
+
+    val weight : t -> int
+    (** [weight t] is the combined weight of bindings in [t]. *)
+
+    val capacity : t -> int
+    (** [capacity t] is the maximum combined weight of bindings that {!trim}
+        will retain. *)
+
+    val resize : int -> t -> t
+    (** [resize cap t] sets [t]'s capacity to [cap], while leaving the bindings
+        unchanged.
+
+        @raise Invalid_argument when [cap < 0]. *)
+
+    val trim : t -> t
+    (** [trim t] is [t'], where [weight t' <= capacity t'].
+
+        This is achieved by discarding bindings in LRU-to-MRU order. *)
+
+    (** {1 Access by [k]} *)
+
+    val mem : k -> t -> bool
+    (** [mem k t] is [true] iff [k] is bound in [t]. *)
+
+    val find : k -> t -> v option
+    (** [find k t] is [Some v] when [k -> v] is bound in [t], or [None]
+        otherwise. *)
+
+    val promote : k -> t -> t
+    (** [promote k t] is [t] with the binding for [k] promoted to
+        most-recently-used, or [t] if [k] is not bound in [t]. *)
+
+    val add : k -> v -> t -> t
+    (** [add k v t] adds the binding [k -> v] to [t] as the most-recently-used
+        binding.
+
+        {b Note} [add] does not remove bindings. To ensure that the resulting
+        map is not over capacity, compose with {{!trim}[trim]}. *)
+
+    val remove : k -> t -> t
+    (** [remove k t] is [t] without a binding for [k]. *)
+
+    val pop : k -> t -> (v * t) option
+    (** [pop k t] is [(v, t')], where [v] is the value bound to [k], and [t']
+        is [t] without the binding [k -> t], or [None] if [k] is not bound in
+        [t]. *)
+
+    (** {1 Access to least-recently-used bindings} *)
+
+    val lru : t -> (k * v) option
+    (** [lru t] is the least-recently-used binding in [t], or [None], when [t]
+        is empty. *)
+
+    val drop_lru : t -> t
+    (** [drop_lru t] is [t] without the binding [lru t], or [t], when [t] is
+        empty. *)
+
+    val pop_lru : t -> ((k * v) * t) option
+    (** [pop_lru t] is [((k, v), t'], where [(k, v)] is [lru t], and [t'] is [t]
+        without that binding. *)
+
+    (** {1 Aggregate access} *)
+
+    val fold : (k -> v -> 'a -> 'a) -> 'a -> t -> 'a
+    (** [fold f z t] is [f k0 v0 (... (f kn vn z))], where [k0 -> v0] is LRU and
+        [kn -> vn] is MRU. *)
+
+    val fold_k : (k -> v -> 'a -> 'a) -> 'a -> t -> 'a
+    (** [fold_k f z t] folds in key-increasing order, ignoring the recently-used
+        ordering.
+
+        {b Note} [fold_k] is faster than [fold]. *)
+
+    val iter : (k -> v -> unit) -> t -> unit
+    (** [iter f t] applies [f] to all the bindings in [t] in in LRU-to-MRU
+        order. *)
+
+    val iter_k : (k -> v -> unit) -> t -> unit
+    (** [iter_k f t] applies f in key-increasing order, ignoring the
+        recently-used ordering.
+
+        {b Note} [iter_k] is faster than [iter]. *)
+
+    (** {1 Conversions} *)
+
+    val of_list : (k * v) list -> t
+    (** [of_list kvs] is a map with bindings [kvs], where the order of the list
+        becomes LRU-to-MRU ordering, and its {{!capacity}[capacity]} is set to
+        its {{!weight}[weight]}.
+
+        The resulting [t] has the same shape as if the bindings were
+        sequentially {{!add}added} in list order, except for capacity. *)
+
+    val to_list : t -> (k * v) list
+    (** [to_list t] are the bindings in [t] in LRU-to-MRU order. *)
+
+    open Format
+
+    (** {1 Pretty-printing} *)
+
+    val pp : ?pp_size:(formatter -> (int * int) -> unit) ->
+             ?sep:(formatter -> unit -> unit) ->
+             (formatter -> k * v -> unit) -> formatter -> t -> unit
+    (** [pp ~pp_size ~sep pp_kv ppf t] pretty-prints [t] to [ppf], using [pp_kv]
+        to print the bindings, [~sep] to separate them, and [~pp_size] to print
+        the {{!weight}[weight]} and {{!capacity}[capacity]}. [~sep] and
+        [~pp_size] default to unspecified printers. *)
+
+    (**/**)
+    val pp_dump : (formatter -> k -> unit) -> (formatter -> v -> unit)
+                    -> formatter -> t -> unit
+    (**/**)
+  end
+
+  (** [Make(K)(V)] is the {{!S}LRU map} with bindings [K.t -> V.t]. The weight
+      of an individual binding is the {!Weighted.weight} of [V.t]. *)
+  module Make (K: Map.OrderedType) (V: Weighted):
+    S with type k = K.t and type v = V.t
+end
+
+
+(** Mutable LRU map. *)
+module M : sig
+
+  (** Signature of mutable LRU maps. *)
+  module type S = sig
+
+    (** {1 Mutable LRU map} *)
+
+    type t
+    (** A map. *)
+
+    type k
+    (** Keys in {{!t}[t]}. *)
+
+    type v
+    (** Values in {{!t}[t]}. *)
+
+    val create : ?random:bool -> int -> t
+    (** [create ?random cap] is a new map with capacity [cap].
+
+        [~random] randomizes the underlying hash table. It defaults to [false].
+        See {!Hashtbl.create}.
+
+        {b Note.} The internal hash table is created with size [cap].
+
+        @raise Invalid_argument when [cap < 0]. *)
+
+    val is_empty : t -> bool
+    (** [is_empty t] is [true] iff there are no bindings in [t]. *)
+
+    val size : t -> int
+    (** [size t] is the number of bindings in [t]. *)
+
+    (** {1 Limiting the weight of bindings} *)
+
+    val weight : t -> int
+    (** [weight t] is the combined weight of bindings in [t]. *)
+
+    val capacity : t -> int
+    (** [capacity t] is the maximum combined weight of bindings that {!trim}
+        will retain. *)
+
+    val resize : int -> t -> unit
+    (** [resize cap t] sets [t]'s capacity to [cap], while leaving the bindings
+        unchanged.
+
+        @raise Invalid_argument when [cap < 0]. *)
+
+    val trim : t -> unit
+    (** [trim t] ensures that [weight t <= capacity t] by dropping bindings in
+        LRU-to-MRU order. *)
+
+    (** {1 Access by [k]} *)
+
+    val mem : k -> t -> bool
+    (** [mem k t] is [true] iff [k] is bound in [t]. *)
+
+    val find : k -> t -> v option
+    (** [find k t] is [Some v] when [k -> v] is bound in [t], or [None]
+        otherwise.
+
+        {b Note} This operation does not change the recently-used order. *)
+
+    val promote : k -> t -> unit
+    (** [promote k t] promotes the binding for [k], if it exists, to
+        most-recently-used. *)
+
+    val add : k -> v -> t -> unit
+    (** [add k v t] adds the binding [k -> v] to [t] as the most-recently-used
+        binding.
+
+        {b Note} [add] does not remove bindings. To ensure that the resulting
+        map is not over capacity, combine with {{!trim}[trim]}. *)
+
+    val remove : k -> t -> unit
+    (** [remove k t] is [t] without a binding for [k]. *)
+
+    (** {1 Access to least-recently-used bindings} *)
+
+    val lru : t -> (k * v) option
+    (** [lru t] is the least-recently-used binding in [t], or [None], when [t]
+        is empty. *)
+
+    val drop_lru : t -> unit
+    (** [drop_lru t] removes the binding [lru t]. *)
+
+    (** {1 Aggregate access} *)
+
+    val fold : (k -> v -> 'a -> 'a) -> 'a -> t -> 'a
+    (** [fold f z t] is [f k0 v0 (... (f kn vn z))], where [k0 -> v0] is LRU and
+        [kn -> vn] is MRU. *)
+
+    val iter : (k -> v -> unit) -> t -> unit
+    (** [iter f t] applies [f] to all the bindings in [t] in in LRU-to-MRU
+        order. *)
+
+    (** {1 Conversions} *)
+
+    val of_list : (k * v) list -> t
+    (** [of_list kvs] is a map with bindings [kvs], where the order of the list
+        becomes LRU-to-MRU ordering, and its {{!capacity}[capacity]} is set to
+        its {{!weight}[weight]}.
+
+        The resulting [t] has the same shape as if the bindings were
+        sequentially {{!add}added} in list order, except for capacity. *)
+
+    val to_list : t -> (k * v) list
+    (** [to_list t] are the bindings in [t] in LRU-to-MRU order. *)
+
+    open Format
+
+    (** {1 Pretty-printing} *)
+
+    val pp : ?pp_size:(formatter -> int * int -> unit) ->
+             ?sep:(formatter -> unit -> unit) ->
+             (formatter -> k * v -> unit) -> formatter -> t -> unit
+    (** [pp ~pp_size ~sep pp_kv ppf t] pretty-prints [t] to [ppf], using [pp_kv]
+        to print the bindings, [~sep] to separate them, and [~pp_size] to print
+        the {{!weight}[weight]} and {{!capacity}[capacity]}. [~sep] and
+        [~pp_size] default to unspecified printers. *)
+
+    (**/**)
+    val pp_dump : (formatter -> k -> unit) -> (formatter -> v -> unit)
+                    -> formatter -> t -> unit
+    (**/**)
+  end
+
+  (** [Make(K)(V)] is the {{!S}LRU map} with bindings [K.t -> V.t]. The weight
+      of an individual binding is the {!Weighted.weight} of [V.t]. *)
+  module Make (K: Hashtbl.HashedType) (V: Weighted):
+    S with type k = K.t and type v = V.t
+
+  (** [MakeSeeded(K)(V)] is a variant backed by {!Hashtbl.SeededS}. *)
+  module MakeSeeded (K: Hashtbl.SeededHashedType) (V: Weighted):
+    S with type k = K.t and type v = V.t
+
+end
+
+(** {1 One-off memoization} *)
+
+val memo : ?hashed:(('a -> int) * ('a -> 'a -> bool)) -> ?weight:('b -> int) ->
+           cap:int -> (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b
+(** [memo ?hashed ?weight ~cap f] is a new memoized instance of [f], using LRU
+    caching. [f] is an open recursive function of one parameter.
+
+    [~hashed] are hashing and equality over the arguments ['a]. It defaults to
+    [(Hashtbl.hash, Pervasives.(=))].
+
+    [~weight] is the weighting function over the results ['b]. It defaults to
+    [fun _ -> 1].
+
+    [~cap] is the total cache capacity.
+
+    @raise Invalid_argument when [cap < 0]. *)

unikernel/duniverse/lru/test/adapt.ml

@@ -0,0 +1,29 @@
+module M_as_F (K: Hashtbl.HashedType) (V: Lru.Weighted):
+  Lru.F.S with type k = K.t and type v = V.t =
+struct
+
+  let nope name _ =
+    invalid_arg @@ Format.sprintf "M_as_F.%s: not implemented" name
+
+  include Lru.M.Make (K) (V)
+
+  let unadd   = nope "unadd"
+  let pop_lru = nope "pop_lru"
+
+  let empty n = create n
+
+  let find ?promote k t =
+    match find ?promote k t with Some v -> Some (v, t) | _ -> None
+
+  let retaining f t = f t; t
+
+  let trim = retaining trim
+  let resize cap = retaining @@ resize cap
+  let add ?trim k v = retaining @@ add ?trim k v
+  let remove k = retaining @@ remove k
+  let drop_lru = retaining drop_lru
+
+  let fold f s t = fold f s t
+  let iter f t = iter f t
+  let to_list t = to_list t
+end

unikernel/duniverse/lru/test/bench.ml

@@ -0,0 +1,84 @@
+(* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved.
+   See LICENSE.md *)
+
+module I = struct
+  type t = int
+  let compare (a: int) b = compare a b
+  let equal (a: int) b = a = b
+  let hash (i: int) = Hashtbl.hash i
+  let weight _ = 1
+end
+module F = Lru.F.Make (I) (I)
+module M = Lru.M.Make (I) (I)
+
+module type S = sig
+  type t
+  val mk : int list -> t
+  val q : int -> t -> int option
+  val a : int -> int -> t -> unit
+  val r : int -> t -> unit
+end
+
+let r_int () = Random.int 2_000_000
+let double xs = List.map (fun x -> (x, x)) xs
+let randoms n = List.init n (fun _ -> r_int ())
+
+open Unmark
+
+let suite ms n =
+  let rs = randoms n in
+  (* let rs1 = randoms n in *)
+  group (string_of_int n) [
+    (* group "mk" (ms |> List.map @@ fun (name, (module M: S)) -> *)
+    (*   bench name (fun () -> M.mk rs)); *)
+    group "find" (ms |> List.map @@ fun (name, (module M: S)) ->
+      let t = M.mk rs in
+      let x = r_int () in
+      bench name (fun () -> M.q x t))
+      (* bench name (fun () -> rs |> List.iter (fun x -> M.q x t |> ignore))) *)
+  ; group "add" (ms |> List.map @@ fun (name, (module M: S)) ->
+      let t = M.mk rs in
+      let x = r_int () in
+      bench name (fun () -> M.a x x t))
+      (* bench name (fun () -> *)
+      (*   let t = M.mk rs in rs1 |> List.iter (fun x -> M.a x x t))) *)
+  ; group "remove" (ms |> List.map @@ fun (name, (module M: S)) ->
+      let t = M.mk rs in
+      let x = r_int () in
+      bench name (fun () -> M.r x t));
+      (* bench name (fun () -> *)
+      (*   let t = M.mk rs in rs1 |> List.iter (fun x -> M.r x t))); *)
+  ]
+
+let impls = [
+  "fun", (module struct
+    type t = F.t ref
+    let mk xs = ref (F.of_list (double xs))
+    let q k q = F.find k !q
+    let a k v q = q := F.add k v !q
+    let r k q = q := F.remove k !q
+  end: S)
+; "imp",
+  (module struct
+    type t = M.t
+    let mk xs = M.of_list (double xs)
+    let q k q = M.find k q
+    let a = M.add
+    let r = M.remove
+  end: S)
+; "ht",
+  (module struct
+    type t = (int, int) Hashtbl.t
+    let mk xs =
+      let h = Hashtbl.create 20 in
+      xs |> List.iter (fun x -> Hashtbl.replace h x x);
+      h
+    let q k m = Hashtbl.find_opt m k
+    let a k v m = Hashtbl.replace m k v
+    let r k m = Hashtbl.remove m k
+  end: S)
+]
+
+let arg = Cmdliner.Arg.(
+  value @@ opt (list int) [10; 100; 1000] @@ info ["sizes"])
+let _ = Unmark_cli.main_ext "lru" ~arg @@ List.map (suite impls)

unikernel/duniverse/lru/test/dune

@@ -0,0 +1,9 @@
+(test
+  (name test)
+  (modules test adapt)
+  (libraries lru alcotest qcheck-core qcheck-alcotest))
+
+(executable
+  (name bench)
+  (modules bench)
+  (libraries lru unmark unmark.cli cmdliner))

unikernel/duniverse/lru/test/test.ml

@@ -0,0 +1,191 @@
+(* Copyright (c) 2016 David Kaloper Meršinjak. All rights reserved.
+   See LICENSE.md *)
+
+let id x = x
+let (%) f g x = f (g x)
+
+module I = struct
+  type t = int
+  let compare (a: int) b = compare a b
+  let equal (a: int) b = a = b
+  let hash (i: int) = Hashtbl.hash i
+  let weight _ = 1
+end
+
+let sort_uniq_r (type a) cmp xs =
+  let module S = Set.Make (struct type t = a let compare = cmp end) in
+  List.fold_right S.add xs S.empty |> S.elements
+let uniq_r (type a) cmp xs =
+  let module S = Set.Make (struct type t = a let compare = cmp end) in
+  let rec go s acc = function
+    []    -> acc
+  | x::xs -> if S.mem x s then go s acc xs else go (S.add x s) (x :: acc) xs in
+  go S.empty [] (List.rev xs)
+let list_of_iter_2 i =
+  let xs = ref [] in i (fun a b -> xs := (a, b) :: !xs); List.rev !xs
+
+let list_trim w xs =
+  let rec go wacc acc = function
+    []     -> acc
+  | kv::xs -> let w' = I.weight (snd kv) + wacc in
+             if w' <= w then go w' (kv::acc) xs else acc in
+  go 0 [] (List.rev xs)
+let list_weight = List.fold_left (fun a (_, v) -> a + I.weight v) 0
+
+let cmpi (a: int) b = compare a b
+let cmp_k (k1, _) (k2, _) = cmpi k1 k2
+let sorted_by_k xs = List.sort cmp_k xs
+
+let size = QCheck.Gen.(small_nat >|= fun x -> x mod 1_000)
+let bindings = QCheck.(
+  make Gen.(list_size size (pair small_nat small_nat))
+    ~print:Fmt.(to_to_string Fmt.(Dump.(list (pair int int))))
+    ~shrink:Shrink.list)
+
+let test name gen p =
+  QCheck.Test.make ~name gen p |> QCheck_alcotest.to_alcotest
+
+
+module F = Lru.F.Make (I) (I)
+let pp_f = Fmt.(F.pp_dump int int)
+let (!) f = `Sem F.(to_list f, size f, weight f)
+let sem xs = `Sem List.(xs, length xs, list_weight xs)
+let lru = QCheck.(
+  map F.of_list bindings ~rev:F.to_list |>
+    set_print Fmt.(to_to_string pp_f))
+let lru_w_nat = QCheck.(pair lru small_nat)
+
+let () = Alcotest.run ~and_exit:false "Lru.F" [
+
+  "of_list", [
+    test "sem" bindings
+      (fun xs -> !F.(of_list xs) = sem (uniq_r cmp_k xs));
+    test "cap" bindings
+      (fun xs -> F.(capacity (of_list xs)) = list_weight (uniq_r cmp_k xs));
+  ];
+
+  "membership", [
+    test "find sem" lru_w_nat
+      (fun (m, x) -> F.find x m = List.assoc_opt x (F.to_list m));
+    test "mem ==> find" lru_w_nat
+      (fun (m, e) -> QCheck.assume (F.mem e m); F.find e m <> None);
+    test "find ==> mem" lru_w_nat
+      (fun (m, e) -> QCheck.assume (F.find e m <> None); F.mem e m);
+  ];
+
+  "add", [
+    test "sem" lru_w_nat
+      (fun (m, k) ->
+        !(F.add k k m) = sem (List.remove_assoc k (F.to_list m) @ [k, k]));
+  ];
+
+  "remove", [
+    test "sem" lru_w_nat
+      (fun (m, k) -> !(F.remove k m) = sem (List.remove_assoc k (F.to_list m)));
+  ];
+
+  "trim", [
+    test "sem" lru_w_nat
+      (fun (m, x) ->
+        !F.(resize x m |> trim) = sem (list_trim x (F.to_list m)));
+  ];
+
+  "promote", [
+    test "sem" lru_w_nat
+      (fun (m, x) ->
+        !(F.promote x m) =
+          !(match F.find x m with Some v -> F.add x v m | _ -> m));
+  ];
+
+  "lru", [
+    test "lru sem" lru
+      (fun m ->
+        QCheck.assume (F.size m > 0);
+        F.lru m = Some (List.hd (F.to_list m)));
+    test "drop_lru sem" lru
+      (fun m ->
+        QCheck.assume (F.size m > 0);
+        F.(to_list (drop_lru m) = List.tl (F.to_list m)));
+  ];
+
+  "conv", [
+    test "to_list inv" lru (fun m -> !F.(of_list (to_list m)) = !m);
+    test "to_list = fold" lru
+      (fun m -> F.to_list m = F.fold (fun k v a -> (k, v)::a) [] m);
+    test "to_list = iter" lru
+      (fun m -> list_of_iter_2 (fun f -> F.iter f m) = F.to_list m);
+    test "fold_k sem" lru
+      (fun m ->
+        F.fold_k (fun k v a -> (k, v)::a) [] m = sorted_by_k (F.to_list m));
+    test "iter_k sem" lru
+      (fun m ->
+        list_of_iter_2 (fun f -> F.iter_k f m) = sorted_by_k (F.to_list m));
+  ]
+
+]
+
+module M = Lru.M.Make (I) (I)
+let pp_m = Fmt.(M.pp_dump int int)
+let (!!) m = `Sem M.(to_list m, size m, weight m)
+let lru = QCheck.(
+  map M.of_list bindings ~rev:M.to_list |>
+    set_print Fmt.(to_to_string pp_m))
+let lru_w_nat = QCheck.(pair lru small_nat)
+let lrus = QCheck.(
+  map (fun xs -> M.of_list xs, F.of_list xs) ~rev:(F.to_list % snd) bindings
+  |> set_print Fmt.(to_to_string pp_f % snd))
+let lrus_w_nat = QCheck.(pair lrus small_nat)
+
+let () = Alcotest.run "Lru.M" [
+
+  "of_list", [
+    test "sem" bindings
+      (fun xs -> !!M.(of_list xs) = sem (uniq_r cmp_k xs));
+    test "cap" bindings
+      (fun xs -> M.(capacity (of_list xs)) = list_weight (uniq_r cmp_k xs));
+  ];
+
+  "membership", [
+    test "find" lrus_w_nat (fun ((m, f), x) -> M.find x m = F.find x f);
+    test "mem" lrus_w_nat (fun ((m, f), x) -> M.mem x m = F.mem x f);
+  ];
+
+  "add", [
+    test "eqv" lrus_w_nat
+      (fun ((m, f), x) -> M.add x x m; !!m = !(F.add x x f))
+  ];
+
+  "remove", [
+    test "eqv" lrus_w_nat
+      (fun ((m, f), x) -> M.remove x m; !!m = !(F.remove x f));
+  ];
+
+  "trim", [
+    test "eqv" lrus_w_nat
+      (fun ((m, f), x) ->
+        M.resize x m; M.trim m; !!m = !F.(resize x f |> trim));
+  ];
+
+  "promote", [
+    test "eqv" lrus_w_nat
+      (fun ((m, f), x) -> M.promote x m; !!m = !(F.promote x f));
+  ];
+
+  "lru", [
+    test "eqv" lrus (fun (m, f) -> M.lru m = F.lru f);
+    test "drop eqv" lrus (fun (m, f) -> M.drop_lru m; !!m = !F.(drop_lru f));
+  ];
+
+  "conv", [
+    test "to_list inv" lru (fun m -> !!M.(of_list (to_list m)) = !!m);
+    test "to_list = fold" lru
+      (fun m -> M.fold (fun k v a -> (k, v)::a) [] m = M.to_list m);
+    test "to_list = iter" lru
+      (fun m -> list_of_iter_2 (fun f -> M.iter f m) = M.to_list m)
+  ];
+
+  "pp", [
+    test "eqv" lrus
+      (fun (m, f) -> Fmt.(to_to_string pp_m m = to_to_string pp_f f));
+  ]
+]