irmin: Move LRU cache to kcas

Author: clecat

irmin.opam

@@ -22,6 +22,8 @@ depends: [
   "uutf"
   "jsonm"   {>= "1.0.0"}
   "eio"     {>= "0.12"}
+  "kcas"    {>= "0.6.1"}
+  "kcas_data" {>= "0.6.1"}
   "lwt"     {>= "5.6.1"}
   "digestif" {>= "0.9.0"}
   "ocamlgraph"
@@ -41,6 +43,8 @@ depends: [
 ]
 
 pin-depends: [
+  # Fix segv in kcas
+  [ "kcas.dev" "git+https://[email protected]/ocaml-multicore/kcas#5f3a39dfc72189e2b83f96c3754d402d5e7d6bc5"]
   # Metrics may have been unnecessarily constrained in opam-repository
   [ "metrics.dev" "git+https://github.com/mirage/metrics#995eb18d2837df02c8ead719c00fb156cf475ab5"]
   [ "metrics-unix.dev" "git+https://github.com/mirage/metrics#995eb18d2837df02c8ead719c00fb156cf475ab5"]

src/irmin-pack/io/lru.ml

@@ -87,5 +87,3 @@ let mem { lru; _ } k = Internal.mem lru k
 let clear t =
   Internal.clear t.lru;
   t.total_weight <- 0
-
-let iter { lru; _ } f = Internal.iter lru (fun k wv -> f k (v wv))

src/irmin-pack/io/lru.mli

@@ -36,4 +36,3 @@ val add : t -> int63 -> Irmin_pack.Pack_value.weight -> value -> unit
 val find : t -> key -> value
 val mem : t -> key -> bool
 val clear : t -> unit
-val iter : t -> (key -> value -> unit) -> unit

src/irmin/dune

@@ -11,6 +11,8 @@
   logs
   logs.fmt
   eio
+  kcas
+  kcas_data
   mtime
   ocamlgraph
   uri

src/irmin/lru.ml

@@ -16,174 +16,148 @@
 
 (* Extracted from https://github.com/pqwy/lru *)
 
-module MakeUnsafe (H : Hashtbl.HashedType) = struct
-  module HT = Hashtbl.Make (H)
+open Kcas
+
+module Make (H : Hashtbl.HashedType) = struct
+  module HT = Kcas_data.Hashtbl
 
   module Q = struct
     type 'a node = {
       value : 'a;
-      mutable next : 'a node option;
-      mutable prev : 'a node option;
+      next : 'a node option Loc.t;
+      prev : 'a node option Loc.t;
     }
 
-    type 'a t = {
-      mutable first : 'a node option;
-      mutable last : 'a node option;
-    }
+    type 'a t = { tail : 'a node option Loc.t; head : 'a node option Loc.t }
 
-    let detach t n =
-      let np = n.prev and nn = n.next in
+    let detach ~xt t n =
+      let np = Xt.get ~xt n.prev and nn = Xt.get ~xt n.next in
       (match np with
-      | None -> t.first <- nn
+      | None -> Xt.set ~xt t.tail nn
       | Some x ->
-          x.next <- nn;
-          n.prev <- None);
+          Xt.set ~xt x.next nn;
+          Xt.set ~xt n.prev None);
       match nn with
-      | None -> t.last <- np
+      | None -> Xt.set ~xt t.head np
       | Some x ->
-          x.prev <- np;
-          n.next <- None
+          Xt.set ~xt x.prev np;
+          Xt.set ~xt n.next None
 
-    let append t n =
+    let append ~xt t n =
       let on = Some n in
-      match t.last with
+      let hd = Xt.get ~xt t.head in
+      match hd with
       | Some x as l ->
-          x.next <- on;
-          t.last <- on;
-          n.prev <- l
+          Xt.set ~xt x.next on;
+          Xt.set ~xt t.head on;
+          Xt.set ~xt 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 t f =
-      let rec aux f = function
-        | Some n ->
-            let next = n.next in
-            f n.value;
-            aux f next
-        | _ -> ()
-      in
-      aux f t.first
+          Xt.set ~xt t.tail on;
+          Xt.set ~xt t.head on
 
-    let clear t =
-      t.first <- None;
-      t.last <- None
+    let node x = { value = x; prev = Loc.make None; next = Loc.make None }
+    let create () = { tail = Loc.make None; head = Loc.make None }
+
+    let clear ~xt t =
+      Xt.set ~xt t.tail None;
+      Xt.set ~xt t.head None
   end
 
-  type key = HT.key
+  type key = H.t
 
   type 'a t = {
