Merge pull request #2261 from metanivek/3.7.2-changes

CHANGES.md

@@ -20,6 +20,16 @@
 - **irmin-cli**
   - Changed `--store irf` to `--store fs` to align the CLI with what is
     published on the Irmin website (#2243, @wyn)
+
+## 3.7.2 (2023-06-16)
+
+### Fixed
+
+- **irmin**
+  - Fix performance issue in `Tree.length` (#2258, @art-w)
+
+- **irmin-pack**
+  - Fix snapshot export when using lower layer (#2257, @metanivek)
 
 ## 3.7.1 (2023-05-24)
 

src/irmin-pack/unix/gc.ml

@@ -42,8 +42,8 @@ module Make (Args : Gc_args.S) = struct
     latest_gc_target_offset : int63;
   }
 
-  let v ~root ~lower_root ~new_files_path ~generation ~unlink ~dispatcher ~fm
-      ~contents ~node ~commit commit_key =
+  let v ~root ~lower_root ~output ~generation ~unlink ~dispatcher ~fm ~contents
+      ~node ~commit commit_key =
     let open Result_syntax in
     let new_suffix_start_offset, latest_gc_target_offset =
       let state : _ Pack_key.state = Pack_key.inspect commit_key in
@@ -56,10 +56,11 @@ module Make (Args : Gc_args.S) = struct
           assert false
     in
     let status = Fm.control fm |> Fm.Control.payload |> fun p -> p.status in
-    (* Ensure we are calling GC on a commit strictly newer than last GC commit *)
+    (* Ensure we are calling GC on a commit strictly newer than last GC commit
+       Only checking when the output is the root (it is not a snapshot export) *)
     let* () =
-      match status with
-      | Gced previous
+      match (output, status) with
+      | `Root, Gced previous
         when Int63.Syntax.(
                previous.latest_gc_target_offset >= latest_gc_target_offset) ->
           Error
@@ -69,6 +70,9 @@ module Make (Args : Gc_args.S) = struct
                  previous.latest_gc_target_offset))
       | _ -> Ok ()
     in
+    let new_files_path =
+      match output with `Root -> root | `External path -> path
+    in
     (* Since we can call GC on commits in the lower, ensure we do not provide a
        [new_suffix_start_offset] that is older than our current starting offset. *)
     let new_suffix_start_offset =

src/irmin-pack/unix/gc.mli

@@ -26,7 +26,7 @@ module Make (Args : Gc_args.S) : sig
   val v :
     root:string ->
     lower_root:string option ->
-    new_files_path:string ->
+    output:[ `External of string | `Root ] ->
     generation:int ->
     unlink:bool ->
     dispatcher:Args.Dispatcher.t ->

src/irmin-pack/unix/store.ml

@@ -240,8 +240,7 @@ module Maker (Config : Conf.S) = struct
                         (Irmin.Type.to_string XKey.t key))
                 | Some (k, _kind) -> Ok k)
 
-          let start ~unlink ~use_auto_finalisation ~new_files_path t commit_key
-              =
+          let start ~unlink ~use_auto_finalisation ~output t commit_key =
             let open Result_syntax in
             [%log.info "GC: Starting on %a" pp_key commit_key];
             let* () =
@@ -260,21 +259,20 @@ module Maker (Config : Conf.S) = struct
             let* gc =
               Gc.v ~root ~lower_root ~generation:next_generation ~unlink
                 ~dispatcher:t.dispatcher ~fm:t.fm ~contents:t.contents
-                ~node:t.node ~commit:t.commit ~new_files_path commit_key
+                ~node:t.node ~commit:t.commit ~output commit_key
             in
             t.running_gc <- Some { gc; use_auto_finalisation };
             Ok ()
 
-          let start_exn ?(unlink = true) ~use_auto_finalisation ~new_files_path
-              t commit_key =
+          let start_exn ?(unlink = true) ?(output = `Root)
+              ~use_auto_finalisation t commit_key =
             match t.running_gc with
             | Some _ ->
                 [%log.info "Repo is alreadying running GC. Skipping."];
                 Lwt.return false
             | None -> (
                 let result =
-                  start ~unlink ~use_auto_finalisation ~new_files_path t
-                    commit_key
+                  start ~unlink ~use_auto_finalisation ~output t commit_key
                 in
                 match result with
                 | Ok _ -> Lwt.return true
@@ -353,7 +351,7 @@ module Maker (Config : Conf.S) = struct
             (* The GC action here does not matter, since we'll not fully
                finalise it *)
             let* launched =
-              start_exn ~use_auto_finalisation:false ~new_files_path:path t
+              start_exn ~use_auto_finalisation:false ~output:(`External path) t
                 commit_key
             in
             let () =
@@ -622,16 +620,13 @@ module Maker (Config : Conf.S) = struct
       let finalise_exn = X.Repo.Gc.finalise_exn
 
       let start_exn ?unlink t =
-        let root = Irmin_pack.Conf.root t.X.Repo.config in
-        X.Repo.Gc.start_exn ?unlink ~use_auto_finalisation:false
-          ~new_files_path:root t
+        X.Repo.Gc.start_exn ?unlink ~use_auto_finalisation:false t
 
       let start repo commit_key =
-        let root = Irmin_pack.Conf.root repo.X.Repo.config in
         try
           let* started =
-            X.Repo.Gc.start_exn ~unlink:true ~use_auto_finalisation:true
-              ~new_files_path:root repo commit_key
+            X.Repo.Gc.start_exn ~unlink:true ~use_auto_finalisation:true repo
+              commit_key
           in
           Lwt.return_ok started
         with exn -> catch_errors "Start GC" exn

src/irmin/tree.ml

@@ -419,6 +419,7 @@ module Make (P : Backend.S) = struct
       mutable map : map option;
       mutable ptr : ptr_option;
       mutable findv_cache : map option;
+      mutable length : int Lazy.t option;
       env : Env.t;
     }
 
@@ -481,7 +482,7 @@ module Make (P : Backend.S) = struct
              Portable_dirty (v, m))
       |> sealv
 
-    let of_v ~env v =
+    let of_v ?length ~env v =
       let ptr, map, value =
         match v with
         | Map m -> (Ptr_none, Some m, None)
@@ -490,12 +491,15 @@ module Make (P : Backend.S) = struct
         | Value _ | Portable_dirty _ | Pruned _ -> (Ptr_none, None, None)
       in
       let findv_cache = None in
-      let info = { ptr; map; value; findv_cache; env } in
+      let info = { ptr; map; value; findv_cache; env; length } in
       { v; info }
 
     let of_map m = of_v (Map m)
     let of_key repo k = of_v (Key (repo, k))
-    let of_value ?updates repo v = of_v (Value (repo, v, updates))
+
+    let of_value ?length ?updates repo v =
+      of_v ?length (Value (repo, v, updates))
+
     let of_portable_dirty p updates = of_v (Portable_dirty (p, updates))
     let pruned h = of_v (Pruned h)
 
@@ -1120,7 +1124,7 @@ module Make (P : Backend.S) = struct
     let empty_hash = hash ~cache:false (empty ())
     let singleton k v = of_map (StepMap.singleton k v)
 
-    let length ~cache t =
+    let slow_length ~cache t =
       match
         (Scan.cascade t
            [
@@ -1150,6 +1154,14 @@ module Make (P : Backend.S) = struct
             | Pnode x -> P.Node_portable.length x |> Lwt.return)
       | Pruned h -> pruned_hash_exn "length" h
 
+    let length ~cache t =
+      match t.info.length with
+      | Some (lazy len) -> Lwt.return len
+      | None ->
+          let+ len = slow_length ~cache t in
+          t.info.length <- Some (Lazy.from_val len);
+          len
+
     let is_empty ~cache t =
       match
         (Scan.cascade t
@@ -1470,6 +1482,27 @@ module Make (P : Backend.S) = struct
       in
       aux_uniq ~path acc 0 t Lwt.return
 
+    let incremental_length t step up n updates =
+      match t.info.length with
+      | None -> None
+      | Some len ->
+          Some
+            (lazy
+              (let len = Lazy.force len in
+               let exists =
+                 match StepMap.find_opt step updates with
+                 | Some (Add _) -> true
+                 | Some Remove -> false
+                 | None -> (
+                     match P.Node.Val.find n step with
+                     | None -> false
+                     | Some _ -> true)
+               in
+               match up with
+               | Add _ when not exists -> len + 1
+               | Remove when exists -> len - 1
+               | _ -> len))
+
     let update t step up =
       let env = t.info.env in
       let of_map m =
@@ -1483,7 +1516,9 @@ module Make (P : Backend.S) = struct
       let of_value repo n updates =
         let updates' = StepMap.add step up updates in
         if updates == updates' then t
-        else of_value ~env repo n ~updates:updates'
+        else
+          let length = incremental_length t step up n updates in
+          of_value ?length ~env repo n ~updates:updates'
       in
       let of_portable n updates =
         let updates' = StepMap.add step up updates in
@@ -1623,7 +1658,8 @@ module Make (P : Backend.S) = struct
 
   let of_backend_node repo n =
     let env = Env.empty () in
-    Node.of_value ~env repo n
+    let length = lazy (P.Node.Val.length n) in
+    Node.of_value ~length ~env repo n
 
   let dump ppf = function
     | `Node n -> Fmt.pf ppf "node: %a" Node.dump n

test/irmin-pack/test_gc.ml

@@ -1470,10 +1470,32 @@ module Snapshot = struct
     let* () = check_2 t c2 in
     S.Repo.close t.repo
 
+  (* Test creating a snapshot in an archive store for a commit that is before
+     the last gc target commit (ie it is in the lower) *)
+  let snapshot_gced_commit () =
+    let lower_root = create_lower_root ~mkdir:false () in
+    let* t = init ~lower_root:(Some lower_root) () in
+    let* t, c1 = commit_1 t in
+    let* t = checkout_exn t c1 in
+    let* t, c2 = commit_2 t in
+    let* () = start_gc t c2 in
+    let* () = finalise_gc t in
+    let root_snap = Filename.concat t.root "snap" in
+    let* () = export t c1 root_snap in
+    let* () = S.Repo.close t.repo in
+    [%log.debug "open store from snapshot"];
+    let* t = init ~readonly:false ~fresh:false ~root:root_snap () in
+    let* t = checkout_exn t c1 in
+    let* t, c2 = commit_2 t in
+    let* () = check_1 t c1 in
+    let* () = check_2 t c2 in
+    S.Repo.close t.repo
+
   let tests =
     [
       tc "Import/export in rw" snapshot_rw;
       tc "Import in ro" snapshot_import_in_ro;
       tc "Export in ro" snapshot_export_in_ro;
+      tc "Snapshot gced commit" snapshot_gced_commit;
     ]
 end