diff --git a/bench/irmin-pack/trace_common.ml b/bench/irmin-pack/trace_common.ml index 7735666a64..5f9ddb6db0 100644 --- a/bench/irmin-pack/trace_common.ml +++ b/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 diff --git a/irmin-pack.opam b/irmin-pack.opam index 8bfb1db5b4..da4b5a0db9 100644 --- a/irmin-pack.opam +++ b/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" diff --git a/irmin.opam b/irmin.opam index 66090d8c7f..c5d0582d40 100644 --- a/irmin.opam +++ b/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" ] ] diff --git a/src/irmin-chunk/irmin_chunk.ml b/src/irmin-chunk/irmin_chunk.ml index 01978824c1..11bff712a4 100644 --- a/src/irmin-chunk/irmin_chunk.ml +++ b/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 diff --git a/src/irmin-git/commit.ml b/src/irmin-git/commit.ml index cda8e8143d..674a91ae35 100644 --- a/src/irmin-git/commit.ml +++ b/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" diff --git a/src/irmin-git/contents.ml b/src/irmin-git/contents.ml index 4ee59ca371..3c6e6bb951 100644 --- a/src/irmin-git/contents.ml +++ b/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" diff --git a/src/irmin-git/node.ml b/src/irmin-git/node.ml index 05d38102c3..1db876370f 100644 --- a/src/irmin-git/node.ml +++ b/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" diff --git a/src/irmin-pack/atomic_write.ml b/src/irmin-pack/atomic_write.ml index fd93b67054..61cc66d355 100644 --- a/src/irmin-pack/atomic_write.ml +++ b/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 diff --git a/src/irmin-pack/dict.ml b/src/irmin-pack/dict.ml index 6fcaf3e209..e79f311d92 100644 --- a/src/irmin-pack/dict.ml +++ b/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 diff --git a/src/irmin-pack/inode.ml b/src/irmin-pack/inode.ml index 4b413c36eb..51bebae330 100644 --- a/src/irmin-pack/inode.ml +++ b/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 diff --git a/src/irmin-pack/pack_index.ml b/src/irmin-pack/pack_index.ml index 790708dbc4..055cc1c44a 100644 --- a/src/irmin-pack/pack_index.ml +++ b/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 diff --git a/src/irmin-pack/pack_store.ml b/src/irmin-pack/pack_store.ml index bdd404225c..5a827d69ac 100644 --- a/src/irmin-pack/pack_store.ml +++ b/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 diff --git a/src/irmin-pack/pack_value.ml b/src/irmin-pack/pack_value.ml index c3e6de7de9..67ba44afb4 100644 --- a/src/irmin-pack/pack_value.ml +++ b/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 diff --git a/src/irmin-pack/pack_value_intf.ml b/src/irmin-pack/pack_value_intf.ml index 7d74abacb4..c18e1a8af3 100644 --- a/src/irmin-pack/pack_value_intf.ml +++ b/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 diff --git a/src/irmin-pack/traverse_pack_file.ml b/src/irmin-pack/traverse_pack_file.ml index 9d86de41df..081954e5f9 100644 --- a/src/irmin-pack/traverse_pack_file.ml +++ b/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) } diff --git a/src/irmin/commit.ml b/src/irmin/commit.ml index 07b570c3cf..2785715da1 100644 --- a/src/irmin/commit.ml +++ b/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 diff --git a/src/irmin/hash.ml b/src/irmin/hash.ml index fe96a04a54..165c620f33 100644 --- a/src/irmin/hash.ml +++ b/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 diff --git a/src/irmin/node.ml b/src/irmin/node.ml index 9504ef8625..7a732eb0ff 100644 --- a/src/irmin/node.ml +++ b/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 diff --git a/test/irmin-pack/common.ml b/test/irmin-pack/common.ml index bf0b01e89e..b71bb7d474 100644 --- a/test/irmin-pack/common.ml +++ b/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 diff --git a/test/irmin-pack/test_inode.ml b/test/irmin-pack/test_inode.ml index a8ddcf4fcd..7f67c0d20e 100644 --- a/test/irmin-pack/test_inode.ml +++ b/test/irmin-pack/test_inode.ml @@ -372,7 +372,7 @@ let test_truncated_inodes () = encode inode (Buffer.add_string buf); Buffer.contents buf in - let decode str = decode str 0 |> snd in + let decode str = decode str (ref 0) in inode |> encode |> decode in let with_failure f =