Source file bigstringaf.ml

type bigstring =
  (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t

type t = bigstring

let create size = Bigarray.(Array1.create char c_layout size)
let empty       = create 0

module BA1 = Bigarray.Array1

let length t = BA1.dim t

external get : t -> int -> char = "%caml_ba_ref_1"
external set : t -> int -> char -> unit = "%caml_ba_set_1"

external unsafe_get : t -> int -> char         = "%caml_ba_unsafe_ref_1"
external unsafe_set : t -> int -> char -> unit = "%caml_ba_unsafe_set_1"

external unsafe_blit            : t       -> src_off:int -> t       -> dst_off:int -> len:int -> unit =
  "bigstringaf_blit_to_bigstring" [@@noalloc]

external unsafe_blit_to_bytes   : t       -> src_off:int -> Bytes.t -> dst_off:int -> len:int -> unit =
  "bigstringaf_blit_to_bytes"     [@@noalloc]

external unsafe_blit_from_bytes : Bytes.t -> src_off:int -> t       -> dst_off:int -> len:int -> unit =
  "bigstringaf_blit_from_bytes"   [@@noalloc]

external unsafe_blit_from_string : string -> src_off:int -> t       -> dst_off:int -> len:int -> unit =
  "bigstringaf_blit_from_bytes"   [@@noalloc]

external unsafe_memcmp : t -> int -> t -> int -> int -> int =
  "bigstringaf_memcmp_bigstring" [@@noalloc]

external unsafe_memcmp_string : t -> int -> string -> int -> int -> int =
  "bigstringaf_memcmp_string" [@@noalloc]

let sub t ~off ~len =
  BA1.sub t off len

let[@inline never] invalid_bounds op buffer_len off len =
  let message =
    Printf.sprintf "Bigstringaf.%s invalid range: { buffer_len: %d, off: %d, len: %d }"
    op buffer_len off len
  in
  raise (Invalid_argument message)
;;

let[@inline never] invalid_bounds_blit op src_len src_off dst_len dst_off len =
  let message =
    Printf.sprintf "Bigstringaf.%s invalid range: { src_len: %d, src_off: %d, dst_len: %d, dst_off: %d, len: %d }"
    op src_len src_off dst_len dst_off len
  in
  raise (Invalid_argument message)
;;

let[@inline never] invalid_bounds_memcmp op buf1_len buf1_off buf2_len buf2_off len =
  let message =
    Printf.sprintf "Bigstringaf.%s invalid range: { buf1_len: %d, buf1_off: %d, buf2_len: %d, buf2_off: %d, len: %d }"
    op buf1_len buf1_off buf2_len buf2_off len
  in
  raise (Invalid_argument message)
;;

(* A note on bounds checking.
 *
 * The code should perform the following check to ensure that the blit doesn't
 * run off the end of the input buffer:
 *
 *   {[off + len <= buffer_len]}
 *
 * However, this may lead to an interger overflow for large values of [off],
 * e.g., [max_int], which will cause the comparison to return [true] when it
 * should really return [false].
 *
 * An equivalent comparison that does not run into this integer overflow
 * problem is:
 *
 *   {[buffer_len - off => len]}
 *
 * This is checking that the input buffer, less the offset, is sufficiently
 * long to perform the blit. Since the expression is subtracting [off] rather
 * than adding it, it doesn't suffer from the overflow that the previous
 * inequality did. As long as there is check to ensure that [off] is not
 * negative, it won't underflow either. *)

let copy t ~off ~len =
  let buffer_len = length t in
  if off < 0 || buffer_len - off < len then invalid_bounds "copy" buffer_len off len;
  let dst = create len in
  unsafe_blit t ~src_off:off dst ~dst_off:0 ~len;
  dst
;;

let substring t ~off ~len =
  let buffer_len = length t in
  if off < 0 || buffer_len - off < len then invalid_bounds "substring" buffer_len off len;
  let b = Bytes.create len in
  unsafe_blit_to_bytes t ~src_off:off b ~dst_off:0 ~len;
  Bytes.unsafe_to_string b
;;

let of_string ~off ~len s =
  let buffer_len = String.length s in
  if off < 0 || buffer_len - off < len then invalid_bounds "of_string" buffer_len off len;
  let b = create len in
  unsafe_blit_from_string s ~src_off:off b ~dst_off:0 ~len;
  b
;;

let blit src ~src_off dst ~dst_off ~len =
  let src_len = length src in
  let dst_len = length dst in
  if src_off < 0 || src_len - src_off < len
  then invalid_bounds_blit "blit" src_len src_off dst_len dst_off len;
  if dst_off < 0 || dst_len - dst_off < len
  then invalid_bounds_blit "blit" src_len src_off dst_len dst_off len;
  unsafe_blit src ~src_off dst ~dst_off ~len
;;

let blit_from_string src ~src_off dst ~dst_off ~len =
  let src_len = String.length src in
  let dst_len = length dst in
  if src_off < 0 || src_len - src_off < len
  then invalid_bounds_blit "blit_from_string" src_len src_off dst_len dst_off len;
  if dst_off < 0 || dst_len - dst_off < len
  then invalid_bounds_blit "blit_from_string" src_len src_off dst_len dst_off len;
  unsafe_blit_from_string src ~src_off dst ~dst_off ~len
;;

let blit_from_bytes src ~src_off dst ~dst_off ~len =
  let src_len = Bytes.length src in
  let dst_len = length dst in
  if src_off < 0 || src_len - src_off < len
  then invalid_bounds_blit "blit_from_bytes" src_len src_off dst_len dst_off len;
  if dst_off < 0 || dst_len - dst_off < len
  then invalid_bounds_blit "blit_from_bytes" src_len src_off dst_len dst_off len;
  unsafe_blit_from_bytes src ~src_off dst ~dst_off ~len
;;

let blit_to_bytes src ~src_off dst ~dst_off ~len =
  let src_len = length src in
  let dst_len = Bytes.length dst in
  if src_off < 0 || src_len - src_off < len
  then invalid_bounds_blit "blit_to_bytes" src_len src_off dst_len dst_off len;
  if dst_off < 0 || dst_len - dst_off < len
  then invalid_bounds_blit "blit_to_bytes" src_len src_off dst_len dst_off len;
  unsafe_blit_to_bytes src ~src_off dst ~dst_off ~len
;;

let memcmp buf1 buf1_off buf2 buf2_off len =
  let buf1_len = length buf1 in
  let buf2_len = length buf2 in
  if buf1_off < 0 || buf1_len - buf1_off < len
  then invalid_bounds_memcmp "memcmp" buf1_len buf1_off buf2_len buf2_off len;
  if buf2_off < 0 || buf2_len - buf2_off < len
  then invalid_bounds_memcmp "memcmp" buf1_len buf1_off buf2_len buf2_off len;
  unsafe_memcmp buf1 buf1_off buf2 buf2_off len
;;

let memcmp_string buf1 buf1_off buf2 buf2_off len =
  let buf1_len = length buf1 in
  let buf2_len = String.length buf2 in
  if buf1_off < 0 || buf1_len - buf1_off < len
  then invalid_bounds_memcmp "memcmp" buf1_len buf1_off buf2_len buf2_off len;
  if buf2_off < 0 || buf2_len - buf2_off < len
  then invalid_bounds_memcmp "memcmp" buf1_len buf1_off buf2_len buf2_off len;
  unsafe_memcmp_string buf1 buf1_off buf2 buf2_off len
;;


(* Safe operations *)

external caml_bigstring_set_16 : bigstring -> int -> int   -> unit = "%caml_bigstring_set16"
external caml_bigstring_set_32 : bigstring -> int -> int32 -> unit = "%caml_bigstring_set32"
external caml_bigstring_set_64 : bigstring -> int -> int64 -> unit = "%caml_bigstring_set64"

external caml_bigstring_get_16 : bigstring -> int -> int   = "%caml_bigstring_get16"
external caml_bigstring_get_32 : bigstring -> int -> int32 = "%caml_bigstring_get32"
external caml_bigstring_get_64 : bigstring -> int -> int64 = "%caml_bigstring_get64"

module Swap = struct
  external bswap16 : int -> int = "%bswap16"
  external bswap_int32 : int32 -> int32 = "%bswap_int32"
  external bswap_int64 : int64 -> int64 = "%bswap_int64"

  let caml_bigstring_set_16 bs off i =
    caml_bigstring_set_16 bs off (bswap16 i)

  let caml_bigstring_set_32 bs off i =
    caml_bigstring_set_32 bs off (bswap_int32 i)

  let caml_bigstring_set_64 bs off i =
    caml_bigstring_set_64 bs off (bswap_int64 i)

  let caml_bigstring_get_16 bs off =
    bswap16 (caml_bigstring_get_16 bs off)

  let caml_bigstring_get_32 bs off =
    bswap_int32 (caml_bigstring_get_32 bs off)

  let caml_bigstring_get_64 bs off =
    bswap_int64 (caml_bigstring_get_64 bs off)

  let get_int16_sign_extended x off =
    ((caml_bigstring_get_16 x off) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
end

let set_int16_le, set_int16_be =
  if Sys.big_endian
  then Swap.caml_bigstring_set_16, caml_bigstring_set_16
  else caml_bigstring_set_16     , Swap.caml_bigstring_set_16

let set_int32_le, set_int32_be =
  if Sys.big_endian
  then Swap.caml_bigstring_set_32, caml_bigstring_set_32
  else caml_bigstring_set_32     , Swap.caml_bigstring_set_32

let set_int64_le, set_int64_be =
  if Sys.big_endian
  then Swap.caml_bigstring_set_64, caml_bigstring_set_64
  else caml_bigstring_set_64     , Swap.caml_bigstring_set_64

let get_int16_le, get_int16_be =
  if Sys.big_endian
  then Swap.caml_bigstring_get_16, caml_bigstring_get_16
  else caml_bigstring_get_16     , Swap.caml_bigstring_get_16

let get_int16_sign_extended_noswap x off =
  ((caml_bigstring_get_16      x off) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int16_sign_extended_le, get_int16_sign_extended_be  =
  if Sys.big_endian
  then Swap.get_int16_sign_extended  , get_int16_sign_extended_noswap
  else get_int16_sign_extended_noswap, Swap.get_int16_sign_extended

let get_int32_le, get_int32_be =
  if Sys.big_endian
  then Swap.caml_bigstring_get_32, caml_bigstring_get_32
  else caml_bigstring_get_32     , Swap.caml_bigstring_get_32

let get_int64_le, get_int64_be =
  if Sys.big_endian
  then Swap.caml_bigstring_get_64, caml_bigstring_get_64
  else caml_bigstring_get_64     , Swap.caml_bigstring_get_64

(* Unsafe operations *)

external caml_bigstring_unsafe_set_16 : bigstring -> int -> int   -> unit = "%caml_bigstring_set16u"
external caml_bigstring_unsafe_set_32 : bigstring -> int -> int32 -> unit = "%caml_bigstring_set32u"
external caml_bigstring_unsafe_set_64 : bigstring -> int -> int64 -> unit = "%caml_bigstring_set64u"

external caml_bigstring_unsafe_get_16 : bigstring -> int -> int   = "%caml_bigstring_get16u"
external caml_bigstring_unsafe_get_32 : bigstring -> int -> int32 = "%caml_bigstring_get32u"
external caml_bigstring_unsafe_get_64 : bigstring -> int -> int64 = "%caml_bigstring_get64u"

module USwap = struct
  external bswap16 : int -> int = "%bswap16"
  external bswap_int32 : int32 -> int32 = "%bswap_int32"
  external bswap_int64 : int64 -> int64 = "%bswap_int64"

  let caml_bigstring_unsafe_set_16 bs off i =
    caml_bigstring_unsafe_set_16 bs off (bswap16 i)

  let caml_bigstring_unsafe_set_32 bs off i =
    caml_bigstring_unsafe_set_32 bs off (bswap_int32 i)

  let caml_bigstring_unsafe_set_64 bs off i =
    caml_bigstring_unsafe_set_64 bs off (bswap_int64 i)

  let caml_bigstring_unsafe_get_16 bs off =
    bswap16 (caml_bigstring_unsafe_get_16 bs off)

  let caml_bigstring_unsafe_get_32 bs off =
    bswap_int32 (caml_bigstring_unsafe_get_32 bs off)

  let caml_bigstring_unsafe_get_64 bs off =
    bswap_int64 (caml_bigstring_unsafe_get_64 bs off)
end

let unsafe_set_int16_le, unsafe_set_int16_be =
  if Sys.big_endian
  then USwap.caml_bigstring_unsafe_set_16, caml_bigstring_unsafe_set_16
  else caml_bigstring_unsafe_set_16      , USwap.caml_bigstring_unsafe_set_16

let unsafe_set_int32_le, unsafe_set_int32_be =
  if Sys.big_endian
  then USwap.caml_bigstring_unsafe_set_32, caml_bigstring_unsafe_set_32
  else caml_bigstring_unsafe_set_32      , USwap.caml_bigstring_unsafe_set_32

let unsafe_set_int64_le, unsafe_set_int64_be =
  if Sys.big_endian
  then USwap.caml_bigstring_unsafe_set_64, caml_bigstring_unsafe_set_64
  else caml_bigstring_unsafe_set_64      , USwap.caml_bigstring_unsafe_set_64

let unsafe_get_int16_le, unsafe_get_int16_be =
  if Sys.big_endian
  then USwap.caml_bigstring_unsafe_get_16, caml_bigstring_unsafe_get_16
  else caml_bigstring_unsafe_get_16      , USwap.caml_bigstring_unsafe_get_16

let unsafe_get_int16_sign_extended_le x off =
  ((unsafe_get_int16_le x off) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let unsafe_get_int16_sign_extended_be x off =
  ((unsafe_get_int16_be x off ) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let unsafe_get_int32_le, unsafe_get_int32_be =
  if Sys.big_endian
  then USwap.caml_bigstring_unsafe_get_32, caml_bigstring_unsafe_get_32
  else caml_bigstring_unsafe_get_32      , USwap.caml_bigstring_unsafe_get_32

let unsafe_get_int64_le, unsafe_get_int64_be =
  if Sys.big_endian
  then USwap.caml_bigstring_unsafe_get_64, caml_bigstring_unsafe_get_64
  else caml_bigstring_unsafe_get_64      , USwap.caml_bigstring_unsafe_get_64