Merge pull request #1049 from icristescu/overcommit

Expose throttle from index

CHANGES.md

@@ -28,6 +28,10 @@
     let _ = <begin loop> ... encode_bin foo ... <end loop>
     ```
 
+- **irmin-pack**:
+  - Added `index_throttle` option to `Irmin_pack.config`, which exposes the
+    memory throttle feature of `Index` in `Irmin-Pack`. (#1049, @icristescu)
+
 #### Changed
 
 - **irmin**

src/irmin-pack/irmin_pack.ml

@@ -28,8 +28,25 @@ module Default = struct
   let index_log_size = 500_000
 
   let readonly = false
+
+  let index_throttle = `Block_writes
 end
 
+let throttle_converter =
+  let parse = function
+    | "Block_writes" -> Ok `Block_writes
+    | "Overcommit_memory" -> Ok `Overcommit_memory
+    | s ->
+        Fmt.error_msg
+          "invalid %s, expected one of: Block_writes Overcommit_memory" s
+  in
+  let print =
+    Fmt.of_to_string (function
+      | `Block_writes -> "Block_writes"
+      | `Overcommit_memory -> "Overcommit_memory")
+  in
+  (parse, print)
+
 let fresh_key =
   Irmin.Private.Conf.key ~doc:"Start with a fresh disk." "fresh"
     Irmin.Private.Conf.bool Default.fresh
@@ -46,6 +63,11 @@ let readonly_key =
   Irmin.Private.Conf.key ~doc:"Start with a read-only disk." "readonly"
     Irmin.Private.Conf.bool Default.readonly
 
+let index_throttle_key =
+  Irmin.Private.Conf.key
+    ~doc:"Strategy to use for large writes when index caches are full."
+    "index-throttle" throttle_converter Default.index_throttle
+
 let fresh config = Irmin.Private.Conf.get config fresh_key
 
 let lru_size config = Irmin.Private.Conf.get config lru_size_key
@@ -54,6 +76,8 @@ let readonly config = Irmin.Private.Conf.get config readonly_key
 
 let index_log_size config = Irmin.Private.Conf.get config index_log_size_key
 
+let index_throttle config = Irmin.Private.Conf.get config index_throttle_key
+
 let root_key = Irmin.Private.Conf.root
 
 let root config =
@@ -63,7 +87,7 @@ let root config =
 
 let config ?(fresh = Default.fresh) ?(readonly = Default.readonly)
     ?(lru_size = Default.lru_size) ?(index_log_size = Default.index_log_size)
-    root =
+    ?(index_throttle = Default.index_throttle) root =
   let config = Irmin.Private.Conf.empty in
   let config = Irmin.Private.Conf.add config fresh_key fresh in
   let config = Irmin.Private.Conf.add config root_key (Some root) in
@@ -72,6 +96,9 @@ let config ?(fresh = Default.fresh) ?(readonly = Default.readonly)
     Irmin.Private.Conf.add config index_log_size_key index_log_size
   in
   let config = Irmin.Private.Conf.add config readonly_key readonly in
+  let config =
+    Irmin.Private.Conf.add config index_throttle_key index_throttle
+  in
   config
 
 let ( ++ ) = Int64.add
@@ -470,12 +497,13 @@ struct
         let lru_size = lru_size config in
         let readonly = readonly config in
         let log_size = index_log_size config in
+        let throttle = index_throttle config in
         let f = ref (fun () -> ()) in
         let index =
           Index.v
             ~flush_callback:(fun () -> !f ())
               (* backpatching to add pack flush before an index flush *)
-            ~fresh ~readonly ~log_size root
+            ~fresh ~readonly ~throttle ~log_size root
         in
         Contents.CA.v ~fresh ~readonly ~lru_size ~index root >>= fun contents ->
         Node.CA.v ~fresh ~readonly ~lru_size ~index root >>= fun node ->

src/irmin-pack/irmin_pack.mli

@@ -19,8 +19,19 @@ val config :
   ?readonly:bool ->
   ?lru_size:int ->
   ?index_log_size:int ->
+  ?index_throttle:[ `Overcommit_memory | `Block_writes ] ->
   string ->
   Irmin.config
+(** Configuration options for stores.
+
+    @param fresh whether an existing store should be overwritten.
+    @param read_only whether read-only mode is enabled for this store.
+    @param lru_size the maximum number of bindings in the lru cache.
+    @param index_log_size the maximum number of bindings in the index cache.
+    @param index_throttle the strategy to use when the index cache is full and
+    an async [Index.merge] in already in progress. [Block_writes] (the default)
+    blocks any new writes until the merge is completed. [Overcommit_memory] does
+    not block but indefinitely expands the in-memory cache. *)
 
 module Pack = Pack
 module Dict = Pack_dict