From 3e945d504c4b8926b40d77a6303177745ce91040 Mon Sep 17 00:00:00 2001
From: gwenaelle <charles-edouard.lecat@epitech.eu>
Date: Fri, 23 Feb 2024 15:27:12 +0100
Subject: [PATCH 1/4] irmin: Move LRU cache to kcas

---
 irmin.opam                |   8 ++
 src/irmin-pack/io/lru.ml  |   2 -
 src/irmin-pack/io/lru.mli |   1 -
 src/irmin/dune            |   2 +
 src/irmin/lru.ml          | 224 +++++++++++++++++---------------------
 src/irmin/lru.mli         |   1 -
 6 files changed, 109 insertions(+), 129 deletions(-)

diff --git a/irmin.opam b/irmin.opam
index 5619596f817..ba3544d83ed 100644
--- a/irmin.opam
+++ b/irmin.opam
@@ -22,6 +22,8 @@ depends: [
   "uutf"
   "jsonm"   {>= "1.0.0"}
   "eio"     {>= "1.0"}
+  "kcas"    {= "dev"}
+  "kcas_data" {= "dev"}
   "lwt"     {>= "5.6.1"}
   "digestif" {>= "0.9.0"}
   "ocamlgraph"
@@ -41,6 +43,12 @@ depends: [
 ]
 
 pin-depends: [
+  # Fix segv in kcas
+  [ "kcas.dev" "git+https://git@github.com/ocaml-multicore/kcas#5f3a39dfc72189e2b83f96c3754d402d5e7d6bc5"]
+  [ "kcas_data.dev" "git+https://git@github.com/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"]
   # Fix race in formatters
   [ "alcotest.dev" "git+https://github.com/haesbaert/alcotest#99030be1df12a17fc2a0f3d00b181cd31cf6b0d4" ]
 ]
diff --git a/src/irmin-pack/io/lru.ml b/src/irmin-pack/io/lru.ml
index 7e27100c5fd..8da2e4c0a51 100644
--- a/src/irmin-pack/io/lru.ml
+++ b/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))
diff --git a/src/irmin-pack/io/lru.mli b/src/irmin-pack/io/lru.mli
index a4f4298dccf..6e40fa63654 100644
--- a/src/irmin-pack/io/lru.mli
+++ b/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
diff --git a/src/irmin/dune b/src/irmin/dune
index 2e031731df4..ed84dccfcc6 100644
--- a/src/irmin/dune
+++ b/src/irmin/dune
@@ -11,6 +11,8 @@
   logs
   logs.fmt
   eio
+  kcas
+  kcas_data
   mtime
   ocamlgraph
   uri
diff --git a/src/irmin/lru.ml b/src/irmin/lru.ml
index 4ae221f2512..40b3c036cda 100644
--- a/src/irmin/lru.ml
+++ b/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;
     cap : cap;
-    mutable w : int;
+    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
diff --git a/src/irmin/lru.mli b/src/irmin/lru.mli
index f3ea5736eb5..e3012b68ded 100644
--- a/src/irmin/lru.mli
+++ b/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

From 4e42315a1365cb7cd0eb953ac35f501305b2116f Mon Sep 17 00:00:00 2001
From: gwenaelle <charles-edouard.lecat@epitech.eu>
Date: Fri, 23 Feb 2024 15:29:47 +0100
Subject: [PATCH 2/4] irmin-pack: Change hash tables to kcas

---
 src/irmin-pack/io/atomic_write.ml | 46 +++++++------------------------
 src/irmin-pack/io/pack_store.ml   | 36 ++++++------------------
 2 files changed, 18 insertions(+), 64 deletions(-)

diff --git a/src/irmin-pack/io/atomic_write.ml b/src/irmin-pack/io/atomic_write.ml
index fd613893f4f..a430955fe8c 100644
--- a/src/irmin-pack/io/atomic_write.ml
+++ b/src/irmin-pack/io/atomic_write.ml
@@ -1,45 +1,19 @@
 open Import
 include Irmin_pack.Atomic_write
 
-module UnsafeTbl (K : Irmin.Type.S) = Hashtbl.Make (struct
-  type t = K.t [@@deriving irmin ~short_hash ~equal]
-
-  let hash = short_hash ?seed:None
-end)
-
-(** Safe but might be incredibly slow. *)
 module Table (K : Irmin.Type.S) = struct
