Source file `bigstringaf.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
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]

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 copy t ~off ~len =
  let buffer_len = length t in
  if off < 0 || off + len > buffer_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 || off + len > buffer_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 || off + len > buffer_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

(* 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