From 12e1d1935bd71879774603c41f193153dfa01889 Mon Sep 17 00:00:00 2001 From: alanechang Date: Mon, 18 Mar 2024 13:13:47 -0400 Subject: [PATCH] flambda-backend: Add unboxed bigstring primitives to `prim_has_valid_reprs` (#2368) . --- .../unboxed_bigstring_primitives.ml | 114 ++++++++++++++++++ .../unboxed_bigstring_primitives.reference | 8 ++ typing/primitive.ml | 60 +++++++++ 3 files changed, 182 insertions(+) create mode 100644 testsuite/tests/typing-layouts/unboxed_bigstring_primitives.ml create mode 100644 testsuite/tests/typing-layouts/unboxed_bigstring_primitives.reference diff --git a/testsuite/tests/typing-layouts/unboxed_bigstring_primitives.ml b/testsuite/tests/typing-layouts/unboxed_bigstring_primitives.ml new file mode 100644 index 00000000000..3d2bc2e73aa --- /dev/null +++ b/testsuite/tests/typing-layouts/unboxed_bigstring_primitives.ml @@ -0,0 +1,114 @@ +(* TEST + * flambda2 + ** native + ** bytecode + ** native + flags = "-extension layouts_alpha" + ** bytecode + flags = "-extension layouts_alpha" + ** native + flags = "-extension layouts_beta" + ** bytecode + flags = "-extension layouts_beta" +*) + +(* CR layouts: add the unboxed simd externals once we support them *) +open Bigarray +type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t +external caml_bigstring_get_32 : bigstring -> int -> int32# = "%caml_bigstring_get32#" +external caml_bigstring_get_64 : bigstring -> int -> int64# = "%caml_bigstring_get64#" +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 unsafe_caml_bigstring_get_32 : bigstring -> int -> int32# = "%caml_bigstring_get32u#" +external unsafe_caml_bigstring_get_64 : bigstring -> int -> int64# = "%caml_bigstring_get64u#" +external unsafe_caml_bigstring_set_32 : bigstring -> int -> int32# -> unit = "%caml_bigstring_set32u#" +external unsafe_caml_bigstring_set_64 : bigstring -> int -> int64# -> unit = "%caml_bigstring_set64u#" + +external[@layout_poly] ignore : ('a : any). 'a -> unit = "%ignore" + +let bigstring_of_string s = + let a = Array1.create char c_layout (String.length s) in + for i = 0 to String.length s - 1 do + a.{i} <- s.[i] + done; + a + +let s = bigstring_of_string (String.make 10 '\x00') +let empty_s = bigstring_of_string "" + +let assert_bound_check f = + try + ignore(f ()); + assert false + with + | Invalid_argument _ -> () + +let () = + assert_bound_check (fun () -> ignore (caml_bigstring_get_32 s (-1))); + assert_bound_check (fun () -> ignore (caml_bigstring_get_32 s 7)); + assert_bound_check (fun () -> ignore (caml_bigstring_get_64 s (-1))); + assert_bound_check (fun () -> ignore (caml_bigstring_get_64 s 3)); + + assert_bound_check (fun () -> caml_bigstring_set_32 s (-1) #0l); + assert_bound_check (fun () -> caml_bigstring_set_32 s 7 #0l); + assert_bound_check (fun () -> caml_bigstring_set_64 s (-1) #0L); + assert_bound_check (fun () -> caml_bigstring_set_64 s 3 #0L); + + assert_bound_check (fun () -> ignore (caml_bigstring_get_32 empty_s 0)); + assert_bound_check (fun () -> ignore (caml_bigstring_get_64 empty_s 0)); + + assert_bound_check (fun () -> caml_bigstring_set_32 empty_s 0 #0l); + assert_bound_check (fun () -> caml_bigstring_set_64 empty_s 0 #0L) + +external bswap32: int32 -> int32 = "%bswap_int32" +external bswap64: int64 -> int64 = "%bswap_int64" + +let swap32 x = + let open Stdlib__Int32_u in + if Sys.big_endian + then x |> to_int32 |> bswap32 |> of_int32 + else x + +let swap64 x = + let open Stdlib__Int64_u in + if Sys.big_endian + then x |> to_int64 |> bswap64 |> of_int64 + else x + +let to_int32 = Stdlib__Int32_u.to_int32 +let to_int64 = Stdlib__Int64_u.to_int64 +let test get_64 set_64 get_32 set_32 = + set_32 s 0 (swap32 #0x12345678l); + Printf.printf "%lx %lx %lx\n%!" + (to_int32 (swap32 (get_32 s 0))) + (to_int32 (swap32 (get_32 s 1))) + (to_int32 (swap32 (get_32 s 2))); + set_32 s 0 (swap32 #0xFEDCBA09l); + Printf.printf "%lx %lx %lx\n%!" + (to_int32 (swap32 (get_32 s 0))) + (to_int32 (swap32 (get_32 s 1))) + (to_int32 (swap32 (get_32 s 2))); + + set_64 s 0 (swap64 #0x1234567890ABCDEFL); + Printf.printf "%Lx %Lx %Lx\n%!" + (to_int64 (swap64 (get_64 s 0))) + (to_int64 (swap64 (get_64 s 1))) + (to_int64 (swap64 (get_64 s 2))); + set_64 s 0 (swap64 #0xFEDCBA0987654321L); + Printf.printf "%Lx %Lx %Lx\n%!" + (to_int64 (swap64 (get_64 s 0))) + (to_int64 (swap64 (get_64 s 1))) + (to_int64 (swap64 (get_64 s 2))) + +let () = + test + caml_bigstring_get_64 + caml_bigstring_set_64 + caml_bigstring_get_32 + caml_bigstring_set_32; + test + unsafe_caml_bigstring_get_64 + unsafe_caml_bigstring_set_64 + unsafe_caml_bigstring_get_32 + unsafe_caml_bigstring_set_32 diff --git a/testsuite/tests/typing-layouts/unboxed_bigstring_primitives.reference b/testsuite/tests/typing-layouts/unboxed_bigstring_primitives.reference new file mode 100644 index 00000000000..15e965c5bfa --- /dev/null +++ b/testsuite/tests/typing-layouts/unboxed_bigstring_primitives.reference @@ -0,0 +1,8 @@ +12345678 123456 1234 +fedcba09 fedcba fedc +1234567890abcdef 1234567890abcd 1234567890ab +fedcba0987654321 fedcba09876543 fedcba098765 +12345678 9123456 ba091234 +fedcba09 9fedcba ba09fedc +1234567890abcdef 1234567890abcd 1234567890ab +fedcba0987654321 fedcba09876543 fedcba098765 diff --git a/typing/primitive.ml b/typing/primitive.ml index f99ba950003..5ac235960aa 100644 --- a/typing/primitive.ml +++ b/typing/primitive.ml @@ -600,6 +600,66 @@ let prim_has_valid_reprs ~loc prim = exactly [Same_as_ocaml_repr Bits64; Same_as_ocaml_repr Value] | "%unbox_int64" -> exactly [Same_as_ocaml_repr Value; Same_as_ocaml_repr Bits64] + + (* Bigstring primitives *) + | "%caml_bigstring_get32#" -> + exactly [ + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Bits32] + | "%caml_bigstring_get32u#" -> + exactly [ + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Bits32] + | "%caml_bigstring_get64#" -> + exactly [ + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Bits64] + | "%caml_bigstring_get64u#" -> + exactly [ + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Bits64] + + (* CR layouts: add these when we have unboxed simd layouts *) + (* | "%caml_bigstring_getu128#" -> + | "%caml_bigstring_getu128u#" -> + | "%caml_bigstring_geta128#" -> + | "%caml_bigstring_geta128u#" -> *) + + | "%caml_bigstring_set32#" -> + exactly [ + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Bits32; + Same_as_ocaml_repr Value] + | "%caml_bigstring_set32u#" -> + exactly [ + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Bits32; + Same_as_ocaml_repr Value] + | "%caml_bigstring_set64#" -> + exactly [ + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Bits64; + Same_as_ocaml_repr Value] + | "%caml_bigstring_set64u#" -> + exactly [ + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Bits64; + Same_as_ocaml_repr Value] + + (* CR layouts: add these when we have unboxed simd layouts *) + (* | "%caml_bigstring_setu128#" -> + | "%caml_bigstring_setu128u#" -> + | "%caml_bigstring_seta128#" -> + | "%caml_bigstring_seta128u#" -> *) + | name when is_builtin_prim_name name -> no_non_value_repr