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));
+  ]
+]