LRU-cache example

README.md

@@ -969,10 +969,11 @@ type ('k, 'v) cache = {
 To create a cache we just create the data structures:
 
 ```ocaml
-# let cache ?hashed_type capacity =
-    { space = Loc.make capacity;
-      table = Hashtbl.create ?hashed_type ();
-      order = Dllist.create () }
+# let cache ?hashed_type capacity = {
+    space = Loc.make capacity;
+    table = Hashtbl.create ?hashed_type ();
+    order = Dllist.create ()
+  }
 val cache : ?hashed_type:'a Hashtbl.hashed_type -> int -> ('a, 'b) cache =
   <fun>
 ```
@@ -997,30 +998,30 @@ val get_opt : xt:'a Xt.t -> ('b, 'c) cache -> 'b -> 'c option = <fun>
 that, as explained previously, moves the node corresponding to the accessed
 association to the left end of the list.
 
-To introduce associations we provide the `set` operation
+To introduce associations we provide the `set_blocking` operation
 
 ```ocaml
-# let set ~xt {table; order; space; _} key value =
+# let set_blocking ~xt {table; order; space; _} key value =
     let node =
       match Hashtbl.Xt.find_opt ~xt table key with
       | None ->
         if 0 = Xt.update ~xt space (fun n -> Int.max 0 (n-1)) then
-          Dllist.Xt.take_opt_r ~xt order
-          |> Option.iter (Hashtbl.Xt.remove ~xt table);
+          Dllist.Xt.take_blocking_r ~xt order
+          |> Hashtbl.Xt.remove ~xt table;
         Dllist.Xt.add_l ~xt key order
       | Some (node, _) ->
         Dllist.Xt.move_l ~xt node order;
         node
     in
     Hashtbl.Xt.replace ~xt table key (node, value)
-val set : xt:'a Xt.t -> ('b, 'c) cache -> 'b -> 'c -> unit = <fun>
+val set_blocking : xt:'a Xt.t -> ('b, 'c) cache -> 'b -> 'c -> unit = <fun>
 ```
 
 that, like `get_opt`, either moves or adds the node of the accessed association
 to the left end of the list. In case a new association is added, the space is
-decremented. If there was no space, an association is first removed. As
-described previously, the association to remove is determined by removing the
-rightmost element from the list.
+decremented. If there was no space, an association is first removed, which will
+block in case capacity is 0. As described previously, the association to remove
+is determined by removing the rightmost element from the list.
 
 We can then test that the cache works as expected:
 
@@ -1029,16 +1030,16 @@ We can then test that the cache works as expected:
 val a_cache : (int, string) cache =
   {space = <abstr>; table = <abstr>; order = <abstr>}
 
-# Xt.commit { tx = set a_cache 101 "basics" }
+# Xt.commit { tx = set_blocking a_cache 101 "basics" }
 - : unit = ()
 
-# Xt.commit { tx = set a_cache 42 "answer" }
+# Xt.commit { tx = set_blocking a_cache 42 "answer" }
 - : unit = ()
 
 # Xt.commit { tx = get_opt a_cache 101 }
 - : string option = Some "basics"
 
-# Xt.commit { tx = set a_cache 2023 "year" }
+# Xt.commit { tx = set_blocking a_cache 2023 "year" }
 - : unit = ()
 
 # Xt.commit { tx = get_opt a_cache 42 }

test/kcas_data/dune

@@ -1,4 +1,11 @@
 (tests
- (names dllist_test hashtbl_test mvar_test queue_test stack_test xt_test)
+ (names
+  dllist_test
+  hashtbl_test
+  lru_cache_example
+  mvar_test
+  queue_test
+  stack_test
+  xt_test)
  (libraries alcotest kcas kcas_data domain_shims)
  (package kcas_data))

test/kcas_data/lru_cache.ml

@@ -0,0 +1,69 @@
+open Kcas
+open Kcas_data
+
+type ('k, 'v) t = {
+  space : int Loc.t;
+  table : ('k, 'k Dllist.node * 'v) Hashtbl.t;
+  order : 'k Dllist.t;
+}
+
+let check_capacity capacity =
+  if capacity < 0 then invalid_arg "Lru_cache: capacity must be non-negative"
+
+let create ?hashed_type capacity =
+  check_capacity capacity;
+  {
+    space = Loc.make capacity;
+    table = Hashtbl.create ?hashed_type ();
+    order = Dllist.create ();
+  }
+
+module Xt = struct
+  let capacity_of ~xt c = Xt.get ~xt c.space + Hashtbl.Xt.length ~xt c.table
+
+  let set_capacity ~xt c new_capacity =
+    check_capacity new_capacity;
+    let old_length = Hashtbl.Xt.length ~xt c.table in
+    let old_space = Xt.get ~xt c.space in
+    let old_capacity = old_space + old_length in
+    for _ = 1 to old_length - new_capacity do
+      Dllist.Xt.take_blocking_r ~xt c.order |> Hashtbl.Xt.remove ~xt c.table
+    done;
+    Xt.set ~xt c.space (Int.max 0 (old_space + new_capacity - old_capacity))
+
+  let get_opt ~xt c key =
+    Hashtbl.Xt.find_opt ~xt c.table key
+    |> Option.map @@ fun (node, datum) ->
+       Dllist.Xt.move_l ~xt node c.order;
+       datum
+
+  let set_blocking ~xt c key datum =
+    let node =
+      match Hashtbl.Xt.find_opt ~xt c.table key with
+      | None ->
+          if 0 = Xt.update ~xt c.space (fun n -> Int.max 0 (n - 1)) then
+            Dllist.Xt.take_blocking_r ~xt c.order
+            |> Hashtbl.Xt.remove ~xt c.table;
+          Dllist.Xt.add_l ~xt key c.order
+      | Some (node, _) ->
+          Dllist.Xt.move_l ~xt node c.order;
+          node
+    in
+    Hashtbl.Xt.replace ~xt c.table key (node, datum)
+
+  let remove ~xt c key =
+    Hashtbl.Xt.find_opt ~xt c.table key
+    |> Option.iter @@ fun (node, _) ->
+       Hashtbl.Xt.remove ~xt c.table key;
+       Dllist.Xt.remove ~xt node;
+       Xt.incr ~xt c.space
+end
+
+let capacity_of c = Kcas.Xt.commit { tx = Xt.capacity_of c }
+let set_capacity c n = Kcas.Xt.commit { tx = Xt.set_capacity c n }
+let get_opt c k = Kcas.Xt.commit { tx = Xt.get_opt c k }
+
+let set_blocking ?timeoutf c k v =
+  Kcas.Xt.commit ?timeoutf { tx = Xt.set_blocking c k v }
+
+let remove c k = Kcas.Xt.commit { tx = Xt.remove c k }

test/kcas_data/lru_cache.mli

@@ -0,0 +1,18 @@
+open Kcas
+open Kcas_data
+
+type ('k, 'v) t
+
+val create : ?hashed_type:'k Hashtbl.hashed_type -> int -> ('k, 'v) t
+
+module Xt :
+  Lru_cache_intf.Ops
+    with type ('k, 'v) t := ('k, 'v) t
+    with type ('x, 'fn) fn := xt:'x Xt.t -> 'fn
+    with type ('x, 'fn) blocking_fn := xt:'x Xt.t -> 'fn
+
+include
+  Lru_cache_intf.Ops
+    with type ('k, 'v) t := ('k, 'v) t
+    with type ('x, 'fn) fn := 'fn
+    with type ('x, 'fn) blocking_fn := ?timeoutf:float -> 'fn

test/kcas_data/lru_cache_example.ml

@@ -0,0 +1,56 @@
+open Kcas
+
+module Lru_cache = struct
+  include Lru_cache
+
+  module Xt = struct
+    include Xt
+
+    let get ~xt c key = Kcas.Xt.to_blocking ~xt (get_opt c key)
+
+    let get_if ~xt c key predicate =
+      let snap = Kcas.Xt.snapshot ~xt in
+      let datum = get ~xt c key in
+      if predicate datum then datum else Retry.later (Kcas.Xt.rollback ~xt snap)
+
+    let try_set ~xt c key datum =
+      match set_blocking ~xt c key datum with
+      | () -> true
+      | exception Retry.Later -> false
+  end
+
+  let get ?timeoutf c k = Kcas.Xt.commit ?timeoutf { tx = Xt.get c k }
+  let get_if ?timeoutf c k p = Kcas.Xt.commit ?timeoutf { tx = Xt.get_if c k p }
+  let try_set c k d = Kcas.Xt.commit { tx = Xt.try_set c k d }
+end
+
+let () =
+  let c = Lru_cache.create 10 in
+  let domain =
+    Domain.spawn @@ fun () ->
+    let tx ~xt = Lru_cache.Xt.get ~xt c "a" + Lru_cache.Xt.get ~xt c "b" in
+    Xt.commit { tx }
+  in
+  Lru_cache.set_blocking c "b" 30;
+  Lru_cache.set_blocking c "a" 12;
+  assert (Domain.join domain = 42);
+  ()
+
+let () =
+  let c = Lru_cache.create 10 in
+  assert (Lru_cache.try_set c "a" 1);
+  Lru_cache.set_blocking c "c" 2;
+  assert (Lru_cache.capacity_of c = 10);
+  assert (Lru_cache.get_opt c "b" = None);
+  assert (Lru_cache.get c "a" = 1);
+  Lru_cache.set_capacity c 3;
+  assert (Lru_cache.get c "c" = 2);
+  Lru_cache.set_capacity c 1;
+  assert (Lru_cache.capacity_of c = 1);
+  assert (Lru_cache.get_opt c "a" = None);
+  assert (Lru_cache.get_if c "c" (( <> ) 0) = 2);
+  Lru_cache.remove c "c";
+  assert (Lru_cache.get_opt c "c" = None);
+  ()
+
+let () = Printf.printf "LRU Cache OK!\n%!"

test/kcas_data/lru_cache_intf.ml

@@ -0,0 +1,11 @@
+module type Ops = sig
+  type ('k, 'v) t
+  type ('x, 'fn) fn
+  type ('x, 'fn) blocking_fn
+
+  val capacity_of : ('x, ('k, 'v) t -> int) fn
+  val set_capacity : ('x, ('k, 'v) t -> int -> unit) fn
+  val get_opt : ('x, ('k, 'v) t -> 'k -> 'v option) fn
+  val set_blocking : ('x, ('k, 'v) t -> 'k -> 'v -> unit) blocking_fn
+  val remove : ('x, ('k, 'v) t -> 'k -> unit) fn
+end