-  module Unsafe = UnsafeTbl (K)
-
-  type 'a t = { lock : Eio.Mutex.t; data : 'a Unsafe.t }
-
-  let create n =
-    let lock = Eio.Mutex.create () in
-    let data = Unsafe.create n in
-    { lock; data }
-
-  let add { lock; data } k v =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.add data k v
-
-  let mem { lock; data } k =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.mem data k
-
-  let find_opt { lock; data } k =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.find_opt data k
-
-  let find t k = match find_opt t k with Some v -> v | None -> raise Not_found
+  module K = (struct
+    include K
 
-  let replace { lock; data } k v =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.replace data k v
+    type t = K.t [@@deriving irmin ~short_hash ~equal]
 
-  let remove { lock; data } k =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.remove data k
+    let hash = short_hash ?seed:None
+    let equal = Irmin.Type.(unstage (equal K.t))
+  end)
 
-  let reset { lock; data } =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.reset data
+  include Kcas_data.Hashtbl
 
-  let fold f { lock; data } init =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.fold f data init
+  let create min_buckets = create ~hashed_type:(module K) ~min_buckets ()
 end
 
 module Make_persistent (Io : Io_intf.S) (K : Irmin.Type.S) (V : Value.S) =
@@ -53,8 +27,8 @@ struct
   type watch = W.watch
 
   type t = {
-    index : int63 Tbl.t;
-    cache : V.t Tbl.t;
+    index : (K.t, int63) Tbl.t;
+    cache : (K.t, V.t) Tbl.t;
     block : Io.t;
     mutable block_size : int63;
     w : W.t;
diff --git a/src/irmin-pack/io/pack_store.ml b/src/irmin-pack/io/pack_store.ml
index 8563a87ae41..acfa41d3fc7 100644
--- a/src/irmin-pack/io/pack_store.ml
+++ b/src/irmin-pack/io/pack_store.ml
@@ -24,37 +24,17 @@ exception Dangling_hash
 let invalid_read fmt = Fmt.kstr (fun s -> raise (Invalid_read s)) fmt
 let corrupted_store fmt = Fmt.kstr (fun s -> raise (Corrupted_store s)) fmt
 
-module UnsafeTbl (K : Irmin.Hash.S) = Hashtbl.Make (struct
-  type t = K.t
-
-  let hash = K.short_hash
-  let equal = Irmin.Type.(unstage (equal K.t))
-end)
-
-(** Safe but might be incredibly slow. *)
 module Table (K : Irmin.Hash.S) = struct
-  module Unsafe = UnsafeTbl (K)
-
-  type 'a t = { lock : Eio.Mutex.t; data : 'a Unsafe.t }
-
-  let create n =
-    let lock = Eio.Mutex.create () in
-    let data = Unsafe.create n in
-    { lock; data }
-
-  let add { lock; data } k v =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.add data k v
-
-  let mem { lock; data } k =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.mem data k
+  module K = (struct
+    include K
 
-  let find_opt { lock; data } k =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.find_opt data k
+    let hash = short_hash
+    let equal = Irmin.Type.(unstage (equal K.t))
+  end)
 
-  let find t k = match find_opt t k with Some v -> v | None -> raise Not_found
+  include Kcas_data.Hashtbl
 
-  let clear { lock; data } =
-    Eio.Mutex.use_rw ~protect:true lock @@ fun () -> Unsafe.clear data
+  let create min_buckets = create ~hashed_type:(module K) ~min_buckets ()
 end
 
 module Make_without_close_checks
@@ -86,7 +66,7 @@ struct
 
   type 'a t = {
     lru : Lru.t;
-    staging : Val.t Tbl.t;
+    staging : (Hash.t, Val.t) Tbl.t;
     indexing_strategy : Irmin_pack.Indexing_strategy.t;
     fm : Fm.t;
     dict : Dict.t;

From 9c7be8d171a5d59ca7ec7bb69e2abf8ddd444582 Mon Sep 17 00:00:00 2001
From: gwenaelle <charles-edouard.lecat@epitech.eu>
Date: Fri, 23 Feb 2024 16:17:14 +0100
Subject: [PATCH 3/4] irmin: Bring iter back

---
 src/irmin-pack/io/lru.ml  | 2 ++
 src/irmin-pack/io/lru.mli | 1 +
 src/irmin/lru.ml          | 2 ++
 src/irmin/lru.mli         | 1 +
 4 files changed, 6 insertions(+)

