Add in_channel twine decoder

Co-authored-by: Simon Cruanes <simon.cruanes.2007@m4x.org>

Author: wintersteiger

src/leb128/imandrakit_leb128.ml

@@ -32,7 +32,7 @@ module Decode = struct
     let res = ref 0L in
     let continue = ref true in
 
-    let off = ref off in
+    let off = ref (sl.off + off) in
     let n_consumed = ref 0 in
 
     while !continue do

src/twine/decode.ml

@@ -4,19 +4,107 @@ module Slice = Byte_slice
 module LEB128 = Imandrakit_leb128.Decode
 
 type cached = ..
-type cached += Miss
 
 module type CACHE_KEY = sig
   type elt
   type cached += C of elt
 end
 
-type t = {
-  sl: slice;
-  cache: cached array;
-  mutable hmap: Hmap.t;
+type t =
+  | Decode : {
+      st: 'st;
+      ops: 'st ops;
+      cache: cached Int_tbl.t;
+      mutable hmap: Hmap.t;
+    }
+      -> t
+
+and 'st ops = {
+  length: 'st -> int;
+  read_char: 'st -> int -> char;
+  read_int32: 'st -> int -> int32;
+  read_int64: 'st -> int -> int64;
+  read_blob: 'st -> int -> int -> slice;
+  read_leb128: 'st -> int -> int64 * offset;
 }
 
