irmin-pack: clear LRU when reloading RO

In order to clear the LRU when a reload is called, this is a general
refactor to move clearing of the LRU to happen when the prefix is
reopened. This covers both a swap after a GC and when reload is called
for a RO instance.

Author: metanivek

src/irmin-pack/unix/file_manager.ml

@@ -46,6 +46,7 @@ struct
     mutable mapping : Mapping_file.t option;
     index : Index.t;
     mutable dict_consumers : after_reload_consumer list;
+    mutable prefix_consumers : after_reload_consumer list;
     mutable suffix_consumers : after_flush_consumer list;
     indexing_strategy : Irmin_pack.Indexing_strategy.t;
     use_fsync : bool;
@@ -71,6 +72,9 @@ struct
   let register_dict_consumer t ~after_reload =
     t.dict_consumers <- { after_reload } :: t.dict_consumers
 
+  let register_prefix_consumer t ~after_reload =
+    t.prefix_consumers <- { after_reload } :: t.prefix_consumers
+
   let register_suffix_consumer t ~after_flush =
     t.suffix_consumers <- { after_flush } :: t.suffix_consumers
 
@@ -84,6 +88,12 @@ struct
         assert false
     | Gced x -> x.generation
 
+  let notify_reload_consumers consumers =
+    List.fold_left
+      (fun acc { after_reload } -> Result.bind acc after_reload)
+      (Ok ()) consumers
+    |> Result.map_error (fun err -> (err : Errs.t :> [> Errs.t ]))
+
   (** Flush stages *************************************************************
 
       The irmin-pack files are only mutated during calls to one of the 3
@@ -216,6 +226,7 @@ struct
     in
     let prefix0 = t.prefix in
     t.prefix <- Some prefix1;
+    let* () = notify_reload_consumers t.prefix_consumers in
     match prefix0 with None -> Ok () | Some io -> Prefix.close io
 
   let open_mapping ~root ~generation =
@@ -379,6 +390,7 @@ struct
         use_fsync;
         index;
         dict_consumers = [];
+        prefix_consumers = [];
         suffix_consumers = [];
         indexing_strategy;
         root;
@@ -435,16 +447,7 @@ struct
       (match hook with Some h -> h `After_suffix | None -> ());
       let* () = Dict.refresh_end_poff t.dict pl1.dict_end_poff in
       (* Step 5. Notify the dict consumers that they must reload *)
-      let* () =
-        let res =
-          List.fold_left
-            (fun acc { after_reload } -> Result.bind acc after_reload)
-            (Ok ()) t.dict_consumers
-        in
-        (* The following dirty trick casts the result from
-           [read_error] to [ [>read_error] ]. *)
-        match res with Ok () -> Ok () | Error (#Errs.t as e) -> Error e
-      in
+      let* () = notify_reload_consumers t.dict_consumers in
       Ok ()
 
   (* File creation ********************************************************** *)
@@ -680,6 +683,7 @@ struct
         indexing_strategy;
         index;
         dict_consumers = [];
+        prefix_consumers = [];
         suffix_consumers = [];
         root;
       }

src/irmin-pack/unix/file_manager_intf.ml

@@ -220,6 +220,9 @@ module type S = sig
   val register_dict_consumer :
     t -> after_reload:(unit -> (unit, Errs.t) result) -> unit
 
+  val register_prefix_consumer :
+    t -> after_reload:(unit -> (unit, Errs.t) result) -> unit
+
   val register_suffix_consumer : t -> after_flush:(unit -> unit) -> unit
 
   type version_error :=

src/irmin-pack/unix/gc.ml

@@ -108,8 +108,7 @@ module Make (Args : Gc_args.S) = struct
       latest_gc_target_offset;
     }
 
-  let swap_and_purge t removable_chunk_num suffix_params =
-    let open Result_syntax in
+  let swap t removable_chunk_num suffix_params =
     let { generation; latest_gc_target_offset; _ } = t in
     let Worker.
           {
@@ -128,19 +127,8 @@ module Make (Args : Gc_args.S) = struct
        is guaranteed by the GC process. *)
     assert (chunk_num >= 1);
 
-    let* () =
-      Fm.swap t.fm ~generation ~suffix_start_offset ~chunk_start_idx ~chunk_num
-        ~suffix_dead_bytes ~latest_gc_target_offset
-    in
-
-    (* No need to purge dict here, as it is global to the store. *)
-    (* No need to purge index here. It is global too, but some hashes may
-       not point to valid offsets anymore. Pack_store will just say that
-       such keys are not member of the store. *)
-    Contents_store.purge_lru t.contents;
-    Node_store.purge_lru t.node;
-    Commit_store.purge_lru t.commit;
-    Ok ()
+    Fm.swap t.fm ~generation ~suffix_start_offset ~chunk_start_idx ~chunk_num
+      ~suffix_dead_bytes ~latest_gc_target_offset
 
   let unlink_all { root; generation; _ } removable_chunk_idxs =
     let result =
@@ -242,9 +230,7 @@ module Make (Args : Gc_args.S) = struct
                     "swap and purge"
                 in
                 let* () =
-                  swap_and_purge t
-                    (List.length removable_chunk_idxs)
-                    suffix_params
+                  swap t (List.length removable_chunk_idxs) suffix_params
                 in
                 let partial_stats =
                   Gc_stats.Main.finish_current_step partial_stats "unlink"

src/irmin-pack/unix/pack_store.ml

@@ -116,6 +116,7 @@ struct
     in
     let lru = Lru.create ~weight lru_size in
     Fm.register_suffix_consumer fm ~after_flush:(fun () -> Tbl.clear staging);
+    Fm.register_prefix_consumer fm ~after_reload:(fun () -> Ok (Lru.clear lru));
     { lru; staging; indexing_strategy; fm; dict; dispatcher }
 
   module Entry_prefix = struct

test/irmin-pack/test_gc.ml

@@ -162,6 +162,12 @@ end
 
 include Store
 
+let lru_hits () =
+  let open Irmin_pack_unix.Stats in
+  let { pack_store; _ } = get () in
+  let pack_store_t = Pack_store.export pack_store in
+  pack_store_t.from_lru
+
 (** Wrappers for testing. *)
 let check_blob tree key expected =
   let+ got = S.Tree.find tree key in
@@ -639,6 +645,27 @@ module Gc = struct
     check_stats (Option.get stats);
     S.Repo.close t.repo
 
+  (** Check that a GC clears the LRU *)
+  let gc_clears_lru () =
+    let* t = init ~lru_size:100 () in
+    (* Rreate some commits *)
+    let* t, c1 = commit_1 t in
+    let* t = checkout_exn t c1 in
+    let* t, c2 = commit_2 t in
+    let* t = checkout_exn t c2 in
+    let* t, c3 = commit_3 t in
+    (* Read some data *)
+    let* () = check_2 t c2 in
+    let* () = check_3 t c3 in
+    (* GC *)
+    let count_before_gc = lru_hits () in
+    let* () = start_gc t c2 in
+    let* () = finalise_gc t in
+    (* Read data again *)
+    let* () = check_3 t c3 in
+    Alcotest.(check int) "GC does clear LRU" count_before_gc (lru_hits ());
+    S.Repo.close t.repo
+
   let tests =
     [
       tc "Test one gc" one_gc;
@@ -657,6 +684,7 @@ module Gc = struct
       tc "Test gc on similar commits" gc_similar_commits;
       tc "Test oldest live commit" latest_gc_target;
       tc "Test worker gc stats" gc_stats;
+      tc "Test gc_clears_lru" gc_clears_lru;
     ]
 end
 
@@ -799,6 +827,39 @@ module Concurrent_gc = struct
     let* () = S.Repo.close t.repo in
     S.Repo.close ro_t.repo
 
+  (** Check that calling reload in RO will clear the LRU only after GC. *)
+  let ro_reload_clears_lru () =
+    let* rw_t = init () in
+    let* ro_t =
+      init ~lru_size:100 ~readonly:true ~fresh:false ~root:rw_t.root ()
+    in
+    (* Create some commits in RW *)
+    let* rw_t, c1 = commit_1 rw_t in
+    let* rw_t = checkout_exn rw_t c1 in
+    let* rw_t, c2 = commit_2 rw_t in
+    let* rw_t = checkout_exn rw_t c2 in
+    let* rw_t, c3 = commit_3 rw_t in
+    (* Reload RO to get all changes, and read some data *)
+    S.reload ro_t.repo;
+    let* () = check_3 ro_t c3 in
+    let count_before_reload = lru_hits () in
+    (* Reload should not clear LRU *)
+    S.reload ro_t.repo;
+    let* () = check_3 ro_t c3 in
+    Alcotest.(check bool)
+      "reload does not clear LRU" true
+      (count_before_reload < lru_hits ());
+    (* GC *)
+    let count_before_gc = lru_hits () in
+    let* () = start_gc rw_t c2 in
+    let* () = finalise_gc rw_t in
+    (* Reload RO to get changes and clear LRU, and read some data *)
+    S.reload ro_t.repo;
+    let* () = check_3 ro_t c3 in
+    Alcotest.(check int) "reload does clear LRU" count_before_gc (lru_hits ());
+    let* () = S.Repo.close rw_t.repo in
+    S.Repo.close ro_t.repo
+
   (** Check that calling close during a gc kills the gc without finalising it.
       On reopening the store, the following gc works fine. *)
   let close_running_gc () =
@@ -901,6 +962,7 @@ module Concurrent_gc = struct
       tc "Test ro_find_running_gc" ro_find_running_gc;
       tc "Test ro_add_running_gc" ro_add_running_gc;
       tc "Test ro_reload_after_second_gc" ro_reload_after_second_gc;
+      tc "Test ro_reload_clears_lru" ro_reload_clears_lru;
       tc "Test close_running_gc" close_running_gc;
       tc "Test skip gc" test_skip;
       tc "Test kill gc and finalise" test_kill_gc_and_finalise;