Merge pull request #2106 from icristescu/backport_fix

Fix gc bugs when commits share the same tree

CHANGES.md

@@ -31,6 +31,8 @@
 
 - **irmin-pack**
   - Fix data race in RO instances when reading control file (#2100, @Ngoguey42)
+  - Fix bugs in gc related to commits that share the same tree. (#2106,
+    @icristescu)
 
 ### Fixed
 

src/irmin-pack/unix/dispatcher.ml

@@ -166,17 +166,15 @@ module Make (Fm : File_manager.S with module Io = Io.Unix) :
         let poff = Suffix_arithmetic.poff_of_off t off in
         { poff; len; location = Suffix }
 
-    let v_in_prefix_exn t ~off ~len =
-      let poff =
-        Prefix_arithmetic.poff_of_entry_exn (get_mapping t) ~off ~len
-      in
+    let v_in_prefix_exn mapping ~off ~len =
+      let poff = Prefix_arithmetic.poff_of_entry_exn mapping ~off ~len in
       { poff; len; location = Prefix }
 
     let v_exn t ~off ~len =
       let open Int63.Syntax in
       let suffix_start_offset = suffix_start_offset t in
       if off >= suffix_start_offset then v_in_suffix_exn t ~off ~len
-      else v_in_prefix_exn t ~off ~len
+      else v_in_prefix_exn (get_mapping t) ~off ~len
 
     let v_range_in_suffix_exn t ~off ~min_len ~max_len =
       let min_len = Int63.of_int min_len in
@@ -238,12 +236,13 @@ module Make (Fm : File_manager.S with module Io = Io.Unix) :
       let accessor =
         Accessor.v_exn t ~off:suffix_start_offset ~len:read_in_suffix
       in
-      read_exn t accessor buf;
+      read_exn t accessor buf_suffix;
       Bytes.blit buf_suffix 0 buf read_in_prefix read_in_suffix)
     else read_exn t (Accessor.v_exn t ~off ~len) buf
 
   let create_accessor_exn = Accessor.v_exn
   let create_accessor_from_range_exn = Accessor.v_range_exn
+  let create_accessor_to_prefix_exn = Accessor.v_in_prefix_exn
 
   let shrink_accessor_exn a ~new_len =
     if new_len > a.len then failwith "shrink_accessor_exn to larger accessor";

src/irmin-pack/unix/dispatcher_intf.ml

@@ -21,8 +21,10 @@ module type S = sig
   module Mapping_file : Mapping_file.S with module Io = Fm.Io
 
   type t
+  type location = private Prefix | Suffix [@@deriving irmin]
 
-  type accessor
+  type accessor = private { poff : int63; len : int; location : location }
+  [@@deriving irmin]
   (** An [accessor] designates a valid readable area in one of the pack files.
 
       Accessors are meant to be used from within the [Irmin_pack_unix]
@@ -84,6 +86,11 @@ module type S = sig
   val read_in_prefix_and_suffix_exn : t -> off:int63 -> len:int -> bytes -> unit
   (** Simlar to [read_exn] but if [off + len] is greater than the end of the
       prefix, it will read the remaining in the prefix. *)
+
+  val create_accessor_to_prefix_exn :
+    Mapping_file.t -> off:int63 -> len:int -> accessor
+  (** [create_accessor_to_prefix_exn mapping ~off ~len] returns an accessor for
+      the prefix file associated with [mapping]. *)
 end
 
 module type Sigs = sig

src/irmin-pack/unix/gc.ml

@@ -347,7 +347,7 @@ module Worker = struct
   module Make (Args : Args) : S with module Args := Args = struct
     open Args
     module Io = Fm.Io
-    module Mapping_file = Fm.Mapping_file
+    module Mapping_file = Dispatcher.Mapping_file
 
     module Ao = struct
       include Append_only_file.Make (Fm.Io) (Errs)
@@ -441,16 +441,15 @@ module Worker = struct
       in
       let buffer = Bytes.create len in
       read_exn ~off ~len buffer;
-      let entry = Mapping_file.find_nearest_leq mapping off in
-      match entry with
-      | None -> assert false
-      | Some { poff; _ } ->
-          Bytes.set buffer Hash.hash_size magic_parent;
-          (* Bytes.unsafe_to_string usage: We assume read_exn returns unique ownership of buffer
-             to this function. Then at the call to Bytes.unsafe_to_string we give up unique
-             ownership to buffer (we do not modify it thereafter) in return for ownership of the
-             resulting string, which we pass to write_exn. This usage is safe. *)
-          write_exn ~off:poff ~len (Bytes.unsafe_to_string buffer)
+      let accessor =
+        Dispatcher.create_accessor_to_prefix_exn mapping ~off ~len
+      in
+      Bytes.set buffer Hash.hash_size magic_parent;
+      (* Bytes.unsafe_to_string usage: We assume read_exn returns unique ownership of buffer
+         to this function. Then at the call to Bytes.unsafe_to_string we give up unique
+         ownership to buffer (we do not modify it thereafter) in return for ownership of the
+         resulting string, which we pass to write_exn. This usage is safe. *)
+      write_exn ~off:accessor.poff ~len (Bytes.unsafe_to_string buffer)
 
     let create_new_suffix ~root ~generation =
       let path = Irmin_pack.Layout.V3.suffix ~root ~generation in

test/irmin-pack/test_gc.ml

@@ -64,7 +64,7 @@ module Store = struct
     (* consider `Idle as success because gc can finalise during commit as well *)
     | `Idle | `Finalised _ -> Lwt.return_unit
 
-  let commit t =
+  let commit ?(info = info) t =
     let parents = List.map S.Commit.key t.parents in
     let+ h = S.Commit.v t.repo ~info ~parents t.tree in
     S.Tree.clear t.tree;
@@ -139,6 +139,13 @@ module Store = struct
     let* t = del t [ "a"; "c" ] in
     let+ h = commit t in
     (t, h)
+
+  let commit_1_different_author t =
+    let info = S.Info.v ~author:"someone" Int64.zero in
+    let* t = set t [ "a"; "b" ] "Novembre" in
+    let* t = set t [ "a"; "c" ] "Juin" in
+    let+ h = commit ~info t in
+    (t, h)
 end
 
 include Store
@@ -548,6 +555,18 @@ module Gc = struct
     let* () = check_3 t c3 in
     S.Repo.close t.repo
 
+  let gc_similar_commits () =
+    let* t = init () in
+    let* t, c1 = commit_1 t in
+    let* () = start_gc t c1 in
+    let* () = finalise_gc t in
+    let* t = checkout_exn t c1 in
+    let* t, c1_again = commit_1_different_author t in
+    let* () = start_gc t c1_again in
+    let* () = finalise_gc t in
+    let* () = check_1 t c1_again in
+    S.Repo.close t.repo
+
   let tests =
     [
       tc "Test one gc" one_gc;
@@ -563,6 +582,7 @@ module Gc = struct
       tc "Test lru" gc_lru;
       tc "Test gc during batch" gc_during_batch;
       tc "Test add back gced commit" add_back_gced_commit;
+      tc "Test gc on similar commits" gc_similar_commits;
     ]
 end