From 8f5c9862c56068e693ea3477e553a07a57278dbd Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 2 Nov 2023 13:31:46 +0000 Subject: [PATCH] flambda-backend: make promote-failed --- .../backtrace_dynlink.flambda.reference | 24 +++-- .../locations_test.compilers.reference | 2 +- testsuite/tests/typing-gadts/test.ml | 6 +- testsuite/tests/typing-layouts/annots_beta.ml | 4 +- testsuite/tests/typing-local/local.ml | 18 +--- .../tests/unboxed-primitive-args/common.ml | 37 +++++++- .../tests/unboxed-primitive-args/common.mli | 2 + .../tests/unboxed-primitive-args/gen_test.ml | 89 ++++++++++++++----- .../tests/unboxed-primitive-args/test.ml | 3 +- .../unboxed-primitive-args/test_common.c | 17 ++++ .../unboxed-primitive-args/test_common.h | 24 +++-- 11 files changed, 160 insertions(+), 66 deletions(-) diff --git a/testsuite/tests/backtrace/backtrace_dynlink.flambda.reference b/testsuite/tests/backtrace/backtrace_dynlink.flambda.reference index 62a7237d2de..dec39927958 100644 --- a/testsuite/tests/backtrace/backtrace_dynlink.flambda.reference +++ b/testsuite/tests/backtrace/backtrace_dynlink.flambda.reference @@ -1,28 +1,24 @@ Raised by primitive operation at Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 6, characters 13-38 -Called from Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 292, characters 8-25 -Called from Dynlink.Native.run.(fun) in file "otherlibs/dynlink/dynlink.ml" (inlined), line 312, characters 25-58 +Called from Dynlink_internal_native.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 112, characters 8-25 +Called from Dynlink_internal_native.Native.run.(fun) in file "otherlibs/dynlink/dynlink.ml" (inlined), line 132, characters 25-58 Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 -Called from Dynlink.Native.run in file "otherlibs/dynlink/dynlink.ml", line 312, characters 4-107 +Called from Dynlink_internal_native.Native.run in file "otherlibs/dynlink/dynlink.ml", line 132, characters 4-107 Called from Dynlink_common.Make.load.(fun) in file "otherlibs/dynlink/dynlink_common.ml", line 367, characters 13-72 Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 Called from Dynlink_common.Make.load in file "otherlibs/dynlink/dynlink_common.ml", line 363, characters 8-408 -Called from Dynlink_common.Make.loadfile in file "otherlibs/dynlink/dynlink_common.ml" (inlined), line 378, characters 26-45 -Called from Dynlink.loadfile in file "otherlibs/dynlink/dynlink.ml" (inlined), line 363, characters 20-35 -Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 39, characters 4-52 +Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 39, characters 4-71 execution of module initializers in the shared library failed: Failure("SUCCESS") Raised at Stdlib.failwith in file "stdlib.ml" (inlined), line 34, characters 17-33 Called from Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 3, characters 4-22 Re-raised at Backtrace_dynlink_plugin in file "backtrace_dynlink_plugin.ml", line 8, characters 5-12 -Called from Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 292, characters 8-25 -Called from Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 292, characters 8-25 -Re-raised at Dynlink.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 304, characters 6-137 -Called from Dynlink.Native.run.(fun) in file "otherlibs/dynlink/dynlink.ml" (inlined), line 312, characters 25-58 +Called from Dynlink_internal_native.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 112, characters 8-25 +Called from Dynlink_internal_native.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 112, characters 8-25 +Re-raised at Dynlink_internal_native.Native.ndl_run in file "otherlibs/dynlink/dynlink.ml", line 124, characters 6-137 +Called from Dynlink_internal_native.Native.run.(fun) in file "otherlibs/dynlink/dynlink.ml" (inlined), line 132, characters 25-58 Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 -Called from Dynlink.Native.run in file "otherlibs/dynlink/dynlink.ml", line 312, characters 4-107 +Called from Dynlink_internal_native.Native.run in file "otherlibs/dynlink/dynlink.ml", line 132, characters 4-107 Called from Dynlink_common.Make.load.(fun) in file "otherlibs/dynlink/dynlink_common.ml", line 367, characters 13-72 Called from Stdlib__List.iter in file "list.ml" (inlined), line 116, characters 12-15 Called from Dynlink_common.Make.load in file "otherlibs/dynlink/dynlink_common.ml", line 363, characters 8-408 Re-raised at Dynlink_common.Make.load in file "otherlibs/dynlink/dynlink_common.ml", line 376, characters 8-17 -Called from Dynlink_common.Make.loadfile in file "otherlibs/dynlink/dynlink_common.ml" (inlined), line 378, characters 26-45 -Called from Dynlink.loadfile in file "otherlibs/dynlink/dynlink.ml" (inlined), line 363, characters 20-35 -Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 39, characters 4-52 +Called from Backtrace_dynlink in file "backtrace_dynlink.ml", line 39, characters 4-71 diff --git a/testsuite/tests/parsetree/locations_test.compilers.reference b/testsuite/tests/parsetree/locations_test.compilers.reference index a0624d26ab6..34b79a7092f 100644 --- a/testsuite/tests/parsetree/locations_test.compilers.reference +++ b/testsuite/tests/parsetree/locations_test.compilers.reference @@ -243,7 +243,7 @@ Ptop_def Ppat_constraint pattern (//toplevel//[2,1+4]..[2,1+5]) Ppat_var "x" (//toplevel//[2,1+4]..[2,1+5]) - core_type (//toplevel//[2,1+4]..[2,1+35]) ghost + core_type (//toplevel//[2,1+16]..[2,1+22]) ghost Ptyp_poly 'a core_type (//toplevel//[2,1+16]..[2,1+22]) Ptyp_arrow diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml index dee7f0c1156..d7edb746e17 100644 --- a/testsuite/tests/typing-gadts/test.ml +++ b/testsuite/tests/typing-gadts/test.ml @@ -689,9 +689,9 @@ let f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) = ;; (* fail *) [%%expect{| type (_, _) eq = Eq : ('a, 'a) eq -Lines 3-4, characters 4-15: -3 | ....f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) = -4 | fun Eq o -> o +Line 3, characters 18-72: +3 | let f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) = + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The universal type variable 'b cannot be generalized: it is already bound to another variable. |}];; diff --git a/testsuite/tests/typing-layouts/annots_beta.ml b/testsuite/tests/typing-layouts/annots_beta.ml index a11c881fa5d..69733075c36 100644 --- a/testsuite/tests/typing-layouts/annots_beta.ml +++ b/testsuite/tests/typing-layouts/annots_beta.ml @@ -356,9 +356,9 @@ val f : ('a : float64). 'a -> 'a = let f : type (a : any). a -> a = fun x -> x ;; [%%expect {| -Line 1, characters 4-43: +Line 1, characters 24-30: 1 | let f : type (a : any). a -> a = fun x -> x - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^ Error: The universal type variable 'a was declared to have layout any, but was inferred to have a representable layout. |}] diff --git a/testsuite/tests/typing-local/local.ml b/testsuite/tests/typing-local/local.ml index feba5bc7314..4e7f8ef3e6b 100644 --- a/testsuite/tests/typing-local/local.ml +++ b/testsuite/tests/typing-local/local.ml @@ -171,11 +171,7 @@ let foo () = ((fun y z -> z) : int -> local_ (int -> int)) in () [%%expect{| -Line 3, characters 4-49: -3 | ((fun y z -> z) : int -> local_ (int -> int)) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This expression has type int -> local_ (int -> int) - but an expression was expected of type int -> int -> int +val foo : unit -> unit = |}] let foo () = @@ -195,11 +191,7 @@ let foo () = ((fun y z -> z) : _ -> local_ (_ -> _)) in () [%%expect{| -Line 3, characters 4-43: -3 | ((fun y z -> z) : _ -> local_ (_ -> _)) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This expression has type 'b -> local_ ('c -> 'c) - but an expression was expected of type 'a -> 'a -> 'a +val foo : unit -> unit = |}] let foo () = @@ -2795,11 +2787,7 @@ let foo () = let local_ _bar2 z : int -> int -> int = local_ (fun x y -> x + y + z) in () [%%expect{| -Line 2, characters 6-66: -2 | let local_ _bar1 : int -> int -> int = local_ (fun x y -> x + y) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This expression has type int -> local_ (int -> int) - but an expression was expected of type int -> (int -> int) +val foo : unit -> unit = |}];; let foo () = diff --git a/testsuite/tests/unboxed-primitive-args/common.ml b/testsuite/tests/unboxed-primitive-args/common.ml index 19c0451e05c..f3ed7ca9e78 100644 --- a/testsuite/tests/unboxed-primitive-args/common.ml +++ b/testsuite/tests/unboxed-primitive-args/common.ml @@ -8,6 +8,8 @@ type 'a typ = | Int64 : int64 typ | Nativeint : nativeint typ | Float : float typ + | Float64x2 : float64x2 typ + | Int64x2 : int64x2 typ type 'a proto = | Ret : 'a typ -> 'a proto @@ -44,6 +46,14 @@ let expand_test = function Test (s, fn, a ** b ** c ** d ** e ** f ** Ret g) | T (s, fn, p) -> Test (s, fn, p) +external int64x2_of_int64s : int64 -> int64 -> int64x2 = "" "vec128_of_int64s" [@@noalloc] [@@unboxed] +external int64x2_low_int64 : int64x2 -> int64 = "" "vec128_low_int64" [@@noalloc] [@@unboxed] +external int64x2_high_int64 : int64x2 -> int64 = "" "vec128_high_int64" [@@noalloc] [@@unboxed] + +external float64x2_of_int64s : int64 -> int64 -> float64x2 = "" "vec128_of_int64s" [@@noalloc] [@@unboxed] +external float64x2_low_int64 : float64x2 -> int64 = "" "vec128_low_int64" [@@noalloc] [@@unboxed] +external float64x2_high_int64 : float64x2 -> int64 = "" "vec128_high_int64" [@@noalloc] [@@unboxed] + let string_of : type a. a typ -> a -> string = function | Int -> Int.to_string | Int32 -> Printf.sprintf "%ldl" @@ -51,6 +61,10 @@ let string_of : type a. a typ -> a -> string = function | Nativeint -> Printf.sprintf "%ndn" | Float -> fun f -> Printf.sprintf "float_of_bits 0x%LxL" (Int64.bits_of_float f) + | Int64x2 -> + fun v -> Printf.sprintf "int64x2 %016Lx:%016Lx" (int64x2_high_int64 v) (int64x2_low_int64 v) + | Float64x2 -> + fun v -> Printf.sprintf "float64x2 %016Lx:%016Lx" (float64x2_high_int64 v) (float64x2_low_int64 v) let rec arity : type a. a proto -> int = function | Ret _ -> 0 @@ -59,7 +73,7 @@ let rec arity : type a. a proto -> int = function module Buffer = struct type t = (char, int8_unsigned_elt, c_layout) Array1.t - let arg_size = 8 + let arg_size = 16 let create ~arity : t = Array1.create char c_layout ((arity + 1) * arg_size) @@ -76,6 +90,22 @@ module Buffer = struct external set_int32 : t -> int -> int32 -> unit = "%caml_bigstring_set32" external set_int64 : t -> int -> int64 -> unit = "%caml_bigstring_set64" + let get_int64x2 buf ~arg = + let low, high = get_int64 buf (arg * arg_size), get_int64 buf (arg * arg_size + 8) in + int64x2_of_int64s low high + + let set_int64x2 buf ~arg x = + set_int64 buf (arg * arg_size) (int64x2_low_int64 x); + set_int64 buf ((arg * arg_size) + 8) (int64x2_high_int64 x) + + let get_float64x2 buf ~arg = + let low, high = get_int64 buf (arg * arg_size), get_int64 buf (arg * arg_size + 8) in + float64x2_of_int64s low high + + let set_float64x2 buf ~arg x = + set_int64 buf (arg * arg_size) (float64x2_low_int64 x); + set_int64 buf ((arg * arg_size) + 8) (float64x2_high_int64 x) + let get_int32 t ~arg = get_int32 t (arg * arg_size) let get_int64 t ~arg = get_int64 t (arg * arg_size) let set_int32 t ~arg x = set_int32 t (arg * arg_size) x @@ -110,6 +140,8 @@ module Buffer = struct | Int64 -> get_int64 | Nativeint -> get_nativeint | Float -> get_float + | Int64x2 -> get_int64x2 + | Float64x2 -> get_float64x2 let set : type a. a typ -> t -> arg:int -> a -> unit = function | Int -> set_int @@ -117,6 +149,8 @@ module Buffer = struct | Int64 -> set_int64 | Nativeint -> set_nativeint | Float -> set_float + | Int64x2 -> set_int64x2 + | Float64x2 -> set_float64x2 (* This is almost a memcpy except that we use get/set which should ensure that the values in [dst] don't overflow. *) @@ -161,6 +195,7 @@ let typ_size : type a. a typ -> int = function | Int64 -> 8 | Nativeint -> Sys.word_size / 8 | Float -> 8 + | Int64x2 | Float64x2 -> 16 let rec sizes : type a. a proto -> int list = function | Ret typ -> [typ_size typ] diff --git a/testsuite/tests/unboxed-primitive-args/common.mli b/testsuite/tests/unboxed-primitive-args/common.mli index b7459bb1027..454c589ffb5 100644 --- a/testsuite/tests/unboxed-primitive-args/common.mli +++ b/testsuite/tests/unboxed-primitive-args/common.mli @@ -5,6 +5,8 @@ type 'a typ = | Int64 : int64 typ | Nativeint : nativeint typ | Float : float typ + | Float64x2 : float64x2 typ + | Int64x2 : int64x2 typ type 'a proto = | Ret : 'a typ -> 'a proto diff --git a/testsuite/tests/unboxed-primitive-args/gen_test.ml b/testsuite/tests/unboxed-primitive-args/gen_test.ml index 8f4b2dfe59d..5c54dc0996a 100644 --- a/testsuite/tests/unboxed-primitive-args/gen_test.ml +++ b/testsuite/tests/unboxed-primitive-args/gen_test.ml @@ -4,14 +4,17 @@ open StdLabels type boxed_integer = Pnativeint | Pint32 | Pint64 +type boxed_vector = Pint64x2 | Pfloat64x2 + type native_repr = | Same_as_ocaml_repr | Unboxed_float | Unboxed_integer of boxed_integer | Untagged_int + | Unboxed_vector of boxed_vector (* Generate primitives with up to this number of arguments *) -let test_all_combination_up_to_n_args = 6 +let test_all_combination_up_to_n_args = 5 (* Generate primitives using all combination of these argument representations. No need to test all combination of other @@ -27,6 +30,8 @@ let test_all_args_combination_of = [ Unboxed_float ; Unboxed_integer Pint32 ; Unboxed_integer Pint64 + ; Unboxed_vector Pint64x2 + ; Unboxed_vector Pfloat64x2 ] let code_of_repr = function @@ -36,6 +41,8 @@ let code_of_repr = function | Unboxed_integer Pint64 -> "L" | Unboxed_integer Pnativeint -> "n" | Untagged_int -> "i" + | Unboxed_vector Pint64x2 -> "I" + | Unboxed_vector Pfloat64x2 -> "x" let repr_of_code = function | 'v' -> Same_as_ocaml_repr @@ -44,6 +51,8 @@ let repr_of_code = function | 'L' -> Unboxed_integer Pint64 | 'n' -> Unboxed_integer Pnativeint | 'i' -> Untagged_int + | 'x' -> Unboxed_vector Pfloat64x2 + | 'I' -> Unboxed_vector Pint64x2 | _ -> assert false let manual_tests = @@ -53,10 +62,15 @@ let manual_tests = ; "L_L" ; "n_n" ; "i_i" + ; "x_x" ; "f_fffff" ; "f_ffffff" ; "f_fffffff" ; "f_fffffffffffffffff" + ; "x_xxxxx" + ; "x_xxxxxx" + ; "x_xxxxxxx" + ; "x_xxxxxxxxxxxxxxxxx" ; "v_iiiiiiiiiiiiiiiii" ; "v_lllllllllllllllll" ; "v_LLLLLLLLLLLLLLLLL" @@ -64,6 +78,11 @@ let manual_tests = ; "v_LiLiLiLiLiLiLiLiL" ; "v_flflflflflflflflflflflflflflflflflfl" ; "v_fLfLfLfLfLfLfLfLfLfLfLfLfLfLfLfLfLfL" + ; "v_xfxfxfxfxfxfxfxfx" + ; "v_fxfxfxfxfxfxfxfxf" + ; "v_lfxlfxlfxlfxlfxlfx" + ; "v_lflxlxlflflxlxlflx" + ; "v_llllllfffffflxxllxx" ] let ocaml_type_of_repr = function @@ -74,6 +93,8 @@ let ocaml_type_of_repr = function | Unboxed_integer Pint64 -> "(int64 [@unboxed])" | Unboxed_integer Pnativeint -> "(nativeint [@unboxed])" | Untagged_int -> "(int [@untagged])" + | Unboxed_vector Pfloat64x2 -> "(float64x2 [@unboxed])" + | Unboxed_vector Pint64x2 -> "(int64x2 [@unboxed])" let ocaml_type_gadt_of_repr = function (* Doesn't really matters what we choose for this case *) @@ -83,6 +104,8 @@ let ocaml_type_gadt_of_repr = function | Unboxed_integer Pint64 -> "Int64" | Unboxed_integer Pnativeint -> "Nativeint" | Untagged_int -> "Int" + | Unboxed_vector Pfloat64x2 -> "Float64x2" + | Unboxed_vector Pint64x2 -> "Int64x2" let c_type_of_repr = function | Same_as_ocaml_repr -> "value" @@ -91,6 +114,8 @@ let c_type_of_repr = function | Unboxed_integer Pint64 -> "int64_t" | Unboxed_integer Pnativeint -> "intnat" | Untagged_int -> "intnat" + | Unboxed_vector Pfloat64x2 -> "__m128d" + | Unboxed_vector Pint64x2 -> "__m128i" type proto = { params : native_repr list @@ -161,29 +186,47 @@ let iter_protos ~f = let pr fmt = Printf.ksprintf (fun s -> print_string s; print_char '\n') fmt let generate_ml () = - pr "open Common"; - pr ""; + let close, print_test = + let n = 2048 in + let i = ref 0 in + let file = ref None in + let close () = + match !file with + | Some file -> + Printf.fprintf file "\nlet run () = run_tests (List.rev tests)\n%!"; + Out_channel.close file + | None -> () + in + let new_file () = + close (); + let next = open_out (Printf.sprintf "test%d.ml" (!i / n)) in + pr "let () = Test%d.run ()" (!i / n); + file := Some next; + Printf.fprintf next "open Common\n"; + Printf.fprintf next "let tests = []\n\n"; + in + close, fun ext test -> + if !i mod n = 0 then new_file (); + Printf.fprintf (Option.get !file) "%s\n%s\n" ext test; + incr i + in iter_protos ~f:(fun proto -> let name = function_name_of_proto proto in - pr "external %s : %s = \"\" %S [@@noalloc]" - name (ocaml_type_of_proto proto) name; - ); - pr ""; - pr "let tests = []"; - iter_protos ~f:(fun proto -> + let ext = Format.sprintf "external %s : %s = \"\" %S [@@@@noalloc]" + name (ocaml_type_of_proto proto) name in let name = function_name_of_proto proto in let arity = List.length proto.params in - if arity <= 6 then - pr "let tests = T%d (%S, %s, %s, %s) :: tests" - arity name name - (List.map proto.params ~f:ocaml_type_gadt_of_repr - |> String.concat ~sep:", ") - (ocaml_type_gadt_of_repr proto.return) + let test = if arity <= 6 then + Format.sprintf "let tests = T%d (%S, %s, %s, %s) :: tests" + arity name name + (List.map proto.params ~f:ocaml_type_gadt_of_repr + |> String.concat ~sep:", ") + (ocaml_type_gadt_of_repr proto.return) else - pr "let tests = T (%S, %s, %s) :: tests" - name name (ocaml_type_gadt_of_proto proto)); - pr ""; - pr "let () = run_tests (List.rev tests)" + Format.sprintf "let tests = T (%S, %s, %s) :: tests" + name name (ocaml_type_gadt_of_proto proto) in + print_test ext test); + close () let generate_stubs () = pr "#include "; @@ -205,7 +248,9 @@ let generate_stubs () = | Unboxed_integer Pint32 -> "set_int32(%d, x%d)" | Unboxed_integer Pint64 -> "set_int64(%d, x%d)" | Unboxed_integer Pnativeint -> "set_intnat(%d, x%d)" - | Untagged_int -> "set_intnat(%d, x%d)") + | Untagged_int -> "set_intnat(%d, x%d)" + | Unboxed_vector Pint64x2 -> "set_int128(%d, x%d)" + | Unboxed_vector Pfloat64x2 -> "set_float128(%d, x%d)") i i); pr " return %(%d%);" (match proto.return with @@ -214,7 +259,9 @@ let generate_stubs () = | Unboxed_integer Pint32 -> "get_int32(%d)" | Unboxed_integer Pint64 -> "get_int64(%d)" | Unboxed_integer Pnativeint -> "get_intnat(%d)" - | Untagged_int -> "get_intnat(%d)") + | Untagged_int -> "get_intnat(%d)" + | Unboxed_vector Pint64x2 -> "get_int128(%d)" + | Unboxed_vector Pfloat64x2 -> "get_float128(%d)") (List.length proto.params); pr "}" ) diff --git a/testsuite/tests/unboxed-primitive-args/test.ml b/testsuite/tests/unboxed-primitive-args/test.ml index 49819fac412..e84a8607ef8 100644 --- a/testsuite/tests/unboxed-primitive-args/test.ml +++ b/testsuite/tests/unboxed-primitive-args/test.ml @@ -12,7 +12,8 @@ compiler_output = "stubs.c" arguments = "ml" compiler_output = "main.ml" **** ocamlopt.opt -all_modules = "test_common.c stubs.c common.mli common.ml main.ml" +ocamlopt_flags = "-extension simd -cc '${cc} -msse4.2'" +all_modules = "test_common.c stubs.c common.mli common.ml test0.ml test1.ml main.ml" ***** run ****** check-program-output diff --git a/testsuite/tests/unboxed-primitive-args/test_common.c b/testsuite/tests/unboxed-primitive-args/test_common.c index c6b873c5147..9f453c354ce 100644 --- a/testsuite/tests/unboxed-primitive-args/test_common.c +++ b/testsuite/tests/unboxed-primitive-args/test_common.c @@ -15,6 +15,8 @@ #include #include +#include +#include char *ocaml_buffer; char *c_buffer; @@ -35,3 +37,18 @@ double test_cleanup_float(void) { return 0.; } + +int64_t vec128_low_int64(__m128i v) +{ + return _mm_extract_epi64(v, 0); +} + +int64_t vec128_high_int64(__m128i v) +{ + return _mm_extract_epi64(v, 1); +} + +__m128i vec128_of_int64s(int64_t low, int64_t high) +{ + return _mm_set_epi64x(high, low); +} diff --git a/testsuite/tests/unboxed-primitive-args/test_common.h b/testsuite/tests/unboxed-primitive-args/test_common.h index 2a1019ca398..93e9a85b680 100644 --- a/testsuite/tests/unboxed-primitive-args/test_common.h +++ b/testsuite/tests/unboxed-primitive-args/test_common.h @@ -16,6 +16,8 @@ #ifndef __TEST_COMMON_H #define __TEST_COMMON_H +#include + /* Where the OCaml side stores the arguments and result for a test case. The C function will read the result it is supposed to return from this buffer. @@ -31,14 +33,20 @@ extern char *ocaml_buffer; equal. */ extern char *c_buffer; -#define get_intnat(n) *(intnat*)(ocaml_buffer+((n)*8)) -#define get_int32(n) *(int32_t*)(ocaml_buffer+((n)*8)) -#define get_int64(n) *(int64_t*)(ocaml_buffer+((n)*8)) -#define get_double(n) *(double*)(ocaml_buffer+((n)*8)) +#define STRIDE 16 + +#define get_intnat(n) *(intnat*)(ocaml_buffer+((n)*STRIDE)) +#define get_int32(n) *(int32_t*)(ocaml_buffer+((n)*STRIDE)) +#define get_int64(n) *(int64_t*)(ocaml_buffer+((n)*STRIDE)) +#define get_double(n) *(double*)(ocaml_buffer+((n)*STRIDE)) +#define get_int128(n) _mm_loadu_si128((__m128i*)(ocaml_buffer+((n)*STRIDE))) +#define get_float128(n) _mm_loadu_pd((double*)(ocaml_buffer+((n)*STRIDE))) -#define set_intnat(n, x) *(intnat*)(c_buffer+((n)*8)) = (x) -#define set_int32(n, x) *(int32_t*)(c_buffer+((n)*8)) = (x) -#define set_int64(n, x) *(int64_t*)(c_buffer+((n)*8)) = (x) -#define set_double(n, x) *(double*)(c_buffer+((n)*8)) = (x) +#define set_intnat(n, x) *(intnat*)(c_buffer+((n)*STRIDE)) = (x) +#define set_int32(n, x) *(int32_t*)(c_buffer+((n)*STRIDE)) = (x) +#define set_int64(n, x) *(int64_t*)(c_buffer+((n)*STRIDE)) = (x) +#define set_double(n, x) *(double*)(c_buffer+((n)*STRIDE)) = (x) +#define set_int128(n, x) _mm_storeu_si128((__m128i*)(c_buffer+((n)*STRIDE)), (x)) +#define set_float128(n, x) _mm_storeu_pd((double*)(c_buffer+((n)*STRIDE)), (x)) #endif /* __TEST_COMMON_H */