Skip to content

Commit 12e1d19

Browse files
alanechangalanechang
authored
flambda-backend: Add unboxed bigstring primitives to prim_has_valid_reprs (#2368)
.
1 parent 12e8b8a commit 12e1d19

File tree

3 files changed

+182
-0
lines changed

3 files changed

+182
-0
lines changed

‎testsuite/tests/typing-layouts/unboxed_bigstring_primitives.ml

Lines changed: 114 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,114 @@
1+
(* TEST
2+
* flambda2
3+
** native
4+
** bytecode
5+
** native
6+
flags = "-extension layouts_alpha"
7+
** bytecode
8+
flags = "-extension layouts_alpha"
9+
** native
10+
flags = "-extension layouts_beta"
11+
** bytecode
12+
flags = "-extension layouts_beta"
13+
*)
14+
15+
(* CR layouts: add the unboxed simd externals once we support them *)
16+
open Bigarray
17+
type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t
18+
external caml_bigstring_get_32 : bigstring -> int -> int32# = "%caml_bigstring_get32#"
19+
external caml_bigstring_get_64 : bigstring -> int -> int64# = "%caml_bigstring_get64#"
20+
external caml_bigstring_set_32 : bigstring -> int -> int32# -> unit = "%caml_bigstring_set32#"
21+
external caml_bigstring_set_64 : bigstring -> int -> int64# -> unit = "%caml_bigstring_set64#"
22+
23+
external unsafe_caml_bigstring_get_32 : bigstring -> int -> int32# = "%caml_bigstring_get32u#"
24+
external unsafe_caml_bigstring_get_64 : bigstring -> int -> int64# = "%caml_bigstring_get64u#"
25+
external unsafe_caml_bigstring_set_32 : bigstring -> int -> int32# -> unit = "%caml_bigstring_set32u#"
26+
external unsafe_caml_bigstring_set_64 : bigstring -> int -> int64# -> unit = "%caml_bigstring_set64u#"
27+
28+
external[@layout_poly] ignore : ('a : any). 'a -> unit = "%ignore"
29+
30+
let bigstring_of_string s =
31+
let a = Array1.create char c_layout (String.length s) in
32+
for i = 0 to String.length s - 1 do
33+
a.{i} <- s.[i]
34+
done;
35+
a
36+
37+
let s = bigstring_of_string (String.make 10 '\x00')
38+
let empty_s = bigstring_of_string ""
39+
40+
let assert_bound_check f =
41+
try
42+
ignore(f ());
43+
assert false
44+
with
45+
| Invalid_argument _ -> ()
46+
47+
let () =
48+
assert_bound_check (fun () -> ignore (caml_bigstring_get_32 s (-1)));
49+
assert_bound_check (fun () -> ignore (caml_bigstring_get_32 s 7));
50+
assert_bound_check (fun () -> ignore (caml_bigstring_get_64 s (-1)));
51+
assert_bound_check (fun () -> ignore (caml_bigstring_get_64 s 3));
52+
53+
assert_bound_check (fun () -> caml_bigstring_set_32 s (-1) #0l);
54+
assert_bound_check (fun () -> caml_bigstring_set_32 s 7 #0l);
55+
assert_bound_check (fun () -> caml_bigstring_set_64 s (-1) #0L);
56+
assert_bound_check (fun () -> caml_bigstring_set_64 s 3 #0L);
57+
58+
assert_bound_check (fun () -> ignore (caml_bigstring_get_32 empty_s 0));
59+
assert_bound_check (fun () -> ignore (caml_bigstring_get_64 empty_s 0));
60+
61+
assert_bound_check (fun () -> caml_bigstring_set_32 empty_s 0 #0l);
62+
assert_bound_check (fun () -> caml_bigstring_set_64 empty_s 0 #0L)
63+
64+
external bswap32: int32 -> int32 = "%bswap_int32"
65+
external bswap64: int64 -> int64 = "%bswap_int64"
66+
67+
let swap32 x =
68+
let open Stdlib__Int32_u in
69+
if Sys.big_endian
70+
then x |> to_int32 |> bswap32 |> of_int32
71+
else x
72+
73+
let swap64 x =
74+
let open Stdlib__Int64_u in
75+
if Sys.big_endian
76+
then x |> to_int64 |> bswap64 |> of_int64
77+
else x
78+
79+
let to_int32 = Stdlib__Int32_u.to_int32
80+
let to_int64 = Stdlib__Int64_u.to_int64
81+
let test get_64 set_64 get_32 set_32 =
82+
set_32 s 0 (swap32 #0x12345678l);
83+
Printf.printf "%lx %lx %lx\n%!"
84+
(to_int32 (swap32 (get_32 s 0)))
85+
(to_int32 (swap32 (get_32 s 1)))
86+
(to_int32 (swap32 (get_32 s 2)));
87+
set_32 s 0 (swap32 #0xFEDCBA09l);
88+
Printf.printf "%lx %lx %lx\n%!"
89+
(to_int32 (swap32 (get_32 s 0)))
90+
(to_int32 (swap32 (get_32 s 1)))
91+
(to_int32 (swap32 (get_32 s 2)));
92+
93+
set_64 s 0 (swap64 #0x1234567890ABCDEFL);
94+
Printf.printf "%Lx %Lx %Lx\n%!"
95+
(to_int64 (swap64 (get_64 s 0)))
96+
(to_int64 (swap64 (get_64 s 1)))
97+
(to_int64 (swap64 (get_64 s 2)));
98+
set_64 s 0 (swap64 #0xFEDCBA0987654321L);
99+
Printf.printf "%Lx %Lx %Lx\n%!"
100+
(to_int64 (swap64 (get_64 s 0)))
101+
(to_int64 (swap64 (get_64 s 1)))
102+
(to_int64 (swap64 (get_64 s 2)))
103+
104+
let () =
105+
test
106+
caml_bigstring_get_64
107+
caml_bigstring_set_64
108+
caml_bigstring_get_32
109+
caml_bigstring_set_32;
110+
test
111+
unsafe_caml_bigstring_get_64
112+
unsafe_caml_bigstring_set_64
113+
unsafe_caml_bigstring_get_32
114+
unsafe_caml_bigstring_set_32

‎testsuite/tests/typing-layouts/unboxed_bigstring_primitives.reference

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
12345678 123456 1234
2+
fedcba09 fedcba fedc
3+
1234567890abcdef 1234567890abcd 1234567890ab
4+
fedcba0987654321 fedcba09876543 fedcba098765
5+
12345678 9123456 ba091234
6+
fedcba09 9fedcba ba09fedc
7+
1234567890abcdef 1234567890abcd 1234567890ab
8+
fedcba0987654321 fedcba09876543 fedcba098765

‎typing/primitive.ml

Lines changed: 60 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -600,6 +600,66 @@ let prim_has_valid_reprs ~loc prim =
600600
exactly [Same_as_ocaml_repr Bits64; Same_as_ocaml_repr Value]
601601
| "%unbox_int64" ->
602602
exactly [Same_as_ocaml_repr Value; Same_as_ocaml_repr Bits64]
603+
604+
(* Bigstring primitives *)
605+
| "%caml_bigstring_get32#" ->
606+
exactly [
607+
Same_as_ocaml_repr Value;
608+
Same_as_ocaml_repr Value;
609+
Same_as_ocaml_repr Bits32]
610+
| "%caml_bigstring_get32u#" ->
611+
exactly [
612+
Same_as_ocaml_repr Value;
613+
Same_as_ocaml_repr Value;
614+
Same_as_ocaml_repr Bits32]
615+
| "%caml_bigstring_get64#" ->
616+
exactly [
617+
Same_as_ocaml_repr Value;
618+
Same_as_ocaml_repr Value;
619+
Same_as_ocaml_repr Bits64]
620+
| "%caml_bigstring_get64u#" ->
621+
exactly [
622+
Same_as_ocaml_repr Value;
623+
Same_as_ocaml_repr Value;
624+
Same_as_ocaml_repr Bits64]
625+
626+
(* CR layouts: add these when we have unboxed simd layouts *)
627+
(* | "%caml_bigstring_getu128#" ->
628+
| "%caml_bigstring_getu128u#" ->
629+
| "%caml_bigstring_geta128#" ->
630+
| "%caml_bigstring_geta128u#" -> *)
631+
632+
| "%caml_bigstring_set32#" ->
633+
exactly [
634+
Same_as_ocaml_repr Value;
635+
Same_as_ocaml_repr Value;
636+
Same_as_ocaml_repr Bits32;
637+
Same_as_ocaml_repr Value]
638+
| "%caml_bigstring_set32u#" ->
639+
exactly [
640+
Same_as_ocaml_repr Value;
641+
Same_as_ocaml_repr Value;
642+
Same_as_ocaml_repr Bits32;
643+
Same_as_ocaml_repr Value]
644+
| "%caml_bigstring_set64#" ->
645+
exactly [
646+
Same_as_ocaml_repr Value;
647+
Same_as_ocaml_repr Value;
648+
Same_as_ocaml_repr Bits64;
649+
Same_as_ocaml_repr Value]
650+
| "%caml_bigstring_set64u#" ->
651+
exactly [
652+
Same_as_ocaml_repr Value;
653+
Same_as_ocaml_repr Value;
654+
Same_as_ocaml_repr Bits64;
655+
Same_as_ocaml_repr Value]
656+
657+
(* CR layouts: add these when we have unboxed simd layouts *)
658+
(* | "%caml_bigstring_setu128#" ->
659+
| "%caml_bigstring_setu128u#" ->
660+
| "%caml_bigstring_seta128#" ->
661+
| "%caml_bigstring_seta128u#" -> *)
662+
603663
| name when is_builtin_prim_name name ->
604664
no_non_value_repr
605665

0 commit comments

Comments
 (0)