+let st_len t =
+  let (Decode { st; ops; _ }) = t in
+  ops.length st
+
+let read_char t offset =
+  let (Decode { st; ops; _ }) = t in
+  ops.read_char st offset
+
+let read_int32 t offset =
+  let (Decode { st; ops; _ }) = t in
+  ops.read_int32 st offset
+
+let read_int64 t offset =
+  let (Decode { st; ops; _ }) = t in
+  ops.read_int64 st offset
+
+let read_blob t offset length =
+  let (Decode { st; ops; _ }) = t in
+  ops.read_blob st offset length
+
+let read_leb128 t offset =
+  let (Decode { st; ops; _ }) = t in
+  ops.read_leb128 st offset
+
+let slice_ops : slice ops =
+  {
+    length = (fun (st : slice) -> Slice.len st);
+    read_char = (fun (st : slice) (offset : int) -> Slice.get st offset);
+    read_int32 =
+      (fun (st : slice) (offset : int) ->
+        Bytes.get_int32_le st.bs (st.off + offset));
+    read_int64 =
+      (fun (st : slice) (offset : int) ->
+        Bytes.get_int64_le st.bs (st.off + offset));
+    read_blob =
+      (fun (st : slice) (offset : int) (length : int) ->
+        Slice.sub st offset (min length (Slice.len st - st.off - offset)));
+    read_leb128 = (fun (st : slice) (offset : int) -> LEB128.u64 st offset);
+  }
+
+let in_channel_ops : in_channel ops =
+  {
+    length = (fun (st : in_channel) -> Int64.to_int (In_channel.length st));
+    read_char =
+      (fun (st : in_channel) (offset : int) ->
+        In_channel.seek st (Int64.of_int offset);
+        Option.get (In_channel.input_char st));
+    read_int32 =
+      (fun (st : in_channel) (offset : int) ->
+        let bs = Bytes.create 4 in
+        In_channel.seek st (Int64.of_int offset);
+        let _ = In_channel.really_input st bs 0 4 in
+        Bytes.get_int32_le bs 0);
+    read_int64 =
+      (fun (st : in_channel) (offset : int) ->
+        let bs = Bytes.create 8 in
+        In_channel.seek st (Int64.of_int offset);
+        let _ = In_channel.really_input st bs 0 8 in
+        Bytes.get_int64_le bs 0);
+    read_blob =
+      (fun (st : in_channel) (offset : int) (length : int) ->
+        let remaining = Int64.to_int (In_channel.length st) - offset in
+        let length = min length remaining in
+        let bs = Bytes.create length in
+        In_channel.seek st (Int64.of_int offset);
+        let _ = In_channel.really_input st bs 0 length in
+        Slice.create bs);
+    read_leb128 =
+      (fun (st : in_channel) (offset : int) ->
+        let remaining = Int64.to_int (In_channel.length st) - offset in
+        let length = min 16 remaining in
+        let bs = Bytes.create length in
+        In_channel.seek st (Int64.of_int offset);
+        let _ = In_channel.really_input st bs 0 length in
+        LEB128.u64 (Slice.create bs) 0);
+  }
+
 type cstor_index = int [@@deriving show]
 
 type cursor = {
@@ -30,16 +118,26 @@ let show_cursor (self : cursor) =
 
 let pp_cursor = Fmt.of_to_string show_cursor
 
-let[@inline] create sl : t =
-  { sl; cache = Array.make sl.len Miss; hmap = Hmap.empty }
+let[@inline] create (st : 'st) (ops : 'st ops) : t =
+  Decode { st; ops; cache = Int_tbl.create 32; hmap = Hmap.empty }
+
+let[@inline] of_slice s : t = create s slice_ops
+let[@inline] of_string s : t = create (Slice.of_string s) slice_ops
+let[@inline] of_in_channel c : t = create c in_channel_ops
+
+let[@inline] hmap_set self k v =
+  match self with
+  | Decode d -> d.hmap <- Hmap.add k v d.hmap
 
-let[@inline] of_string s = create @@ Slice.of_string s
-let[@inline] hmap_set self k v = self.hmap <- Hmap.add k v self.hmap
-let[@inline] hmap_get self k = Hmap.find k self.hmap
+let[@inline] hmap_get self k =
+  match self with
+  | Decode d -> Hmap.find k d.hmap
 
 let hmap_transfer d1 ~into:d2 : unit =
-  d2.hmap <-
-    Hmap.fold (fun (Hmap.B (k, v)) h2 -> Hmap.add k v h2) d1.hmap d2.hmap
+  match d1, d2 with
+  | Decode d1, Decode d2 ->
+    d2.hmap <-
+      Hmap.fold (fun (Hmap.B (k, v)) h2 -> Hmap.add k v h2) d1.hmap d2.hmap
 
 type 'a decoder = t -> offset -> 'a
 type num_bytes_consumed = int
@@ -77,7 +175,7 @@ let invalid_first_byte_ msg ~offset ~high ~low =
   failf "Decode: invalid first byte %d/%d at %d: %s" high low offset msg
 
 let[@inline] get_char_ (self : t) (offset : offset) : int =
-  Char.code (Slice.get self.sl offset)
+  Char.code @@ read_char self offset
 
 let[@inline] get_high (c : int) : int = (c land 0b1111_0000) lsr 4
 let[@inline] get_low (c : int) : int = c land 0b0000_1111
@@ -87,7 +185,7 @@ let[@inline] get_int64_ self offset ~low : int64 * num_bytes_consumed =
   if low < 15 then
     Int64.of_int low, 0
   else (
-    let i, n = LEB128.u64 self.sl (offset + 1) in
+    let i, n = read_leb128 self (offset + 1) in
     Int64.add i 15L, n
   )
 
@@ -106,13 +204,9 @@ let get_special_ offset ~high ~low : Value.t =
 let[@inline] get_float_ (self : t) offset ~low : float * num_bytes_consumed =
   let isf32 = low = 0 in
   if isf32 then
-    ( Bytes.get_int32_le self.sl.bs (self.sl.off + offset + 1)
-      |> Int32.float_of_bits,
-      4 )
+    read_int32 self (offset + 1) |> Int32.float_of_bits, 4
   else
-    ( Bytes.get_int64_le self.sl.bs (self.sl.off + offset + 1)
-      |> Int64.float_of_bits,
-      8 )
+    read_int64 self (offset + 1) |> Int64.float_of_bits, 8
 
 (** Number of bytes to skip *)
 let skip_float_ ~low : int =
@@ -173,11 +267,11 @@ let read ?(auto_deref = true) (self : t) (offset : offset) : Value.t =
     Value.Float f
   | 4 ->
     let len, size_len = get_int_truncate_ self offset ~low in
-    let s = Slice.sub self.sl (offset + 1 + size_len) len in
+    let s = read_blob self (offset + 1 + size_len) len in
     Value.String s
   | 5 ->
     let len, size_len = get_int_truncate_ self offset ~low in
-    let s = Slice.sub self.sl (offset + 1 + size_len) len in
+    let s = read_blob self (offset + 1 + size_len) len in
     Value.Blob s
   | 6 ->
     let len, size_len = get_int_truncate_ self offset ~low in
@@ -208,7 +302,8 @@ let read ?(auto_deref = true) (self : t) (offset : offset) : Value.t =
     let idx_cstor, size_idx_cstor = get_int_truncate_ self offset ~low in
     let offset_after_n = offset + 1 + size_idx_cstor in
     let num_items, size_num_items =
-      LEB128.uint_truncate self.sl offset_after_n
+      let sl = read_blob self offset_after_n 16 in
+      LEB128.uint_truncate sl 0
     in
     let c : cursor =
       {
@@ -314,7 +409,7 @@ let string_slice self offset =
   let low = get_low c in
   if high <> 4 then fail_decode_type_ ~what:"string" offset;
   let len, size_len = get_int_truncate_ self offset ~low in
-  Slice.sub self.sl (offset + 1 + size_len) len
+  read_blob self (offset + 1 + size_len) len
 
 let string self offset = Slice.contents @@ string_slice self offset
 
@@ -325,7 +420,7 @@ let blob_slice self offset =
   let low = get_low c in
   if high <> 5 then fail_decode_type_ ~what:"blob" offset;
   let len, size_len = get_int_truncate_ self offset ~low in
-  Slice.sub self.sl (offset + 1 + size_len) len
+  read_blob self (offset + 1 + size_len) len
 
 let blob self offset = Slice.contents @@ blob_slice self offset
 
@@ -380,7 +475,8 @@ let cstor self offset =
     let idx_cstor, size_idx_cstor = get_int_truncate_ self offset ~low in
     let offset_after_n = offset + 1 + size_idx_cstor in
     let num_items, size_num_items =
-      LEB128.uint_truncate self.sl offset_after_n
+      let sl = read_blob self offset_after_n 16 in
+      LEB128.uint_truncate sl 0
     in
     let c : cursor =
       {
@@ -405,15 +501,16 @@ let[@inline] ref_for (self : t) offset : _ offset_for =
   Offset_for (ref_ self offset)
 
 let get_entrypoint (self : t) : offset =
-  assert (Slice.len self.sl > 0);
-  let last = Slice.len self.sl - 1 in
-  let offset = Char.code @@ Slice.get self.sl last in
+  let len = st_len self in
+  assert (len > 0);
+  let last = len - 1 in
+  let offset = Char.code @@ read_char self last in
   last - offset - 1
 
 let read_entrypoint (self : t) : Value.t =
   read self @@ deref_rec self @@ get_entrypoint self
 
-let decode_string ?(init = ignore) (d : _ decoder) (s : string) =
+let decode_string ?(init = ignore) (d : 'a decoder) (s : string) : 'a =
   let self = of_string s in
   init self;
   let off = deref_rec self @@ get_entrypoint self in
@@ -544,12 +641,13 @@ let with_cache (type a) (key : a cache_key) (dec : a decoder) : a decoder =
     dec st off
   else (
     (* go through the cache *)
-    match st.cache.(off) with
-    | K.C v -> v
-    | Miss ->
+    let (Decode { cache; _ }) = st in
+    match Int_tbl.find cache off with
+    | exception Not_found ->
       let v = dec st off in
-      st.cache.(off) <- K.C v;
+      Int_tbl.add cache off (K.C v);
       v
+    | K.C v -> v
     | _ -> (* weird collision, just don't cache… *) dec st off
   )
 

src/twine/decode.mli

@@ -2,8 +2,9 @@ open Types
 
 type t
 
-val create : slice -> t
+val of_slice : slice -> t
 val of_string : string -> t
+val of_in_channel : in_channel -> t
 val hmap_set : t -> 'a Hmap.key -> 'a -> unit
 val hmap_get : t -> 'a Hmap.key -> 'a option
 
@@ -74,12 +75,12 @@ module Dict_cursor : sig
 end
 
 val deref_rec : offset decoder
-(** Given any value, follow pointers until a non-pointer value is reached,
-    a return its address. *)
+(** Given any value, follow pointers until a non-pointer value is reached, a
+    return its address. *)
 
 val read : ?auto_deref:bool -> Value.t decoder
 (** Read a value of any kind.
- @param auto_deref if true (default), follow pointers implicitly *)
+    @param auto_deref if true (default), follow pointers implicitly *)
 
 val null : unit decoder
 val bool : bool decoder
@@ -116,39 +117,35 @@ val decode_string : ?init:(t -> unit) -> 'a decoder -> string -> 'a
 
 (** {2 Caching}
 
-  Caching is used to reflect the sharing of values
-  embedded in a Twine slice, into the decoded values.
-  It means that, for a given type, if values of this type
-  are encoded with sharing (e.g. a graph-heavy term representation),
-  then with caching we can decode the values to OCaml values
-  that also have sharing.
-*)
+    Caching is used to reflect the sharing of values embedded in a Twine slice,
+    into the decoded values. It means that, for a given type, if values of this
+    type are encoded with sharing (e.g. a graph-heavy term representation), then
+    with caching we can decode the values to OCaml values that also have
+    sharing. *)
 
 type 'a cache_key
 (** Generative key used to cache values during decoding *)
 
 val create_cache_key : unit -> _ cache_key
 (** Generate a new (generative) cache key for a type.
 
-    {b NOTE} this should be called only at module toplevel, as a constant,
-    not dynamically inside a function:
-    [let key: foo value_pack.Deser.cache_key = value_pack.Deser.create_cache_key ();;].
-    Indeed, this is generative, so creating multiple keys for a type
+    {b NOTE} this should be called only at module toplevel, as a constant, not
+    dynamically inside a function:
+    [let key: foo value_pack.Deser.cache_key = value_pack.Deser.create_cache_key
+     ();;]. Indeed, this is generative, so creating multiple keys for a type
     will result in sub-par performance or non-existent caching. *)
 
 val with_cache : 'a cache_key -> 'a decoder -> 'a decoder
-(** [with_cache key dec] is the same decoder as [dec] but
-      it uses [key] to retrieve values directly from
-      an internal table for entries/values that have already
-      been decoded in the past. This means that a value that was
-      encoded with a lot of sharing (e.g in a graph, or a large
-      string using {!Ser.add_string}) will be decoded only once.
-  *)
+(** [with_cache key dec] is the same decoder as [dec] but it uses [key] to
+    retrieve values directly from an internal table for entries/values that have
+    already been decoded in the past. This means that a value that was encoded
+    with a lot of sharing (e.g in a graph, or a large string using
+    {!Ser.add_string}) will be decoded only once. *)
 
 val add_cache : 'a decoder ref -> unit
-(** [add_cache dec_ref] modifies the decoder so it uses a new cache key.
-    It is the same as:
-  {[
-  let key = create_cache_key ()
-  let () = dec_ref := with_cache key !dec_ref
-  ]} *)
+(** [add_cache dec_ref] modifies the decoder so it uses a new cache key. It is
+    the same as:
+    {[
+      let key = create_cache_key ()
+      let () = dec_ref := with_cache key !dec_ref
+    ]} *)

src/twine/dump.ml

@@ -149,7 +149,7 @@ let default_string_ellipsis_threshold = 30
 
 let dump_slice ?(string_ellipsis_threshold = default_string_ellipsis_threshold)
     (sl : slice) : string =
-  let dec = Decode.create sl in
+  let dec = Decode.of_slice sl in
   let st = { offset = Int_map.empty; dec; string_ellipsis_threshold } in
   dump_rec st (Decode.get_entrypoint dec);
   let buf = Buffer.create 32 in

test/twine/dune

@@ -1,5 +1,5 @@
 (tests
- (names t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12)
+ (names t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t_file_1)
  (libraries imandrakit.twine hex ppx_deriving.runtime unix)
  (package imandrakit)
  (preprocess

test/twine/t_file_1.expected

@@ -0,0 +1,7 @@
+t_out: { T_file_1.a = 43; b = (Types.Offset_for 13);
+         c = (Types.Offset_for 13) }
+t_in : { T_file_1.a = 43; b = (Types.Offset_for 13);
+         c = (Types.Offset_for 13) }
+a=43 b=XYZ c=XYZ
+00000000: 4c55 4e55 5345 4420 5354 5546 4643 5859  LUNUSED STUFFCXY
+00000001: 5a63 1f1c e6e7 04                        Zc.....