Adapt to mirage/repr#81 (improved binary decoder type)

bench/irmin-pack/trace_common.ml

@@ -199,20 +199,21 @@ module Io (Ff : File_format) = struct
   let encode_lrow = Repr.(encode_bin Ff.Latest.row_t |> unstage)
   let magic = Ff.magic
 
-  let read_with_prefix_exn : (string -> int -> int * 'a) -> in_channel -> 'a =
+  let read_with_prefix_exn : (string -> int ref -> 'a) -> in_channel -> 'a =
    fun decode chan ->
     (* First read the prefix *)
     let len = Var_int.read_exn chan in
     (* Then read the repr. *)
-    let len', v =
+    let pos_ref = ref 0 in
+    let v =
       (* This could fail if [len] is not long enough for repr (corruption) *)
-      decode (really_input_string chan len) 0
+      decode (really_input_string chan len) pos_ref
     in
-    if len <> len' then
+    if len <> !pos_ref then
       Fmt.failwith
         "An value read in the Trace was expected to take %d bytes, but it took \
          only %d."
-        len len';
+        len !pos_ref;
     v
 
   let decoded_seq_of_encoded_chan_with_prefixes :
@@ -240,8 +241,9 @@ module Io (Ff : File_format) = struct
         magic Magic.pp Ff.magic;
 
     let (Version_converter vc) =
-      let len', version = decode_i32 (really_input_string chan 4) 0 in
-      assert (len' = 4);
+      let pos_ref = ref 0 in
+      let version = decode_i32 (really_input_string chan 4) pos_ref in
+      assert (!pos_ref = 4);
       Ff.get_version_converter (Int32.to_int version)
     in
 

irmin-pack.opam

@@ -33,7 +33,7 @@ depends: [
 ]
 
 pin-depends: [
-  [ "index.dev" "git+https://github.com/mirage/index#5222f7e939491269e61915aac910d2f9f99556b4" ]
+  [ "index.dev" "git+https://github.com/mirage/index#07bdd1b5da5737c92c743a65df685145ffdca603" ]
 ]
 
 synopsis: "Irmin backend which stores values in a pack file"

irmin.opam

@@ -50,6 +50,6 @@ depend on external C stubs; it aims to run everywhere, from Linux,
 to browsers and Xen unikernels.
 """
 pin-depends: [
-  [ "repr.dev" "git+https://github.com/mirage/repr#17623decc3d499b83da1f5d71b298681100539a3" ]
-  [ "ppx_repr.dev" "git+https://github.com/mirage/repr#17623decc3d499b83da1f5d71b298681100539a3" ]
+  [ "repr.dev" "git+https://github.com/mirage/repr#031cbb3728c3394e46b25a5e77aa5ceaa674c235" ]
+  [ "ppx_repr.dev" "git+https://github.com/mirage/repr#031cbb3728c3394e46b25a5e77aa5ceaa674c235" ]
 ]

src/irmin-chunk/irmin_chunk.ml

@@ -89,9 +89,10 @@ module Chunk (H : Irmin.Hash.S) = struct
 
   let of_string b =
     let len = String.length b in
-    let n, v = decode_bin_value b 0 in
-    if len = n then { len; v }
-    else Fmt.invalid_arg "invalid length: got %d, expecting %d" n len
+    let pos_ref = ref 0 in
+    let v = decode_bin_value b pos_ref in
+    if !pos_ref = len then { len; v }
+    else Fmt.invalid_arg "invalid length: got %d, expecting %d" !pos_ref len
 
   let to_string t =
     let buf = Bytes.make t.len '\000' in

src/irmin-git/commit.ml

@@ -95,10 +95,13 @@ module Make (G : Git.S) = struct
     [%log.debug "Commit.encode_bin"];
     k (to_bin t)
 
-  let decode_bin buf off =
+  let decode_bin buf pos_ref =
     [%log.debug "Commit.decode_bin"];
+    let off = !pos_ref in
     match Raw.of_raw_with_header ~off buf with
-    | Ok (Git.Value.Commit t) -> (String.length buf, t)
+    | Ok (Git.Value.Commit t) ->
+        pos_ref := String.length buf;
+        t
     | Ok _ -> failwith "wrong object kind"
     | Error _ -> failwith "wrong object kind"
 

src/irmin-git/contents.ml

@@ -46,12 +46,15 @@ module Make (G : Git.S) (C : Irmin.Contents.S) = struct
     let to_bin t = Raw.to_raw (V.to_git t)
     let encode_bin (t : t) k = k (to_bin t)
 
-    let decode_bin buf off =
+    let decode_bin buf pos_ref =
       [%log.debug "Content.decode_bin"];
+      let off = !pos_ref in
       match Raw.of_raw_with_header ~off buf with
       | Ok g -> (
           match V.of_git g with
-          | Some g -> (String.length buf, g)
+          | Some g ->
+              pos_ref := String.length buf;
+              g
           | None -> failwith "wrong object kind")
       | Error (`Msg _) -> failwith "wrong object"
 

src/irmin-git/node.ml

@@ -155,10 +155,13 @@ module Make (G : Git.S) (P : Irmin.Path.S) = struct
     [%log.debug "Tree.encode_bin"];
     k (to_bin t)
 
-  let decode_bin buf off =
+  let decode_bin buf pos_ref =
     [%log.debug "Tree.decode_bin"];
+    let off = !pos_ref in
     match Raw.of_raw_with_header buf ~off with
-    | Ok (Git.Value.Tree t) -> (String.length buf, t)
+    | Ok (Git.Value.Tree t) ->
+        pos_ref := String.length buf;
+        t
     | Ok _ -> failwith "wrong object kind"
     | Error _ -> failwith "wrong object"
 

src/irmin-pack/atomic_write.ml

@@ -57,12 +57,14 @@ struct
 
   let decode_bin = Irmin.Type.(unstage (decode_bin int32))
 
-  let read_length32 ~off block =
+  let read_length32 ~file_pos block =
     let buf = Bytes.create 4 in
-    let n = IO.read block ~off buf in
-    assert (n = 4);
-    let n, v = decode_bin (Bytes.unsafe_to_string buf) 0 in
+    let n = IO.read block ~off:!file_pos buf in
     assert (n = 4);
+    file_pos := !file_pos ++ Int63.of_int 4;
+    let pos_ref = ref 0 in
+    let v = decode_bin (Bytes.unsafe_to_string buf) pos_ref in
+    assert (!pos_ref = 4);
     Int32.to_int v
 
   let entry = Irmin.Type.(pair (string_of `Int32) V.t)
@@ -87,28 +89,36 @@ struct
            fixed-width binary encoding"
 
   let refill t ~to_ ~from =
-    let rec aux offset =
-      if offset >= to_ then ()
+    let file_pos = ref from in
+    let rec aux () =
+      if !file_pos >= to_ then ()
       else
-        let len = read_length32 ~off:offset t.block in
-        let buf = Bytes.create (len + value_encoded_size) in
-        let off = offset ++ Int63.of_int 4 in
-        let n = IO.read t.block ~off buf in
-        assert (n = Bytes.length buf);
-        let buf = Bytes.unsafe_to_string buf in
-        let h =
-          let h = String.sub buf 0 len in
-          match key_of_bin_string h with
+        let start = !file_pos in
+        let key_encoded_size = read_length32 ~file_pos t.block in
+        let buf_size = key_encoded_size + value_encoded_size in
+        let buf =
+          let buf = Bytes.create buf_size in
+          let n = IO.read t.block ~off:!file_pos buf in
+          assert (n = buf_size);
+          file_pos := !file_pos ++ Int63.of_int buf_size;
+          Bytes.unsafe_to_string buf
+        in
+        let key =
+          match String.sub buf 0 key_encoded_size |> key_of_bin_string with
           | Ok k -> k
           | Error (`Msg e) -> failwith e
         in
-        let n, v = decode_bin_value buf len in
-        assert (n = String.length buf);
-        if not (equal_value v V.null) then Tbl.add t.cache h v;
-        Tbl.add t.index h offset;
-        (aux [@tailcall]) (off ++ Int63.(of_int @@ (len + value_encoded_size)))
+        let value =
+          let pos_ref = ref key_encoded_size in
+          let v = decode_bin_value buf pos_ref in
+          assert (!pos_ref = buf_size);
+          v
+        in
+        if not (equal_value value V.null) then Tbl.add t.cache key value;
+        Tbl.add t.index key start;
+        (aux [@tailcall]) ()
     in
-    aux from
+    aux ()
 
   let sync_offset t =
     let former_offset = IO.offset t.block in

src/irmin-pack/dict.ml

@@ -39,17 +39,19 @@ module Make (V : Version.S) (IO : IO.S) : S = struct
     let n = IO.read t.io ~off:from raw in
     assert (n = len);
     let raw = Bytes.unsafe_to_string raw in
-    let rec aux n offset =
-      if offset >= len then ()
+    let pos_ref = ref 0 in
+    let rec aux n =
+      if !pos_ref >= len then ()
       else
-        let _, v = decode_bin_int32 raw offset in
+        let v = decode_bin_int32 raw pos_ref in
         let len = Int32.to_int v in
-        let v = String.sub raw (offset + 4) len in
+        let v = String.sub raw !pos_ref len in
+        pos_ref := !pos_ref + len;
         Hashtbl.add t.cache v n;
         Hashtbl.add t.index n v;
-        (aux [@tailcall]) (n + 1) (offset + 4 + len)
+        (aux [@tailcall]) (n + 1)
     in
-    (aux [@tailcall]) (Hashtbl.length t.cache) 0
+    (aux [@tailcall]) (Hashtbl.length t.cache)
 
   let sync_offset t =
     let former_offset = IO.offset t.io in

src/irmin-pack/inode.ml

@@ -1088,9 +1088,9 @@ struct
 
     exception Exit of [ `Msg of string ]
 
-    let decode_bin ~dict ~hash t off : int * t =
+    let decode_bin ~dict ~hash t pos_ref : t =
       Stats.incr_inode_decode_bin ();
-      let off, i = decode_compress t off in
+      let i = decode_compress t pos_ref in
       let step : Compress.name -> T.step = function
         | Direct n -> n
         | Indirect s -> (
@@ -1126,8 +1126,7 @@ struct
             let entries = List.map ptr entries in
             Tree { depth; length; entries }
       in
-      let t = Bin.v ~stable:i.stable ~hash:(lazy i.hash) (t i.v) in
-      (off, t)
+      Bin.v ~stable:i.stable ~hash:(lazy i.hash) (t i.v)
 
     let decode_bin_length = decode_compress_length
   end

src/irmin-pack/pack_index.ml

@@ -26,10 +26,7 @@ module Make (K : Irmin.Hash.S) = struct
     let hash_size = 30
     let encode = to_bin_string
     let encoded_size = K.hash_size
-
-    let decode s off =
-      let _, v = decode_bin s off in
-      v
+    let decode s off = decode_bin s (ref off)
   end
 
   module Val = struct

src/irmin-pack/pack_store.ml

@@ -143,8 +143,7 @@ module Maker
       let buf = Bytes.create K.hash_size in
       let n = IO.read t.pack.block ~off buf in
       assert (n = K.hash_size);
-      let _, v = decode_key (Bytes.unsafe_to_string buf) 0 in
-      v
+      decode_key (Bytes.unsafe_to_string buf) (ref 0)
 
     let unsafe_mem t k =
       [%log.debug "[pack] mem %a" pp_hash k];
@@ -168,7 +167,7 @@ module Maker
       if n <> len then raise Invalid_read;
       let hash off = io_read_and_decode_hash ~off t in
       let dict = Dict.find t.pack.dict in
-      Val.decode_bin ~hash ~dict (Bytes.unsafe_to_string buf) 0
+      Val.decode_bin ~hash ~dict (Bytes.unsafe_to_string buf) (ref 0)
 
     let pp_io ppf t =
       let name = Filename.basename (Filename.dirname (IO.name t.pack.block)) in
@@ -190,7 +189,7 @@ module Maker
               match Index.find t.pack.index k with
               | None -> None
               | Some (off, len, _) ->
-                  let v = snd (io_read_and_decode ~off ~len t) in
+                  let v = io_read_and_decode ~off ~len t in
                   (if check_integrity then
                    check_key k v |> function
                    | Ok () -> ()
@@ -208,7 +207,7 @@ module Maker
 
     let integrity_check ~offset ~length k t =
       try
-        let value = snd (io_read_and_decode ~off:offset ~len:length t) in
+        let value = io_read_and_decode ~off:offset ~len:length t in
         match check_key k value with
         | Ok () -> Ok ()
         | Error _ -> Error `Wrong_hash

src/irmin-pack/pack_value.ml

@@ -44,8 +44,8 @@ struct
   let encode_bin ~dict:_ ~offset:_ v hash = encode_value { kind; hash; v }
 
   let decode_bin ~dict:_ ~hash:_ s off =
-    let len, t = decode_value s off in
-    (len, t.v)
+    let t = decode_value s off in
+    t.v
 
   let decode_bin_length =
     match Irmin.Type.(Size.of_encoding value) with

src/irmin-pack/pack_value_intf.ml

@@ -21,8 +21,8 @@ module type S = sig
     dict:(int -> string option) ->
     hash:(int63 -> hash) ->
     string ->
-    int ->
-    int * t
+    int ref ->
+    t
 
   val decode_bin_length : string -> int -> int
 end

src/irmin-pack/traverse_pack_file.ml

@@ -178,11 +178,12 @@ end = struct
 
   let decode_entry_exn ~off ~buffer ~buffer_off =
     try
+      let buffer_pos = ref buffer_off in
       (* Decode the key and kind by hand *)
-      let off_after_key, key = decode_key buffer buffer_off in
-      assert (off_after_key = buffer_off + Hash.hash_size);
-      let off_after_kind, kind = decode_kind buffer off_after_key in
-      assert (off_after_kind = buffer_off + Hash.hash_size + 1);
+      let key = decode_key buffer buffer_pos in
+      assert (!buffer_pos = buffer_off + Hash.hash_size);
+      let kind = decode_kind buffer buffer_pos in
+      assert (!buffer_pos = buffer_off + Hash.hash_size + 1);
       (* Get the length of the entire entry *)
       let entry_len = decode_entry_length kind buffer buffer_off in
       { key; data = (off, entry_len, kind) }

src/irmin/commit.ml

@@ -569,12 +569,11 @@ module V1 = struct
 
       let decode_bin =
         let decode_bin = Type.(unstage (decode_bin h)) in
-        fun buf off ->
-          let n, v = decode_bin buf off in
-          ( n,
-            match hash_of_bin_string v with
-            | Ok v -> v
-            | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e )
+        fun buf pos_ref ->
+          let v = decode_bin buf pos_ref in
+          match hash_of_bin_string v with
+          | Ok v -> v
+          | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e
 
       type t = K.t
 

src/irmin/hash.ml

@@ -87,12 +87,11 @@ module V1 (K : S) : S with type t = K.t = struct
 
   let decode_bin =
     let decode_bin = Type.unstage (Type.decode_bin h) in
-    fun buf off ->
-      let n, v = decode_bin buf off in
-      ( n,
-        match of_bin_key v with
-        | Ok v -> v
-        | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e )
+    fun buf pos_ref ->
+      let v = decode_bin buf pos_ref in
+      match of_bin_key v with
+      | Ok v -> v
+      | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e
 
   let t = Type.like K.t ~bin:(encode_bin, decode_bin, size_of)
 end

src/irmin/node.ml

@@ -522,12 +522,11 @@ module V1 (N : Generic_key.S with type step = string) = struct
 
     let decode_bin =
       let decode_bin = Type.(unstage (decode_bin h)) in
-      fun buf off ->
-        let n, v = decode_bin buf off in
-        ( n,
-          match of_bin_string v with
-          | Ok v -> v
-          | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e )
+      fun buf pos_ref ->
+        let v = decode_bin buf pos_ref in
+        match of_bin_string v with
+        | Ok v -> v
+        | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e
 
     let t = Type.like t ~bin:(encode_bin, decode_bin, size_of)
   end

test/irmin-pack/common.ml

@@ -61,9 +61,9 @@ module Contents = struct
   let decode_pair = Irmin.Type.(unstage (decode_bin (pair H.t t)))
   let encode_bin ~dict:_ ~offset:_ x k = encode_pair (k, x)
 
-  let decode_bin ~dict:_ ~hash:_ x off =
-    let len, (_, v) = decode_pair x off in
-    (len, v)
+  let decode_bin ~dict:_ ~hash:_ x pos_ref =
+    let _, v = decode_pair x pos_ref in
+    v
 
   let decode_bin_length =
     match Irmin.Type.(Size.of_encoding (pair H.t t)) with