-    ht : (key * 'a) Q.node HT.t;
+    ht : (key, (key * 'a) Q.node) HT.t;
     q : (key * 'a) Q.t;
-    mutable cap : cap;
-    mutable w : int;
+    cap : cap;
+    w : int Loc.t;
   }
 
   and cap = Uncapped | Capped of int
 
-  let weight t = t.w
+  let weight ~xt t = Xt.get ~xt t.w
 
   let create cap =
     let cap, ht_cap =
       if cap < 0 then (Uncapped, 65536) else (Capped cap, cap)
     in
-    { cap; w = 0; ht = HT.create ht_cap; q = Q.create () }
+    {
+      cap;
+      w = Loc.make 0;
+      ht = HT.create ~hashed_type:(module H) ~min_buckets:ht_cap ();
+      q = Q.create ();
+    }
 
-  let drop t =
-    match t.q.first with
+  let drop ~xt t =
+    let tl = Xt.get ~xt t.q.tail in
+    match tl with
     | None -> None
     | Some ({ Q.value = k, v; _ } as n) ->
-        t.w <- t.w - 1;
-        HT.remove t.ht k;
-        Q.detach t.q n;
+        Xt.modify ~xt t.w (fun tw -> tw - 1);
+        HT.Xt.remove ~xt t.ht k;
+        Q.detach ~xt t.q n;
         Some v
 
-  let remove t k =
-    try
-      let n = HT.find t.ht k in
-      t.w <- t.w - 1;
-      HT.remove t.ht k;
-      Q.detach t.q n
-    with Not_found -> ()
+  let remove ~xt t k =
+    match HT.Xt.find_opt ~xt t.ht k with
+    | None -> ()
+    | Some n ->
+        Xt.modify ~xt t.w (fun tw -> tw - 1);
+        HT.Xt.remove ~xt t.ht k;
+        Q.detach ~xt t.q n
 
   let add t k v =
-    let add t k v =
-      remove t k;
-      let n = Q.node (k, v) in
-      t.w <- t.w + 1;
-      HT.add t.ht k n;
-      Q.append t.q n
+    let tx ~xt =
+      let add t k v =
+        remove ~xt t k;
+        let n = Q.node (k, v) in
+        Xt.modify ~xt t.w (fun tw -> tw + 1);
+        HT.Xt.replace ~xt t.ht k n;
+        Q.append ~xt t.q n
+      in
+      match t.cap with
+      | Capped c when c = 0 -> ()
+      | Uncapped -> add t k v
+      | Capped c ->
+          add t k v;
+          if weight ~xt t > c then
+            let _ = drop ~xt t in
+            ()
     in
-    match t.cap with
-    | Capped c when c = 0 -> ()
-    | Uncapped -> add t k v
-    | Capped c ->
-        add t k v;
-        if weight t > c then
-          let _ = drop t in
-          ()
-
-  let promote t k =
-    try
-      let n = HT.find t.ht k in
-      Q.(
-        detach t.q n;
-        append t.q n)
-    with Not_found -> ()
-
-  let find_opt t k =
-    match HT.find_opt t.ht k with
-    | Some v ->
-        promote t k;
-        Some (snd v.value)
-    | None -> None
-
-  let mem t k =
-    match HT.mem t.ht k with
-    | false -> false
-    | true ->
-        promote t k;
-        true
-
-  let iter t f = Q.iter t.q (fun (k, v) -> f k v)
-
-  let clear t =
-    t.w <- 0;
-    HT.clear t.ht;
-    Q.clear t.q
-end
-
-(** Safe but might be incredibly slow. *)
-module Make (H : Hashtbl.HashedType) = struct
-  module Unsafe = MakeUnsafe (H)
-
-  type 'a t = { lock : Eio.Mutex.t; data : 'a Unsafe.t }
-
-  let create cap =
-    let lock = Eio.Mutex.create () in
-    let data = Unsafe.create cap in
-    { lock; data }
-
-  let add { lock; data } k v =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.add data k v
+    Xt.commit { tx }
 
-  let find_opt { lock; data } k =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.find_opt data k
+  let drop t = Xt.commit { tx = drop t }
 
-  let find t k = match find_opt t k with Some v -> v | None -> raise Not_found
+  let promote ~xt t n =
+    Q.detach ~xt t.q n;
+    Q.append ~xt t.q n
 
-  let mem { lock; data } k =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.mem data k
+  let find t k =
+    let tx ~xt =
+      match HT.Xt.find_opt ~xt t.ht k with
+      | Some v ->
+          promote ~xt t v;
+          snd v.value
+      | None ->
+          raise Not_found
+    in
+    Xt.commit { tx }
 
-  let iter { lock; data } f =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.iter data f
+  let mem t k =
+    let tx ~xt =
+      match HT.Xt.find_opt ~xt t.ht k with
+      | None -> false
+      | Some v ->
+          promote ~xt t v;
+          true
+    in
+    Xt.commit { tx }
 
-  let clear { lock; data } =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.clear data
+  let clear t =
+    let tx ~xt =
+      Xt.set ~xt t.w 0;
+      HT.Xt.clear ~xt t.ht;
+      Q.clear ~xt t.q
+    in
+    Xt.commit { tx }
 
-  let drop { lock; data } =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.drop data
 end

src/irmin/lru.mli

@@ -23,6 +23,5 @@ module Make (H : Hashtbl.HashedType) : sig
   val find : 'a t -> H.t -> 'a
   val mem : 'a t -> H.t -> bool
   val clear : 'a t -> unit
-  val iter : 'a t -> (H.t -> 'a -> unit) -> unit
   val drop : 'a t -> 'a option
 end