suggested changes

src/irmin-pack/unix/errors.ml

@@ -71,7 +71,8 @@ type base_error =
   | `Invalid_read_of_gced_object of string
   | `Inconsistent_store
   | `Split_forbidden_during_batch
-  | `Multiple_empty_chunks ]
+  | `Multiple_empty_chunks
+  | `Cannot_run_during_gc ]
 [@@deriving irmin ~pp]
 (** [base_error] is the type of most errors that can occur in a [result], except
     for errors that have associated exceptions (see below) and backend-specific

src/irmin-pack/unix/ext.ml

@@ -248,7 +248,7 @@ module Maker (Config : Conf.S) = struct
                 cancelled
             | None -> false
 
-          let start ~unlink ~use_auto_finalisation ~path_new_files t commit_key
+          let start ~unlink ~use_auto_finalisation ~new_files_path t commit_key
               =
             let open Result_syntax in
             [%log.info "GC: Starting on %a" pp_key commit_key];
@@ -277,20 +277,20 @@ module Maker (Config : Conf.S) = struct
             let gc =
               Gc.v ~root ~generation:next_generation ~unlink
                 ~dispatcher:t.dispatcher ~fm:t.fm ~contents:t.contents
-                ~node:t.node ~commit:t.commit ~path_new_files commit_key
+                ~node:t.node ~commit:t.commit ~new_files_path commit_key
             in
             t.running_gc <- Some { gc; use_auto_finalisation };
             Ok ()
 
-          let start_exn ?(unlink = true) ~use_auto_finalisation ~path_new_files
+          let start_exn ?(unlink = true) ~use_auto_finalisation ~new_files_path
               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 ~path_new_files t
+                  start ~unlink ~use_auto_finalisation ~new_files_path t
                     commit_key
                 in
                 match result with
@@ -357,20 +357,19 @@ module Maker (Config : Conf.S) = struct
 
           let create_one_commit_store t commit_key path =
             let () = Io.mkdir path |> Errs.raise_if_error in
-            let* _launched =
-              start_exn ~use_auto_finalisation:false ~path_new_files:path t
+            let* launched =
+              start_exn ~use_auto_finalisation:false ~new_files_path:path t
                 commit_key
             in
-            let generation = File_manager.generation t.fm + 1 in
+            let () =
+              if not launched then Errs.raise_error `Cannot_run_during_gc
+            in
             let* () =
               match t.running_gc with
               | None -> assert false
-              | Some { gc; _ } -> Gc.finalise_without_swap gc
-            in
-            let () =
-              File_manager.create_one_commit_store t.config ~generation
-                ~new_store_root:path commit_key
-              |> Errs.raise_if_error
+              | Some { gc; _ } ->
+                  Gc.finalise_and_create_one_commit_store ~new_store_root:path
+                    t.config gc commit_key
             in
             let branch_path = Irmin_pack.Layout.V4.branch ~root:path in
             let* branch_store =
@@ -600,14 +599,14 @@ module Maker (Config : Conf.S) = struct
       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
-          ~path_new_files:root t
+          ~new_files_path:root 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
-              ~path_new_files:root repo commit_key
+              ~new_files_path:root repo commit_key
           in
           Lwt.return_ok started
         with exn -> catch_errors "Start GC" exn

src/irmin-pack/unix/file_manager.ml

@@ -799,24 +799,13 @@ struct
     cleanup ~root ~generation ~chunk_start_idx ~chunk_num
 
   let create_one_commit_store config ~generation ~new_store_root
-      latest_gc_target =
+      ~latest_gc_target_offset ~suffix_start_offset commit_key =
     let open Result_syntax in
     let root = Irmin_pack.Conf.root config in
-    let commit_key, latest_gc_target_offset, suffix_start_offset =
-      match Pack_key.inspect latest_gc_target with
-      | Direct { offset; length; _ } as commit_key ->
-          let suffix_start_offset =
-            Int63.Syntax.(offset + Int63.of_int length)
-          in
-          (commit_key, offset, suffix_start_offset)
-      | Indexed _ ->
-          (* The caller of this function lifted the key to a direct one. *)
-          assert false
-    in
     (* Step 1. Copy the dict *)
     let src_dict = Irmin_pack.Layout.V4.dict ~root in
     let dst_dict = Irmin_pack.Layout.V4.dict ~root:new_store_root in
-    let* () = Io.cp_file ~src:src_dict ~dst:dst_dict in
+    let* () = Io.copy_file ~src:src_dict ~dst:dst_dict in
     (* Step 2. Create an empty suffix and close it. *)
     let* suffix =
       Suffix.create_rw ~root:new_store_root ~overwrite:false
@@ -858,8 +847,8 @@ struct
     in
     (* Step 5. Add the commit to the index, close the index. *)
     let () =
-      match commit_key with
-      | Direct { hash; offset; length } ->
+      match Pack_key.inspect commit_key with
+      | Pack_key.Direct { hash; offset; length } ->
           Index.add index hash (offset, length, Pack_value.Kind.Commit_v2)
       | Indexed _ -> assert false
     in

src/irmin-pack/unix/file_manager_intf.ml

@@ -261,8 +261,14 @@ module type S = sig
     Irmin.Backend.Conf.t ->
     generation:int ->
     new_store_root:string ->
+    latest_gc_target_offset:int63 ->
+    suffix_start_offset:int63 ->
     Index.key Pack_key.t ->
     (unit, [> open_rw_error | close_error ]) result
+  (** [create_one_commit_store conf generation new_store_root key] is called
+      when creating a new store at [new_store_root] from the existing one,
+      containing only one commit, specified by the [key]. Ths new store will use
+      configuration options from [conf] and set to [generation]. *)
 end
 
 module type Sigs = sig

src/irmin-pack/unix/gc.ml

@@ -42,7 +42,7 @@ module Make (Args : Gc_args.S) = struct
     latest_gc_target_offset : int63;
   }
 
-  let v ~root ~path_new_files ~generation ~unlink ~dispatcher ~fm ~contents
+  let v ~root ~new_files_path ~generation ~unlink ~dispatcher ~fm ~contents
       ~node ~commit commit_key =
     let new_suffix_start_offset, latest_gc_target_offset =
       let state : _ Pack_key.state = Pack_key.inspect commit_key in
@@ -84,7 +84,7 @@ module Make (Args : Gc_args.S) = struct
     let task =
       Async.async (fun () ->
           Worker.run_and_output_result root commit_key new_suffix_start_offset
-            ~generation ~path_new_files)
+            ~generation ~new_files_path)
     in
     let partial_stats =
       Gc_stats.Main.finish_current_step partial_stats "before finalise"
@@ -282,10 +282,17 @@ module Make (Args : Gc_args.S) = struct
           | `Running -> Lwt.return_ok `Running
           | #Async.outcome as status -> go status)
 
-  let finalise_without_swap t =
+  let finalise_and_create_one_commit_store ~new_store_root config t commit_key =
     let* status = Async.await t.task in
     match status with
-    | `Success -> Lwt.return_unit
+    | `Success ->
+        let () =
+          Fm.create_one_commit_store config ~generation:t.generation
+            ~new_store_root ~latest_gc_target_offset:t.latest_gc_target_offset
+            ~suffix_start_offset:t.new_suffix_start_offset commit_key
+          |> Errs.raise_if_error
+        in
+        Lwt.return_unit
     | _ ->
         let gc_output = read_gc_output ~root:t.root ~generation:t.generation in
         let r = gc_errors status gc_output |> Errs.raise_if_error in

src/irmin-pack/unix/gc.mli

@@ -25,7 +25,7 @@ module Make (Args : Gc_args.S) : sig
 
   val v :
     root:string ->
-    path_new_files:string ->
+    new_files_path:string ->
     generation:int ->
     unlink:bool ->
     dispatcher:Args.Dispatcher.t ->
@@ -52,6 +52,8 @@ module Make (Args : Gc_args.S) : sig
       finalises. *)
 
   val cancel : t -> bool
-  val finalise_without_swap : t -> unit Lwt.t
+
+  val finalise_and_create_one_commit_store :
+    new_store_root:string -> Irmin.Backend.Conf.t -> t -> Args.key -> unit Lwt.t
 end
 with module Args = Args

src/irmin-pack/unix/gc_args.ml

@@ -17,13 +17,14 @@
 open! Import
 
 module type S = sig
-  module Fm : File_manager.S with module Io = Io.Unix
+  type hash
+
+  module Fm : File_manager.S with module Io = Io.Unix and type Index.key = hash
   module Async : Async.S
   module Dict : Dict.S with module Fm = Fm
   module Errs : Io_errors.S with module Io = Fm.Io
   module Dispatcher : Dispatcher.S with module Fm = Fm
 
-  type hash
   type key = hash Pack_key.t [@@deriving irmin]
 
   module Hash : sig

src/irmin-pack/unix/gc_worker.ml

@@ -134,7 +134,7 @@ module Make (Args : Gc_args.S) = struct
 
   type gc_output = (gc_results, Args.Errs.t) result [@@deriving irmin]
 
-  let run ~generation ~path_new_files root commit_key new_suffix_start_offset =
+  let run ~generation ~new_files_path root commit_key new_suffix_start_offset =
     let open Result_syntax in
     let config =
       Irmin_pack.Conf.init ~fresh:false ~readonly:true ~lru_size:0 root
@@ -179,7 +179,7 @@ module Make (Args : Gc_args.S) = struct
         stats := Gc_stats.Worker.add_file_size !stats "mapping" mapping_size
       in
       (fun f ->
-        Mapping_file.create ~report_file_sizes ~root:path_new_files ~generation
+        Mapping_file.create ~report_file_sizes ~root:new_files_path ~generation
           ~register_entries:f ()
         |> Errs.raise_if_error)
       @@ fun ~register_entry ->
@@ -231,7 +231,7 @@ module Make (Args : Gc_args.S) = struct
       stats := Gc_stats.Worker.finish_current_step !stats "prefix: start";
       let prefix =
         let path =
-          Irmin_pack.Layout.V4.prefix ~root:path_new_files ~generation
+          Irmin_pack.Layout.V4.prefix ~root:new_files_path ~generation
         in
         Ao.create_rw_exn ~path
       in
@@ -265,7 +265,7 @@ module Make (Args : Gc_args.S) = struct
       in
       let prefix =
         let path =
-          Irmin_pack.Layout.V4.prefix ~root:path_new_files ~generation
+          Irmin_pack.Layout.V4.prefix ~root:new_files_path ~generation
         in
         Io.open_ ~path ~readonly:false |> Errs.raise_if_error
       in
@@ -361,11 +361,11 @@ module Make (Args : Gc_args.S) = struct
 
   (* No one catches errors when this function terminates. Write the result in a
      file and terminate. *)
-  let run_and_output_result ~generation ~path_new_files root commit_key
+  let run_and_output_result ~generation ~new_files_path root commit_key
       new_suffix_start_offset =
     let result =
       Errs.catch (fun () ->
-          run ~generation ~path_new_files root commit_key
+          run ~generation ~new_files_path root commit_key
             new_suffix_start_offset)
     in
     let write_result = write_gc_output ~root ~generation result in

src/irmin-pack/unix/gc_worker.mli

@@ -24,7 +24,7 @@ module Make (Args : Gc_args.S) : sig
 
   val run_and_output_result :
     generation:int ->
-    path_new_files:string ->
+    new_files_path:string ->
     string ->
     Args.key ->
     int63 ->

src/irmin-pack/unix/io.ml

@@ -267,7 +267,7 @@ module Unix = struct
       Ok ()
     with Sys_error msg -> Error (`Sys_error msg)
 
-  let cp_file ~src ~dst =
+  let copy_file ~src ~dst =
     let cmd = Filename.quote_command "cp" [ "-p"; src; dst ] in
     match Sys.command cmd with
     | 0 -> Ok ()

src/irmin-pack/unix/io_errors.ml

@@ -75,7 +75,8 @@ module Make (Io : Io.S) : S with module Io = Io = struct
     | `Ro_not_allowed
     | `Io_misc of Io.misc_error
     | `Split_forbidden_during_batch
-    | `Multiple_empty_chunks ]
+    | `Multiple_empty_chunks
+    | `Cannot_run_during_gc ]
   [@@deriving irmin]
 
   let raise_error = function

src/irmin-pack/unix/io_intf.ml

@@ -78,7 +78,7 @@ module type S = sig
   val move_file :
     src:string -> dst:string -> (unit, [> `Sys_error of string ]) result
 
-  val cp_file :
+  val copy_file :
     src:string -> dst:string -> (unit, [> `Sys_error of string ]) result
 
   val mkdir : string -> (unit, [> mkdir_error ]) result