diff --git a/src/irmin-pack/io/lru.ml b/src/irmin-pack/io/lru.ml
index 8da2e4c0a51..7e27100c5fd 100644
--- a/src/irmin-pack/io/lru.ml
+++ b/src/irmin-pack/io/lru.ml
@@ -87,3 +87,5 @@ 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))
diff --git a/src/irmin-pack/io/lru.mli b/src/irmin-pack/io/lru.mli
index 6e40fa63654..a4f4298dccf 100644
--- a/src/irmin-pack/io/lru.mli
+++ b/src/irmin-pack/io/lru.mli
@@ -36,3 +36,4 @@ 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
diff --git a/src/irmin/lru.ml b/src/irmin/lru.ml
index 40b3c036cda..bd63a1477ff 100644
--- a/src/irmin/lru.ml
+++ b/src/irmin/lru.ml
@@ -160,4 +160,6 @@ module Make (H : Hashtbl.HashedType) = struct
     in
     Xt.commit { tx }
 
+  let iter t f =
+    HT.iter (fun k q -> f k (snd q.Q.value)) t.ht
 end
diff --git a/src/irmin/lru.mli b/src/irmin/lru.mli
index e3012b68ded..f3ea5736eb5 100644
--- a/src/irmin/lru.mli
+++ b/src/irmin/lru.mli
@@ -23,5 +23,6 @@ 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

From 8c3de90cfd5490a9752b9a927bbd4ca63b1f62fb Mon Sep 17 00:00:00 2001
From: gwenaelle <charles-edouard.lecat@epitech.eu>
Date: Mon, 26 Feb 2024 11:25:30 +0100
Subject: [PATCH 4/4] Fmt

---
 src/irmin-pack/io/atomic_write.ml | 4 ++--
 src/irmin-pack/io/pack_store.ml   | 4 ++--
 src/irmin/lru.ml                  | 6 ++----
 3 files changed, 6 insertions(+), 8 deletions(-)

diff --git a/src/irmin-pack/io/atomic_write.ml b/src/irmin-pack/io/atomic_write.ml
index a430955fe8c..b309d1570eb 100644
--- a/src/irmin-pack/io/atomic_write.ml
+++ b/src/irmin-pack/io/atomic_write.ml
@@ -2,14 +2,14 @@ open Import
 include Irmin_pack.Atomic_write
 
 module Table (K : Irmin.Type.S) = struct
-  module K = (struct
+  module K = struct
     include K
 
     type t = K.t [@@deriving irmin ~short_hash ~equal]
 
     let hash = short_hash ?seed:None
     let equal = Irmin.Type.(unstage (equal K.t))
-  end)
+  end
 
   include Kcas_data.Hashtbl
 
diff --git a/src/irmin-pack/io/pack_store.ml b/src/irmin-pack/io/pack_store.ml
index acfa41d3fc7..bb80bbc2c08 100644
--- a/src/irmin-pack/io/pack_store.ml
+++ b/src/irmin-pack/io/pack_store.ml
@@ -25,12 +25,12 @@ let invalid_read fmt = Fmt.kstr (fun s -> raise (Invalid_read s)) fmt
 let corrupted_store fmt = Fmt.kstr (fun s -> raise (Corrupted_store s)) fmt
 
 module Table (K : Irmin.Hash.S) = struct
-  module K = (struct
+  module K = struct
     include K
 
     let hash = short_hash
     let equal = Irmin.Type.(unstage (equal K.t))
-  end)
+  end
 
   include Kcas_data.Hashtbl
 
diff --git a/src/irmin/lru.ml b/src/irmin/lru.ml
index bd63a1477ff..4938c6f2f06 100644
--- a/src/irmin/lru.ml
+++ b/src/irmin/lru.ml
@@ -137,8 +137,7 @@ module Make (H : Hashtbl.HashedType) = struct
       | Some v ->
           promote ~xt t v;
           snd v.value
-      | None ->
-          raise Not_found
+      | None -> raise Not_found
     in
     Xt.commit { tx }
 
@@ -160,6 +159,5 @@ module Make (H : Hashtbl.HashedType) = struct
     in
     Xt.commit { tx }
 
-  let iter t f =
-    HT.iter (fun k q -> f k (snd q.Q.value)) t.ht
+  let iter t f = HT.iter (fun k q -> f k (snd q.Q.value)) t.ht
 end