Merge pull request #1594 from icristescu/release-2.9.0

Release 2.9.0

CHANGES.md

@@ -1,4 +1,13 @@
-## 2.9.0 (TODO)
+## 2.9.0 (2021-11-15)
+
+### Fixed
+
+- **irmin-pack**
+   - Improved the performance of Index encode and decode operations by
+     eliminating intermediate allocations (up to 5% fewer minor words
+     allocated) (#1577, @CraigFe)
+   - Reduce the number of backend nodes built during export
+     (up to 20% fewer minor words allocated) (#1553, @Ngoguey42)
 
 ### Added
 
@@ -12,6 +21,7 @@
 
 - **irmin-pack**
   - Limit inode depth (#1596, #samoht)
+  - Adapt to index 1.5.0 (#1593, @icristescu)
 
 ## 2.8.0 (2021-10-15)
 

src/irmin-pack/inode.ml

@@ -961,8 +961,36 @@ struct
 
     let of_seq l =
       let t =
-        let aux acc (s, v) = add Total ~copy:false acc s v in
-        Seq.fold_left aux (empty Total) l
+        let rec aux_big seq inode =
+          match seq () with
+          | Seq.Nil -> inode
+          | Seq.Cons ((s, v), rest) ->
+              aux_big rest (add Total ~copy:false inode s v)
+        in
+        let len =
+          (* [StepMap.cardinal] is (a bit) expensive to compute, let's track the
+             size of the map in a [ref] while doing [StepMap.update]. *)
+          ref 0
+        in
+        let rec aux_small seq map =
+          match seq () with
+          | Seq.Nil ->
+              assert (!len <= Conf.entries);
+              values Total map
+          | Seq.Cons ((s, v), rest) ->
+              let map =
+                StepMap.update s
+                  (function
+                    | None ->
+                        incr len;
+                        Some v
+                    | Some _ -> Some v)
+                  map
+              in
+              if !len = Conf.entries then aux_big rest (values Total map)
+              else aux_small rest map
+        in
+        aux_small l StepMap.empty
       in
       stabilize Total t
 

src/irmin-pack/pack_index.ml

@@ -36,20 +36,21 @@ module Make (K : Irmin.Hash.S) = struct
   module Val = struct
     type t = int63 * int * Pack_value.Kind.t [@@deriving irmin]
 
-    let to_bin_string =
-      Irmin.Type.(
-        unstage (to_bin_string (triple int63_t int32 Pack_value.Kind.t)))
-
-    let encode (off, len, kind) = to_bin_string (off, Int32.of_int len, kind)
+    let encoded_size = (64 / 8) + (32 / 8) + 1
 
-    let decode_bin =
-      Irmin.Type.(unstage (decode_bin (triple int63_t int32 Pack_value.Kind.t)))
+    let encode ((off, len, kind) : t) =
+      let buf = Bytes.create encoded_size in
+      Bytes.set_int64_be buf 0 (Int63.to_int64 off);
+      Bytes.set_int32_be buf 8 (Int32.of_int len);
+      Bytes.set buf 12 (Pack_value.Kind.to_magic kind);
+      Bytes.unsafe_to_string buf
 
-    let decode s off =
-      let off, len, kind = snd (decode_bin s off) in
-      (off, Int32.to_int len, kind)
-
-    let encoded_size = (64 / 8) + (32 / 8) + 1
+    let decode s pos : t =
+      let buf = Bytes.unsafe_of_string s in
+      let off = Bytes.get_int64_be buf pos |> Int63.of_int64 in
+      let len = Bytes.get_int32_be buf (pos + 8) |> Int32.to_int in
+      let kind = Bytes.get buf (pos + 12) |> Pack_value.Kind.of_magic_exn in
+      (off, len, kind)
   end
 
   module Stats = Index.Stats

src/irmin-pack/pack_value.ml

@@ -10,14 +10,14 @@ module Kind = struct
     | Inode -> 'I'
     | Node -> 'N'
 
-  let of_magic = function
+  let of_magic_exn = function
     | 'C' -> Commit
     | 'B' -> Contents
     | 'I' -> Inode
     | 'N' -> Node
     | c -> Fmt.failwith "Kind.of_magic: unexpected magic char %C" c
 
-  let t = Irmin.Type.(map char) of_magic to_magic
+  let t = Irmin.Type.(map char) of_magic_exn to_magic
   let pp = Fmt.using to_magic Fmt.char
 end
 

src/irmin-pack/pack_value_intf.ml

@@ -32,6 +32,7 @@ module type Sigs = sig
     type t = Commit | Contents | Inode | Node [@@deriving irmin]
 
     val to_magic : t -> char
+    val of_magic_exn : char -> t
     val pp : t Fmt.t
   end
 

src/irmin-test/store_watch.ml

@@ -351,8 +351,9 @@ module Make (Log : Logs.LOG) (S : S) = struct
     run x test
 
   let tests =
-    [
-      ("Callbacks and exceptions", test_watch_exn);
-      ("Basic operations", test_watches);
-    ]
+    (* [test_watches] has been disabled for being flaky.
+        TODO: work out why, fix it, and re-enable it.
+        See https://github.com/mirage/irmin/issues/1447. *)
+    let _ = ("Basic operations", test_watches) in
+    [ ("Callbacks and exceptions", test_watch_exn) ]
 end

src/irmin/tree.ml

@@ -1464,10 +1464,19 @@ module Make (P : Private.S) = struct
               on_node_seq new_children_seq @@ fun () ->
               let* v = Node.to_value ~cache n in
               let v = get_ok "export" v in
-              let key = Node.hash ~cache n in
               cnt.node_add <- cnt.node_add + 1;
-              let* key' = P.Node.add node_t v in
-              assert (equal_hash key key');
+              let* key = P.Node.add node_t v in
+              let () =
+                (* Sanity check: Did we just store the same hash as the one represented
+                   by the Tree.Node [n]? *)
+                match Node.cached_hash n with
+                | None ->
+                    (* No hash is in [n]. Computing it would result in getting it from
+                       [v] or rebuilding a private node. *)
+                    ()
+                | Some key' -> assert (equal_hash key key')
+              in
+
               Node.export ?clear (Some repo) n key;
               k ())
     and on_contents (`Contents (c, _)) k =